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

[Sean Seefried]

> 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)