[Template-haskell] example of derive using Template Haskell?
S. Alexander Jacobson
alex at alexjacobson.com
Thu Jan 13 15:22:15 EST 2005
This is really great. Do you have an example of
use of each of these functions?
e.g. do I do:
$(derive [Int,String,MyTime])
or
$(derive ["Int","String","MyTime"])
-Alex-
______________________________________________________________
S. Alexander Jacobson tel:917-770-6565 http://alexjacobson.com
On Wed, 12 Jan 2005, Sean Seefried wrote:
>
>> I have {-# OPTIONS -fglasgow-exts #-} at the top of both modules. Does
>> that not imply -fth?
>>
>> I do realize that my example is not valid Haskell code. I am looking for
>> an example of valid Haskell code that allows me to derive a class.
>>
>> Or even just an example of actualy usage of [d|...] that works with GHC
>> 6.2.2!
>>
>> SO far I haven't been able to find one.
>>
>
> The following module derives Data and Typeable instances. I hope it's of some
> use to you.
>
> Sean
>
> --------------
>
> {-# OPTIONS -fth #-}
> --
> -- The bulk of this module was shamelessly ripped from Ulf Norell,
> -- winner of the Succ-zeroth International Obfuscated Haskell Code Contest.
> I
> -- mention this as it was from his winning entry that this module began.
> --
> --
> -- I have extended it to deal with data definitions with type variables.
> -- I also added the coments.
> --
> -- Sean Seefried 2004
> --
>
> module DeriveData.DeriveData where
>
> import Language.Haskell.TH
> import Data.List
> import Data.Char
> import Data.Generics
> import Control.Monad
>
> -- maximum type paramters for a Typeable instance
> maxTypeParams = 7
>
>
> --
> -- | Takes the name of an algebraic data type, the number of type parameters
> -- it has and creates a Typeable instance for it.
> deriveTypeable :: Name -> Int -> Q [Dec]
> deriveTypeable name nParam
> | nParam <= maxTypeParams =
> sequence
> [ instanceD (return [])
> (conT typeableName `appT` conT name)
> [ funD typeOfName [clause [wildP] (normalB
> [| mkTyConApp (mkTyCon $(litE $ stringL (nameBase name))) [] |])
> []]
> ]
> ]
> | otherwise = error ("Typeable classes can only have a maximum of " ++
> show maxTypeParams ++ " parameters")
> where
> typeableName
> | nParam == 0 = mkName "Typeable"
> | otherwise = mkName ("Typeable" ++ show nParam)
> typeOfName
> | nParam == 0 = mkName "typeOf"
> | otherwise = mkName ("typeOf" ++ show nParam)
>
> --
> -- | Takes a name of a algebraic data type, the number of parameters it
> -- has and a list of constructor pairs. Each one of these constructor
> -- pairs consists of a constructor name and the number of type
> -- parameters it has. The function returns an automatically generated
> -- instance declaration for the Data class.
> --
> -- Doesn't do gunfold, dataCast1 or dataCast2
> deriveData :: Name -> Int -> [(Name, Int)] -> Q [Dec]
> deriveData name nParam cons =
> sequence (
> conDecs ++
>
> [ dataTypeDec
> , instanceD context
> (conT ''Data `appT` (foldl1 appT ([conT name] ++ typeQParams)))
> [ funD 'gfoldl
> [ clause (map (varP . mkName) ["f", "z", "x"])
> (normalB $ caseE (varE (mkName "x")) (map mkMatch cons))
> []
> ]
> , funD 'gunfold
> [clause [wildP, wildP, wildP ]
> (normalB [| error "gunfoldl not defined" |]) []]
> , funD 'toConstr
> [ clause [varP (mkName "x")]
> (normalB $ caseE (varE (mkName "x"))
> (zipWith mkSel cons conVarExps))
> []
> ]
> , funD 'dataTypeOf
> [ clause [wildP] (normalB $ varE (mkName dataTypeName)) []
> ]
> ]
> ])
> where
> paramNames = take nParam (zipWith (++) (repeat "a") (map show [0..]))
> typeQParams = map (\nm -> varT (mkName nm)) paramNames
> context = cxt (map (\typ -> conT ''Data `appT` typ) typeQParams)
>
> -- Takes a pair (constructor name, number of type arguments) and
> -- creates the correct definition for gfoldl
> -- It is of the form z <constr name> `f` arg1 `f` ... `f` argn
> mkMatch (c,n) =
> do vs <- mapM (\s -> newName s) names
> match (conP c $ map varP vs)
> (normalB $ foldl
> (\e x -> (varE (mkName "f") `appE` e) `appE` varE
> x)
> (varE (mkName "z") `appE` conE c)
> vs
> ) []
> where names = take n (zipWith (++) (repeat "x") (map show [0..]))
> lowCaseName = map toLower nameStr
> nameStr = nameBase name
> dataTypeName = lowCaseName ++ "DataType"
> -- Creates dataTypeDec of the form:
> -- <name>DataType = mkDataType <name> [<constructors]
> dataTypeDec = funD (mkName dataTypeName)
> [clause []
> (normalB
> [| mkDataType nameStr $(listE (conVarExps)) |]) [] ]
> -- conVarExps is a [ExpQ]. Each ExpQ is a variable
> expression
> -- of form varE (mkName <con>Constr)
> numCons = length cons
> constrNames =
> take numCons (map (\i -> dataTypeName ++ show i ++ "Constr") [1..])
> conNames = map (nameBase . fst) cons
> conVarExps = map (varE . mkName) constrNames
> conDecs = zipWith mkConstrDec constrNames conNames
> where
> mkConstrDec decNm conNm =
> funD (mkName decNm)
> [clause []
> (normalB
> [| mkConstr $(varE (mkName dataTypeName)) conNm []
> $(fixity conNm)
> |]) []]
> fixity (':':_) = [| Infix |]
> fixity _ = [| Prefix |]
>
> mkSel (c,n) e = match (conP c $ replicate n wildP)
> (normalB e) []
>
> deriveMinimalData :: Name -> Int -> Q [Dec]
> deriveMinimalData name nParam = do
> decs <- qOfDecs
> let listOfDecQ = map return decs
> sequence
> [ instanceD context
> (conT ''Data `appT` (foldl1 appT ([conT name] ++ typeQParams)))
> listOfDecQ ]
>
> where
> paramNames = take nParam (zipWith (++) (repeat "a") (map show [0..]))
> typeQParams = map (\nm -> varT (mkName nm)) paramNames
> context = cxt (map (\typ -> conT ''Data `appT` typ) typeQParams)
> qOfDecs =
> [d| gunfold _ _ _ = error ("gunfold not defined")
> toConstr x = error ("toConstr not defined for " ++
> show (typeOf x))
> dataTypeOf x = error ("dataTypeOf not implemented for " ++
> show (typeOf x))
> gfoldl f z x = z x
> |]
>
> {- instance Data NameSet where
> gunfold _ _ _ = error ("gunfold not implemented")
> toConstr x = error ("toConstr not implemented for " ++ show (typeOf x))
> dataTypeOf x = error ("dataTypeOf not implemented for " ++ show (typeOf x))
> gfoldl f z x = z x -}
>
> typeInfo :: DecQ -> Q (Name, Int, [(Name, Int)])
> typeInfo m =
> do d <- m
> case d of
> d@(DataD _ _ _ _ _) ->
> return $ (simpleName $ name d, paramsA d, consA d)
> d@(NewtypeD _ _ _ _ _) ->
> return $ (simpleName $ name d, paramsA d, consA d)
> _ -> error ("derive: not a data type declaration: " ++ show d)
>
> where
> consA (DataD _ _ _ cs _) = map conA cs
> consA (NewtypeD _ _ _ c _) = [ conA c ]
>
> paramsA (DataD _ _ ps _ _) = length ps
> paramsA (NewtypeD _ _ ps _ _) = length ps
>
>
> conA (NormalC c xs) = (simpleName c, length xs)
> conA (RecC c xs) = (simpleName c, length xs)
> conA (InfixC _ c _) = (simpleName c, 2)
>
> name (DataD _ n _ _ _) = n
> name (NewtypeD _ n _ _ _) = n
> name d = error $ show d
>
> simpleName :: Name -> Name
> simpleName nm =
> let s = nameBase nm
> in case dropWhile (/=':') s of
> [] -> mkName s
> _:[] -> mkName s
> _:t -> mkName t
>
> --
> -- | Derives the Data and Typeable instances for a single given data type.
> --
> deriveOne :: Name -> Q [Dec]
> deriveOne name =
> do info' <- reify name
> case info' of
> TyConI d -> do
> (name, nParam, ca) <- typeInfo ((return d) :: Q Dec)
> t <- deriveTypeable name nParam
> d <- deriveData name nParam ca
> return $ t ++ d
> _ -> error ("derive: can't be used on anything but a type " ++
> "constructor of an algebraic data type")
>
> --
> -- | Derives Data and Typeable instances for a list of data
> -- types. Order is irrelevant. This should be used in favour of
> -- deriveOne since Data and Typeable instances can often depend on
> -- other Data and Typeable instances - e.g. if you are deriving a
> -- large, mutually recursive data type. If you splice the derived
> -- instances in one by one you will need to do it in depedency order
> -- which is difficult in most cases and impossible in the mutually
> -- recursive case. It is better to bring all the instances into
> -- scope at once.
> --
> -- e.g. if
> -- data Foo = Foo Int
> -- is declared in an imported module then
> -- $(derive [''Foo])
> -- will derive the instances for it
> derive :: [Name] -> Q [Dec]
> derive names = do
> decss <- mapM deriveOne names
> return (concat decss)
>
>
> --
> -- | This function is much like deriveOne except that it brings into
> -- scope an instance of Data with minimal definitions. gfoldl will
> -- essentially leave a data structure untouched while gunfoldl,
> -- toConstr and dataTypeOf will yield errors.
> --
> -- This function is useful when you are certain that you will never
> -- wish to transform a particular data type. For instance you may
> -- be transforming another data type that contains other data types,
> -- some of which you wish to transform (perhaps recursively) and
> -- some which you just wish to return unchanged.
> --
> -- Sometimes you will be forced to use deriveMinimalOne because you --
> do not have access to the contructors of the data type (perhaps
> -- because it is an Abstract Data Type). However, should the
> -- interface to the ADT be sufficiently rich it is possible to
> -- define you're own Data and Typeable instances.
> deriveMinimalOne :: Name -> Q [Dec]
> deriveMinimalOne name =
> do info' <- reify name
> case info' of
> TyConI d -> do
> (name, nParam, _) <- typeInfo ((return d) :: Q Dec)
> t <- deriveTypeable name nParam
> d <- deriveMinimalData name nParam
> return $ t ++ d
> _ -> error ("deriveMinimal: can't be used on anything but a type "
> ++
> "constructor of an algebraic data type")
>
>
> deriveMinimal :: [Name] -> Q [Dec]
> deriveMinimal names = do
> decss <- mapM deriveMinimalOne names
> return (concat decss)
>
More information about the template-haskell
mailing list