{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Common.Derive -- Copyright : (c) 2008 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- Summary: Functions for generating support for using a datatype with EMGM. -- -- Generating datatype support can be done in a fully automatic way using -- 'derive' or 'deriveWith', or it can be done piecemeal using a number of other -- functions. For most needs, the automatic approach is fine. But if you find -- you need more control, use the manual deriving approach described here. ----------------------------------------------------------------------------- module Generics.EMGM.Common.Derive ( -- * Automatic Instance Deriving -- -- | The functions 'derive' and 'deriveWith' determine which representations -- can be supported by your datatype. The indications are as follows for each -- class: -- -- ['Rep'] This instance will be generated for every type. -- -- ['FRep', 'FRep2', 'FRep3'] These instances will only be generated for -- functor types (kind @* -> *@). -- -- ['BiFRep2'] This instance will only be generated for bifunctor types (kind -- @* -> * -> *@). derive, deriveWith, Modifier(..), Modifiers, -- * Manual Instance Deriving -- -- | Use the functions in this section for more control over the declarations -- and instances that are generated. -- -- Since each function here generates one component needed for the entire -- datatype representation, you will most likely need to use multiple TH -- declarations. To get the equivalent of the resulting code described in -- 'derive', you will need the following: -- -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE MultiParamTypeClasses #-} -- > {-# LANGUAGE FlexibleContexts #-} -- > {-# LANGUAGE FlexibleInstances #-} -- > {-# LANGUAGE OverlappingInstances #-} -- > {-# LANGUAGE UndecidableInstances #-} -- -- @ -- module Example where -- import Generics.EMGM.Common.Derive -- data T a = C a Int -- @ -- -- @ -- $(declareConDescrs ''T) -- $(declareEP ''T) -- $(deriveRep ''T) -- $(deriveFRep ''T) -- $(deriveCollect ''T) -- @ -- ** Constructor Description Declaration -- -- | Use the following to generate only the 'ConDescr' declarations. declareConDescrs, declareConDescrsWith, -- ** Embedding-Project Pair Declaration -- -- | Use the following to generate only the 'EP' declarations. declareEP, declareEPWith, -- ** Rep Instance Deriving -- -- | Use the following to generate only the 'Rep' instances. deriveRep, deriveRepWith, -- ** FRep Instance Deriving -- -- | Use the following to generate only the 'FRep', 'FRep2', and 'FRep3' -- instances. deriveFRep, deriveFRepWith, -- ** BiFRep Instance Deriving -- -- | Use the following to generate only the 'BiFRep2' instances. deriveBiFRep, deriveBiFRepWith, -- ** Function-Specific Instance Deriving -- -- | Use the following to generate instances specific to certain functions. deriveCollect, ) where ----------------------------------------------------------------------------- -- Imports ----------------------------------------------------------------------------- import Prelude import Language.Haskell.TH import Data.Maybe (catMaybes) import Generics.EMGM.Common.Derive.Common -- We ignore these imports for Haddock, because Haddock does not like Template -- Haskell expressions in many places. -- -- See http://code.google.com/p/emgm/issues/detail?id=21 -- #ifndef __HADDOCK__ import Generics.EMGM.Common.Derive.ConDescr (mkConDescr) import Generics.EMGM.Common.Derive.EP (mkEP) import Generics.EMGM.Common.Derive.Instance #endif -- These are imported only for Haddock. #ifdef __HADDOCK__ import Generics.EMGM.Common.Base import Generics.EMGM.Common.Base2 import Generics.EMGM.Common.Base3 import Generics.EMGM.Common.Representation import Generics.EMGM.Functions.Collect #endif ----------------------------------------------------------------------------- -- General functions ----------------------------------------------------------------------------- #ifndef __HADDOCK__ -- | Make the DT and constructor descriptions declareConDescrsBase :: Modifiers -> Name -> Q (DT, [Dec]) declareConDescrsBase mods typeName = do info <- reify typeName case info of TyConI d -> case d of DataD _ name vars cons _ -> mkDT name vars cons NewtypeD _ name vars con _ -> mkDT name vars [con] _ -> err _ -> err where mkDT name vars cons = do pairs <- mapM (normalizeCon mods) cons let (ncons', cdDecs) = unzip pairs return (DT name vars cons ncons', concat . catMaybes $ cdDecs) err = reportError $ showString "Unsupported name \"" . shows typeName $ "\". Must be data or newtype." -- | Normalize constructor variants normalizeCon :: Modifiers -> Con -> Q (NCon, Maybe [Dec]) normalizeCon mods c = case c of NormalC name args -> mkNCon name (map snd args) RecC name args -> mkNCon name (map $(sel 2 3) args) InfixC argL name argR -> mkNCon name [snd argL, snd argR] ForallC _ _ con -> -- It appears that this ForallC may never be reached, because non-Haskell-98 -- constructors can't be reified according to an error received when trying. do (NCon name _ _ _, _) <- normalizeCon mods con reportError $ showString "Existential data constructors such as \"" . showString (nameBase name) $ "\" are not supported." where mkNCon name args = do let maybeCdMod = lookup (nameBase name) mods (cdName, cdDecs) <- mkConDescr maybeCdMod c let names = newVarNames args return (NCon name cdName args names, cdDecs) -- | For each element in a list, make a new variable name using the character -- 'v' (arbitrary) and a number. newVarNames :: [a] -> [Name] newVarNames = map newVarName . zipWith const [1..] where newVarName :: Int -> Name newVarName = mkName . (:) 'v' . show -------------------------------------------------------------------------------- declareEPBase :: Modifiers -> DT -> Q (Name, [Dec]) declareEPBase mods dt = do fromName <- newName "from" toName <- newName "to" return (mkEP mods dt fromName toName) deriveRepBase :: DT -> Name -> Name -> Q [Dec] deriveRepBase dt epName g = do return [mkRepInst epName g dt] deriveFRepBase :: DT -> Name -> Name -> Name -> Q [Dec] deriveFRepBase dt epName g ra = return [frepInstDec, frep2InstDec, frep3InstDec] where frepInstDec = mkFRepInst ra epName g dt frep2InstDec = mkFRep2Inst ra epName g dt frep3InstDec = mkFRep3Inst ra epName g dt deriveBiFRepBase :: DT -> Name -> Name -> Name -> Name -> Q [Dec] deriveBiFRepBase dt epName g ra rb = return [mkBiFRep2Inst ra rb epName g dt] #endif ----------------------------------------------------------------------------- -- Exported functions ----------------------------------------------------------------------------- -- | Same as 'derive' except that you can pass a list of name modifications to -- the deriving mechanism. -- -- Use @deriveWith@ if: -- -- (1) You want to use the generated constructor descriptions or -- embedding-projection pairs /and/ one of your constructors or types is an -- infix symbol. In other words, if you have a constructor @:*@, you cannot -- refer to the (invalid) generated name for its description, @con:*@. It -- appears that GHC has no problem with that name internally, so this is only -- if you want access to it. -- -- (2) You want to define your own constructor description. This allows you to -- give a precise implementation different from the one generated for you. -- -- For option 1, use 'ChangeTo' as in this example: -- -- @ -- data U = Int :* Char -- $(deriveWith [(\":*\", ChangeTo \"Star\")] ''U) -- x = ... conStar ... -- @ -- -- For option 2, use 'DefinedAs' as in this example: -- -- @ -- data V = (:=) { i :: Int, j :: Char } -- $(deriveWith [(\":=\", DefinedAs \"Equals\")] ''V) -- conEquals = 'ConDescr' \":=\" 2 [] ('Infix' 4) -- @ -- -- Using the example for option 2 with "Generics.EMGM.Functions.Show" will print -- values of @V@ as infix instead of the default record syntax. -- -- Note that only the first pair with its first field matching the type or -- constructor name in the 'Modifiers' list will be used. Any other matches will -- be ignored. deriveWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ deriveWith mods typeName = do (dt, conDescrDecs) <- declareConDescrsBase mods typeName (epName, epDecs) <- declareEPBase mods dt g <- newName "g" repInstDecs <- deriveRepBase dt epName g ra <- newName "ra" frepInstDecs <- deriveFRepBase dt epName g ra rb <- newName "rb" bifrepInstDecs <- deriveBiFRepBase dt epName g ra rb let higherOrderRepInstDecs = case length (tvars dt) of 1 -> frepInstDecs 2 -> bifrepInstDecs _ -> [] collectInstDec <- mkRepCollectInst dt return $ conDescrDecs ++ epDecs ++ repInstDecs ++ higherOrderRepInstDecs ++ [collectInstDec] #else deriveWith = undefined #endif -- | Derive all appropriate instances for using EMGM with a datatype. -- -- Here is an example module that shows how to use @derive@: -- -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE MultiParamTypeClasses #-} -- > {-# LANGUAGE FlexibleContexts #-} -- > {-# LANGUAGE FlexibleInstances #-} -- > {-# LANGUAGE OverlappingInstances #-} -- > {-# LANGUAGE UndecidableInstances #-} -- -- @ -- module Example where -- import "Generics.EMGM" -- data T a = C a 'Int' -- @ -- -- @ -- $(derive ''T) -- @ -- -- The Template Haskell @derive@ declaration in the above example generates the -- following (annotated) code: -- -- @ -- -- (1) Constructor description declarations (1 per constructor) -- @ -- -- @ -- conC :: 'ConDescr' -- conC = 'ConDescr' \"C\" 2 [] 'Nonfix' -- @ -- -- @ -- -- (2) Embedding-projection pair declarations (1 per type) -- @ -- -- @ -- epT :: 'EP' (T a) (a :*: 'Int') -- epT = 'EP' fromT toT -- where fromT (C v1 v2) = v1 :*: v2 -- toT (v1 :*: v2) = C v1 v2 -- @ -- -- @ -- -- (3) 'Rep' instance (1 per type) -- @ -- -- @ -- instance ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => 'Rep' g (T a) where -- 'rep' = 'rtype' epT ('rcon' conC ('rprod' 'rep' 'rep')) -- @ -- -- @ -- -- (4) Higher arity instances if applicable (either 'FRep', 'FRep2', and -- -- 'FRep3' together, or 'BiFRep2') -- @ -- -- @ -- instance ('Generic' g) => 'FRep' g T where -- 'frep' ra = 'rtype' epT ('rcon' conC ('rprod' ra 'rint')) -- @ -- -- @ -- -- In this case, similar instances would be generated for 'FRep2' and 'FRep3'. -- @ -- -- @ -- -- (5) Function-specific instances (1 per type) -- @ -- -- @ -- instance 'Rep' ('Collect' 'Char') 'Char' where -- 'rep' = 'Collect' (:[]) -- @ -- -- Note that the constructor description @conC@ and embedding-project pair @epT@ -- are top-level values. This allows them to be shared between multiple -- instances. If these names conflict with your own, you may want to put the -- @$(derive ...)@ declaration in its own module and restrict the export list. derive :: Name -> Q [Dec] derive = deriveWith [] -------------------------------------------------------------------------------- -- | Same as 'declareConDescrs' except that you can pass a list of name -- modifications to the deriving mechanism. See 'deriveWith' for an example. declareConDescrsWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ declareConDescrsWith mods typeName = do (_, conDescrDecs) <- declareConDescrsBase mods typeName return conDescrDecs #else declareConDescrsWith = undefined #endif -- | Generate declarations of 'ConDescr' values for all constructors in a type. -- See 'derive' for an example. declareConDescrs :: Name -> Q [Dec] declareConDescrs = declareConDescrsWith [] -------------------------------------------------------------------------------- -- | Same as 'declareEP' except that you can pass a list of name modifications -- to the deriving mechanism. See 'deriveWith' for an example. declareEPWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ declareEPWith mods typeName = do (dt, _) <- declareConDescrsBase mods typeName (_, epDecs) <- declareEPBase mods dt return epDecs #else declareEPWith = undefined #endif -- | Generate declarations of 'EP' values for a type. See 'derive' for an -- example. declareEP :: Name -> Q [Dec] declareEP = declareEPWith [] -------------------------------------------------------------------------------- -- | Same as 'deriveRep' except that you can pass a list of name modifications -- to the deriving mechanism. See 'deriveWith' for an example. deriveRepWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ deriveRepWith mods typeName = do (dt, _) <- declareConDescrsBase mods typeName (epName, _) <- declareEPBase mods dt g <- newName "g" repInstDecs <- deriveRepBase dt epName g return repInstDecs #else deriveRepWith = undefined #endif -- | Generate 'Rep' instance declarations for a type. See 'derive' for an -- example. deriveRep :: Name -> Q [Dec] deriveRep = deriveRepWith [] -------------------------------------------------------------------------------- -- | Same as 'deriveFRep' except that you can pass a list of name modifications -- to the deriving mechanism. See 'deriveWith' for an example. deriveFRepWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ deriveFRepWith mods typeName = do (dt, _) <- declareConDescrsBase mods typeName (epName, _) <- declareEPBase mods dt g <- newName "g" ra <- newName "ra" frepInstDecs <- deriveFRepBase dt epName g ra return frepInstDecs #else deriveFRepWith = undefined #endif -- | Generate 'FRep', 'FRep2', and 'FRep3' instance declarations for a type. See -- 'derive' for an example. deriveFRep :: Name -> Q [Dec] deriveFRep = deriveFRepWith [] -------------------------------------------------------------------------------- -- | Same as 'deriveBiFRep' except that you can pass a list of name -- modifications to the deriving mechanism. See 'deriveWith' for an example. deriveBiFRepWith :: Modifiers -> Name -> Q [Dec] #ifndef __HADDOCK__ deriveBiFRepWith mods typeName = do (dt, _) <- declareConDescrsBase mods typeName (epName, _) <- declareEPBase mods dt g <- newName "g" ra <- newName "ra" rb <- newName "rb" bifrepInstDecs <- deriveBiFRepBase dt epName g ra rb return bifrepInstDecs #else deriveBiFRepWith = undefined #endif -- | Generate 'BiFRep2' instance declarations for a type. See 'derive' for an -- example. deriveBiFRep :: Name -> Q [Dec] deriveBiFRep = deriveBiFRepWith [] -------------------------------------------------------------------------------- -- | Generate a @'Rep' 'Collect' T@ instance declaration for a type @T@. See -- 'derive' for an example. deriveCollect :: Name -> Q [Dec] #ifndef __HADDOCK__ deriveCollect typeName = do (dt, _) <- declareConDescrsBase [] typeName collectInstDec <- mkRepCollectInst dt return [collectInstDec] #else deriveCollect = undefined #endif