syb-with-class-0.3: Data/Generics/SYB/WithClass/Derive.hs
{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-- We can't warn about missing sigs as we have a group of decls in
-- quasi-quotes that we're going to put in a class instance
--
-- Ulf Norell, 2004
-- Started this module.
--
-- Sean Seefried, 2004
-- Extension for data definitions with type variables; comments added.
-- http://www.haskell.org/pipermail/template-haskell/2005-January/000393.html
--
-- Simon D. Foster, 2004--2005
-- Extended to work with SYB3.
--
-- Ralf Lammel, 2005
-- Integrated with SYB3 source distribution.
--
module Data.Generics.SYB.WithClass.Derive where
import Language.Haskell.TH
import Data.List
import Data.Char
import Control.Monad
import Data.Maybe
import Data.Generics.SYB.WithClass.Basics
-- maximum type paramters for a Typeable instance
maxTypeParams :: Int
maxTypeParams = 7
--
-- | Takes the name of an algebraic data type, the number of type parameters
-- it has and creates a Typeable instance for it.
deriveTypeablePrim :: Name -> Int -> Q [Dec]
deriveTypeablePrim name nParam
#ifdef __HADDOCK__
= undefined
#else
| 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)
#endif
--
-- | 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
deriveDataPrim :: Name -> [Type] -> [(Name, Int)] -> [(Name, [(Maybe Name, Type)])] -> Q [Dec]
deriveDataPrim name typeParams cons terms =
#ifdef __HADDOCK__
undefined
#else
do sequence (
conDecs ++
[ dataTypeDec
, instanceD context (dataCxt myType)
[ funD 'gfoldl
[ clause ([wildP] ++ (map (varP . mkName) ["f", "z", "x"]))
(normalB $ caseE (varE (mkName "x")) (map mkMatch cons))
[]
]
, funD 'gunfold
[clause ([wildP] ++ (map (varP. mkName) ["k", "z", "c"]))
(if (null cons) then (normalB [| error "gunfold : Type has no constructors" |])
else (normalB $ caseE (varE (mkName "constrIndex") `appE` varE (mkName "c")) mkMatches)) []]
, funD 'toConstr
[ clause [wildP, varP (mkName "x")]
(normalB $ caseE (varE (mkName "x"))
(zipWith mkSel cons conVarExps))
[]
]
, funD 'dataTypeOf
[ clause [wildP, wildP] (normalB $ varE (mkName theDataTypeName)) []
]
]
])
where
types = filter (\x -> case x of (VarT _) -> False; _ -> True) $ map snd $ concat $ map snd terms
fieldNames = let fs = map (map fst.snd) terms in
map (\x -> if (null x || all isNothing x) then [] else map (maybe "" show) x) fs
nParam = length typeParams
{- paramNames = take nParam (zipWith (++) (repeat "a") (map show [0..]))
typeQParams = map (\nm -> varT (mkName nm)) paramNames-}
myType = foldl AppT (ConT name) typeParams
dataCxt typ = conT ''Data `appT` varT (mkName "ctx") `appT` return typ
satCxt typ = conT ''Sat `appT` (varT (mkName "ctx") `appT` return typ)
dataCxtTypes = nub (typeParams ++ types)
satCxtTypes = nub (myType : types)
context = cxt (map dataCxt dataCxtTypes ++ map satCxt satCxtTypes)
-- 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 :: Integer ..]))
mkMatches = map (\(n, (cn, i)) -> match (litP $ integerL n) (normalB $ reapply (appE (varE $ mkName "k")) i (varE (mkName "z") `appE` conE cn)) []) (zip [1..] cons)
where
reapply _ 0 f = f
reapply x n f = x (reapply x (n-1) f)
lowCaseName = map toLower nameStr
nameStr = nameBase name
theDataTypeName = lowCaseName ++ "DataType"
-- Creates dataTypeDec of the form:
-- <name>DataType = mkDataType <name> [<constructors]
dataTypeDec = funD (mkName theDataTypeName)
[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 -> theDataTypeName ++ show i ++ "Constr") [1 :: Integer ..])
conNames = map (nameBase . fst) cons
conVarExps = map (varE . mkName) constrNames
conDecs = zipWith3 mkConstrDec constrNames conNames fieldNames
where
mkConstrDec decNm conNm fieldNm =
funD (mkName decNm)
[clause []
(normalB
[| mkConstr $(varE (mkName theDataTypeName)) conNm fieldNm
$(fixity conNm)
|]) []]
fixity (':':_) = [| Infix |]
fixity _ = [| Prefix |]
mkSel (c,n) e = match (conP c $ replicate n wildP)
(normalB e) []
#endif
deriveMinimalData :: Name -> Int -> Q [Dec]
deriveMinimalData name nParam = do
#ifdef __HADDOCK__
undefined
#else
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 :: Integer ..]))
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 _ z x = z x
|]
#endif
{- 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 :: Dec -> Q (Name, [Name], [(Name, Int)], [(Name, [(Maybe Name, Type)])])
typeInfo d =
case d of
DataD _ n ps cs _ ->
return $ (simpleName n, ps, map conA cs, map termA cs)
NewtypeD _ n ps c _ ->
return $ (simpleName n, ps, [conA c], [termA c])
_ -> error ("derive: not a data type declaration: " ++ show d)
where
termA (NormalC c xs) = (c, map (\x -> (Nothing, snd x)) xs)
termA (RecC c xs) = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs)
termA (InfixC t1 c t2) = (c, [(Nothing, snd t1), (Nothing, snd t2)])
termA (ForallC _ _ c) = termA c
conA (NormalC c xs) = (c, length xs)
conA (RecC c xs) = (c, length xs)
conA (InfixC _ c _) = (c, 2)
conA (ForallC _ _ c) = conA c
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 n =
do info' <- reify n
case info' of
TyConI d -> deriveOneDec d
_ -> error ("derive: can't be used on anything but a type " ++
"constructor of an algebraic data type")
deriveOneDec :: Dec -> Q [Dec]
deriveOneDec dec =
do (name, param, ca, terms) <- typeInfo dec
t <- deriveTypeablePrim name (length param)
d <- deriveDataPrim name (map VarT param) ca terms
return (t ++ d)
deriveOneData :: Name -> Q [Dec]
deriveOneData n =
do info' <- reify n
case info' of
TyConI i -> do
(name, param, ca, terms) <- typeInfo i
d <- deriveDataPrim name (map VarT param) ca terms
return 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)
deriveDec :: [Dec] -> Q [Dec]
deriveDec decs = do
decss <- mapM deriveOneDec decs
return (concat decss)
deriveData :: [Name] -> Q [Dec]
deriveData names = do
decss <- mapM deriveOneData names
return (concat decss)
deriveTypeable :: [Name] -> Q [Dec]
deriveTypeable names = do
decss <- mapM deriveOneTypeable names
return (concat decss)
deriveOneTypeable :: Name -> Q [Dec]
deriveOneTypeable n =
do info' <- reify n
case info' of
TyConI i -> do
(name, param, _, _) <- typeInfo i
t <- deriveTypeablePrim name (length param)
return t
_ -> error ("derive: can't be used on anything but a type " ++
"constructor of an algebraic data type")
--
-- | 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 n =
do info' <- reify n
case info' of
TyConI i -> do
(name, param, _, _) <- typeInfo i
t <- deriveTypeablePrim name (length param)
d <- deriveMinimalData name (length param)
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)