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

20 Jan 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> [ 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)