module Generics.Deriving.TH.Pre711 (
deriveMeta
, deriveData
, deriveConstructors
, deriveSelectors
, mkMetaDataType
, mkMetaConsType
, mkMetaSelType
, SelStrictInfo
, reifySelStrictInfo
) where
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Generics.Deriving.TH.Internal
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveMeta :: Name -> Q [Dec]
deriveMeta n =
do a <- deriveData n
b <- deriveConstructors n
c <- deriveSelectors n
return (a ++ b ++ c)
deriveData :: Name -> Q [Dec]
deriveData = dataInstance
deriveConstructors :: Name -> Q [Dec]
deriveConstructors = constrInstance
deriveSelectors :: Name -> Q [Dec]
deriveSelectors = selectInstance
dataInstance :: Name -> Q [Dec]
dataInstance n = do
i <- reifyDataInfo n
case i of
Left _ -> return []
Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT
where
mkInstance n' dv isNT = do
ds <- mkDataData dv n'
is <- mkDataInstance dv n' isNT
return $ [ds,is]
constrInstance :: Name -> Q [Dec]
constrInstance n = do
i <- reifyDataInfo n
case i of
Left _ -> return []
Right (n', _, _, cs, dv) -> mkInstance n' cs dv
where
mkInstance n' cs dv = do
ds <- mapM (mkConstrData dv n') cs
is <- mapM (mkConstrInstance dv n') cs
return $ ds ++ is
selectInstance :: Name -> Q [Dec]
selectInstance n = do
i <- reifyDataInfo n
case i of
Left _ -> return []
Right (n', _, _, cs, dv) -> mkInstance n' cs dv
where
mkInstance n' cs dv = do
ds <- mapM (mkSelectData dv n') cs
is <- mapM (mkSelectInstance dv n') cs
return $ concat (ds ++ is)
mkDataData :: DataVariety -> Name -> Q Dec
mkDataData dv n = dataD (cxt []) (genName dv [n]) [] [] []
mkConstrData :: DataVariety -> Name -> Con -> Q Dec
mkConstrData dv dt (NormalC n _) =
dataD (cxt []) (genName dv [dt, n]) [] [] []
mkConstrData dv dt (RecC n f) =
mkConstrData dv dt (NormalC n (map shrink f))
mkConstrData dv dt (InfixC t1 n t2) =
mkConstrData dv dt (NormalC n [t1,t2])
mkConstrData _ _ con = gadtError con
mkSelectData :: DataVariety -> Name -> Con -> Q [Dec]
mkSelectData dv dt (RecC n fs) = return (map one fs)
where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] [] []
mkSelectData _ _ _ = return []
mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec
mkDataInstance dv n isNewtype =
instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $
[ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]
, funD moduleNameValName [clause [wildP] (normalB (stringE name)) []]
]
#if __GLASGOW_HASKELL__ >= 708
++ if isNewtype
then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]
else []
#endif
where
name = fromMaybe (error "Cannot fetch module name!") (nameModule n)
liftFixity :: Fixity -> Q Exp
liftFixity (Fixity n a) = conE infixDataName
`appE` liftAssociativity a
`appE` lift n
liftAssociativity :: FixityDirection -> Q Exp
liftAssociativity InfixL = conE leftAssociativeDataName
liftAssociativity InfixR = conE rightAssociativeDataName
liftAssociativity InfixN = conE notAssociativeDataName
mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec
mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False []
mkConstrInstance dv dt (RecC n _) =
mkConstrInstanceWith dv dt n True False
[funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]
mkConstrInstance dv dt (InfixC _ n _) = do
i <- reify n
let fi = case i of
DataConI _ _ _ f -> f
_ -> error $ "Not a data constructor name: " ++ show n
mkConstrInstanceWith dv dt n False True
[funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]
mkConstrInstance _ _ con = gadtError con
mkConstrInstanceWith :: DataVariety
-> Name
-> Name
-> Bool
-> Bool
-> [Q Dec]
-> Q Dec
mkConstrInstanceWith dv dt n isRecord isInfix extra =
instanceD
(cxt [])
(appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix))
(funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]
mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where
one :: Name -> Q Dec
one f =
instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ()))
[funD selNameValName [clause [wildP]
(normalB (litE (stringL (nameBase f)))) []]]
mkSelectInstance _ _ _ = return []
genName :: DataVariety -> [Name] -> Name
genName dv ns = mkName
. showsDataVariety dv
. intercalate "_"
. consQualName
$ map (sanitizeName . nameBase) ns
where
consQualName :: [String] -> [String]
consQualName = case ns of
[] -> id
n:_ -> (showNameQual n :)
mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type
mkMetaDataType dv n _ = conT $ genName dv [n]
mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type
mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n]
mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f]
mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName
type SelStrictInfo = ()
reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo]
reifySelStrictInfo _ bangs = return (map (const ()) bangs)