module Data.Generics.SYB.WithClass.Derive where
import Language.Haskell.TH
import Data.List
import Control.Monad
import Data.Generics.SYB.WithClass.Basics
deriveTypeablePrim :: Name -> Int -> Q [Dec]
deriveTypeablePrim name nParam
#ifdef __HADDOCK__
= undefined
#else
= case index names nParam of
Just (className, methodName) ->
let moduleString = case nameModule name of
Just m -> m ++ "."
Nothing -> ""
typeString = moduleString ++ nameBase name
body = [| mkTyConApp (mkTyCon $(litE $ stringL typeString)) [] |]
method = funD methodName [clause [wildP] (normalB body) []]
in sequence [ instanceD (return [])
(conT className `appT` conT name)
[ method ]
]
Nothing -> error ("Typeable classes can only have a maximum of " ++
show (length names + 1) ++ " parameters")
where index [] _ = Nothing
index (x:_) 0 = Just x
index (_:xs) n = index xs (n 1)
names = [(''Typeable, 'typeOf),
(''Typeable1, 'typeOf1),
(''Typeable2, 'typeOf2),
(''Typeable3, 'typeOf3),
(''Typeable4, 'typeOf4),
(''Typeable5, 'typeOf5),
(''Typeable6, 'typeOf6),
(''Typeable7, 'typeOf7)]
#endif
type Constructor = (Name,
Int,
Maybe [Name],
[Type])
deriveDataPrim :: Name -> [Type] -> [Constructor] -> Q [Dec]
deriveDataPrim name typeParams cons =
#ifdef __HADDOCK__
undefined
#else
do theDataTypeName <- newName $ "dataType_sybwc_" ++ show name
constrNames <- mapM (\(conName,_,_,_) -> newName $ "constr_sybwc_" ++ show conName) cons
let constrExps = map varE constrNames
let mkConstrDec :: Name -> Constructor -> Q [Dec]
mkConstrDec decNm (constrName, _, mfs, _) =
do let constrString = nameBase constrName
fieldNames = case mfs of
Nothing -> []
Just fs -> map nameBase fs
fixity (':':_) = [| Infix |]
fixity _ = [| Prefix |]
body = [| mkConstr $(varE theDataTypeName)
constrString
fieldNames
$(fixity constrString)
|]
sequence [ sigD decNm [t| Constr |],
funD decNm [clause [] (normalB body) []]
]
conDecss <- zipWithM mkConstrDec constrNames cons
let conDecs = concat conDecss
sequence (
map return conDecs ++
[
sigD theDataTypeName [t| DataType |]
,
let nameStr = nameBase name
body = [| mkDataType nameStr $(listE constrExps) |]
in funD theDataTypeName [clause [] (normalB body) []]
,
instanceD context (dataCxt myType)
[
do f <- newName "_f"
z <- newName "z"
x <- newName "x"
let
mkMatch (c, n, _, _)
= do args <- replicateM n (newName "arg")
let applyF e arg = [| $(varE f) $e $(varE arg) |]
body = foldl applyF [| $(varE z) $(conE c) |] args
match (conP c $ map varP args) (normalB body) []
matches = map mkMatch cons
funD 'gfoldl [ clause (wildP : map varP [f, z, x])
(normalB $ caseE (varE x) matches)
[]
]
,
do k <- newName "_k"
z <- newName "z"
c <- newName "c"
let body = if null cons
then [| error "gunfold : Type has no constructors" |]
else caseE [| constrIndex $(varE c) |] matches
mkMatch n (cn, i, _, _)
= match (litP $ integerL n)
(normalB $ reapply (appE (varE k))
i
[| $(varE z) $(conE cn) |]
)
[]
where reapply _ 0 f = f
reapply x j f = x (reapply x (j1) f)
fallThroughMatch
= match wildP (normalB [| error "gunfold: fallthrough" |]) []
matches = zipWith mkMatch [1..] cons ++ [fallThroughMatch]
funD 'gunfold [clause (wildP : map varP [k, z, c])
(normalB body)
[]
]
,
do x <- newName "x"
let mkSel (c, n, _, _) e = match (conP c $ replicate n wildP)
(normalB e)
[]
body = caseE (varE x) (zipWith mkSel cons constrExps)
funD 'toConstr [ clause [wildP, varP x]
(normalB body)
[]
]
,
funD 'dataTypeOf [ clause [wildP, wildP]
(normalB $ varE theDataTypeName)
[]
]
]
])
where notTyVar (VarT _) = False
notTyVar _ = True
types = [ t | (_, _, _, ts) <- cons, t <- ts, notTyVar t ]
myType = foldl AppT (ConT name) typeParams
dataCxt typ = conT ''Data `appT` varT (mkName "ctx") `appT` return typ
dataCxt' typ = return $ ClassP ''Data [VarT (mkName "ctx"), typ]
satCxt typ = return $ ClassP ''Sat [VarT (mkName "ctx") `AppT` typ]
dataCxtTypes = nub (typeParams ++ types)
satCxtTypes = nub (myType : types)
context = cxt (map dataCxt' dataCxtTypes ++ map satCxt satCxtTypes)
#endif
deriveMinimalData :: Name -> Int -> Q [Dec]
deriveMinimalData name nParam = do
#ifdef __HADDOCK__
undefined
#else
decs <- qOfDecs
params <- replicateM nParam (newName "a")
let typeQParams = map varT params
context = cxt (map (\typ -> classP ''Data [typ]) typeQParams)
instanceType = foldl appT (conT name) typeQParams
inst <-instanceD context
(conT ''Data `appT` instanceType)
(map return decs)
return [inst]
where 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
typeInfo :: Dec
-> Q (Name,
[Name],
[Constructor])
typeInfo d
= case d of
DataD _ n ps cs _ -> return (n, map varName ps, map conA cs)
NewtypeD _ n ps c _ -> return (n, map varName ps, [conA c])
_ -> error ("derive: not a data type declaration: " ++ show d)
where conA (NormalC c xs) = (c, length xs, Nothing, map snd xs)
conA (InfixC x1 c x2) = conA (NormalC c [x1, x2])
conA (ForallC _ _ c) = conA c
conA (RecC c xs) = let getField (n, _, _) = n
getType (_, _, t) = t
fields = map getField xs
types = map getType xs
in (c, length xs, Just fields, types)
varName (PlainTV n) = n
varName (KindedTV n _) = n
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, cs) <- typeInfo dec
t <- deriveTypeablePrim name (length param)
d <- deriveDataPrim name (map VarT param) cs
return (t ++ d)
deriveOneData :: Name -> Q [Dec]
deriveOneData n =
do info <- reify n
case info of
TyConI i -> do
(name, param, cs) <- typeInfo i
deriveDataPrim name (map VarT param) cs
_ -> error ("derive: can't be used on anything but a type " ++
"constructor of an algebraic data type")
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
deriveTypeablePrim name (length param)
_ -> error ("derive: can't be used on anything but a type " ++
"constructor of an algebraic data type")
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)