[Template-haskell] example of derive using Template Haskell?

S. Alexander Jacobson alex at alexjacobson.com
Thu Jan 20 18:52:04 EST 2005


So I am starting off just trying to extract the 
list of field names in a data structure e.g. from

   data MyDB = MyDB {name::Prop String
  		   ,age:: Prop Int
 		 } deriving (Show)


I want to be able to derive:

   data DBProps = Name String | Age Int

unfortunately, a LOT has appears to have changed 
since 6.2.2.  For example, Language.Haskell.TH 
doesn't exist in 6.2.2.  Instead I have 
Language.Haskell.THSyntax.    And TyConI doesn't 
exist yet either.


I'm inclined to believe that moving forward on 
Template Haskell with 6.2.2 is pointless.  Is 
there any way of obtaining a build of 6.3 for 
windows (or even better 6.4RC1!)?

-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