module Generics.Deriving.TH (
deriveMeta
, deriveData
, deriveConstructors
, deriveSelectors
, deriveAll
, deriveAll1
, deriveAll0And1
, deriveRepresentable0
, deriveRepresentable1
, deriveRep0
, deriveRep1
, simplInstance
, makeRep0
, makeFrom
, makeTo
, makeRep1
, makeFrom1
, makeTo1
) where
import Data.Char (isAlphaNum, ord)
import Data.List
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
import qualified Data.Map as Map
import Data.Map as Map (Map)
#endif
#if __GLASGOW_HASKELL__ >= 706 && __GLASGOW_HASKELL__ < 710
import qualified Data.Set as Set
import Data.Set (Set)
#endif
import Generics.Deriving.Base
import Generics.Deriving.TH.Internal
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (Name(..), NameFlavour(..), Lift(..),
modString, pkgString)
import Language.Haskell.TH hiding (Fixity())
simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
simplInstance cl ty fn df = do
x <- newName "x"
let typ = ForallT [PlainTV x] []
((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 DataPlain ty)) []) `AppT` (VarT x))
fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
[funD fn [clause [] (normalB (varE df `appE`
(sigE (varE undefinedValName) (return typ)))) []]]
deriveAll :: Name -> Q [Dec]
deriveAll n =
do a <- deriveMeta n
b <- deriveRepresentable0 n
return (a ++ b)
deriveAll1 :: Name -> Q [Dec]
deriveAll1 n =
do a <- deriveMeta n
b <- deriveRepresentable1 n
return (a ++ b)
deriveAll0And1 :: Name -> Q [Dec]
deriveAll0And1 n =
do a <- deriveMeta n
b <- deriveRepresentable0 n
c <- deriveRepresentable1 n
return (a ++ b ++ c)
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
deriveRepresentable0 :: Name -> Q [Dec]
deriveRepresentable0 n = do
rep0 <- deriveRep0 n
inst <- deriveInst n
return $ rep0 ++ inst
deriveRepresentable1 :: Name -> Q [Dec]
deriveRepresentable1 n = do
rep1 <- deriveRep1 n
inst1 <- deriveInst1 n
return $ rep1 ++ inst1
deriveRep0 :: Name -> Q [Dec]
deriveRep0 = deriveRepCommon 0
deriveRep1 :: Name -> Q [Dec]
deriveRep1 = deriveRepCommon 1
deriveRepCommon :: Int -> Name -> Q [Dec]
deriveRepCommon arity n = do
i <- reifyDataInfo n
let (name, _, allTvbs, cons, dv) = either error id i
(tvbs, _, gk) = buildTypeInstance arity name allTvbs cons dv
fmap (:[]) $ tySynD (genRepName arity dv name)
(map unKindedTV tvbs)
(repType gk dv name cons)
deriveInst :: Name -> Q [Dec]
deriveInst = deriveInstCommon genericTypeName repTypeName 0 fromValName toValName
deriveInst1 :: Name -> Q [Dec]
deriveInst1 = deriveInstCommon generic1TypeName rep1TypeName 1 from1ValName to1ValName
deriveInstCommon :: Name -> Name -> Int -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon genericName repName arity fromName toName n = do
i <- reifyDataInfo n
let (name, _, allTvbs, cons, dv) = either error id i
(tvbs, origTy, gk) = buildTypeInstance arity name allTvbs cons dv
repTy = applyTyToTvbs (genRepName arity dv name) tvbs
#if __GLASGOW_HASKELL__ >= 707
tyIns = TySynInstD repName (TySynEqn [origTy] repTy)
#else
tyIns = TySynInstD repName [origTy] repTy
#endif
mkBody maker = [clause [] (normalB $ mkCaseExp gk name cons maker) []]
fcs = mkBody mkFrom
tcs = mkBody mkTo
fmap (:[]) $
instanceD (cxt []) (conT genericName `appT` return origTy)
[return tyIns, funD fromName fcs, funD toName tcs]
makeRep0 :: Name -> Q Type
makeRep0 = makeRepCommon 0
makeRep1 :: Name -> Q Type
makeRep1 = makeRepCommon 1
makeRepCommon :: Int -> Name -> Q Type
makeRepCommon arity n = do
i <- reifyDataInfo n
case i of
Left msg -> error msg
Right (name, _, _, _, dv) -> conT $ genRepName arity dv name
makeFrom :: Name -> Q Exp
makeFrom = makeFunCommon mkFrom 0
makeTo :: Name -> Q Exp
makeTo = makeFunCommon mkTo 0
makeFrom1 :: Name -> Q Exp
makeFrom1 = makeFunCommon mkFrom 1
makeTo1 :: Name -> Q Exp
makeTo1 = makeFunCommon mkTo 1
makeFunCommon :: (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])
-> Int -> Name -> Q Exp
makeFunCommon maker arity n = do
i <- reifyDataInfo n
let (name, _, allTvbs, cons, dv) = either error id i
(_, _, gk) = buildTypeInstance arity name allTvbs cons dv
mkCaseExp gk name cons maker
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)
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 :)
genRepName :: Int -> DataVariety -> Name -> Name
genRepName arity dv n = mkName
. showsDataVariety dv
. (("Rep" ++ show arity) ++)
. ((showNameQual n ++ "_") ++)
. sanitizeName
$ nameBase n
showsDataVariety :: DataVariety -> ShowS
showsDataVariety dv = (++ '_':label dv)
where
label DataPlain = "Plain"
label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n)
showNameQual :: Name -> String
showNameQual = sanitizeName . showQual
where
showQual (Name _ (NameQ m)) = modString m
showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m
showQual _ = ""
sanitizeName :: String -> String
sanitizeName nb = 'N':(
nb >>= \x -> case x of
c | isAlphaNum c || c == '\''-> [c]
'_' -> "__"
c -> "_" ++ show (ord c))
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 r@(RecC _ _) =
mkConstrData dv dt (stripRecordNames r)
mkConstrData dv dt (InfixC t1 n t2) =
mkConstrData dv dt (NormalC n [t1,t2])
mkConstrData _ _ (ForallC _ _ con) = forallCError 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) (conT $ genName dv [n])) $
[ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]
, funD moduleNameValName [clause [wildP] (normalB (stringE name)) []]
#if __GLASGOW_HASKELL__ >= 711
, funD packageNameValName [clause [wildP] (normalB (stringE pkgName)) []]
#endif
]
#if __GLASGOW_HASKELL__ >= 708
++ if _isNewtype
then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]
else []
#endif
where
name = maybe (error "Cannot fetch module name!") id (nameModule n)
#if __GLASGOW_HASKELL__ >= 711
pkgName = maybe (error "Cannot fetch package name!") id (namePackage n)
#endif
liftFixity :: Fixity -> Q Exp
liftFixity Prefix = conE prefixDataName
liftFixity (Infix a n) = conE infixDataName
`appE` liftAssociativity a
`appE` lift n
liftAssociativity :: Associativity -> Q Exp
liftAssociativity LeftAssociative = conE leftAssociativeDataName
liftAssociativity RightAssociative = conE rightAssociativeDataName
liftAssociativity NotAssociative = conE notAssociativeDataName
mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec
mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n []
mkConstrInstance dv dt (RecC n _) = mkConstrInstanceWith dv dt n
[ funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]
mkConstrInstance dv dt (InfixC _ n _) =
do
i <- reify n
#if __GLASGOW_HASKELL__ >= 711
fi <- case i of
DataConI{} -> fmap convertFixity $ reifyFixity n
_ -> return Prefix
#else
let fi = case i of
DataConI _ _ _ f -> convertFixity f
_ -> Prefix
#endif
instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))
[funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []],
funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]
where
convertFixity (Fixity n' d) = Infix (convertDirection d) n'
convertDirection InfixL = LeftAssociative
convertDirection InfixR = RightAssociative
convertDirection InfixN = NotAssociative
mkConstrInstance _ _ (ForallC _ _ con) = forallCError con
mkConstrInstanceWith :: DataVariety -> Name -> Name -> [Q Dec] -> Q Dec
mkConstrInstanceWith dv dt n extra =
instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))
(funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]
mkSelectInstance dv dt (RecC n fs) = return (map one fs) where
one (f, _, _) =
InstanceD ([]) (AppT (ConT selectorTypeName) (ConT $ genName dv [dt, n, f]))
[FunD selNameValName [Clause [WildP]
(NormalB (LitE (StringL (nameBase f)))) []]]
mkSelectInstance _ _ _ = return []
repType :: GenericKind -> DataVariety -> Name -> [Con] -> Q Type
repType gk dv dt cs =
conT d1TypeName `appT` (conT $ genName dv [dt]) `appT`
foldr1' sum' (conT v1TypeName)
(map (repCon gk dv dt) cs)
where
sum' :: Q Type -> Q Type -> Q Type
sum' a b = conT sumTypeName `appT` a `appT` b
repCon :: GenericKind -> DataVariety -> Name -> Con -> Q Type
repCon _ dv dt (NormalC n []) =
conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
(conT s1TypeName `appT` conT noSelectorTypeName `appT` conT u1TypeName)
repCon gk dv dt (NormalC n fs) =
conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
(foldr1 prod (map (repField gk . snd) fs)) where
prod :: Q Type -> Q Type -> Q Type
prod a b = conT productTypeName `appT` a `appT` b
repCon _ dv dt (RecC n []) =
conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT` conT u1TypeName
repCon gk dv dt (RecC n fs) =
conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
(foldr1 prod (map (repField' gk dv dt n) fs)) where
prod :: Q Type -> Q Type -> Q Type
prod a b = conT productTypeName `appT` a `appT` b
repCon gk dv dt (InfixC t1 n t2) = repCon gk dv dt (NormalC n [t1,t2])
repCon _ _ _ (ForallC _ _ con) = forallCError con
repField :: GenericKind -> Type -> Q Type
repField gk t = conT s1TypeName `appT` conT noSelectorTypeName `appT`
(repFieldArg gk =<< expandSyn t)
repField' :: GenericKind -> DataVariety -> Name -> Name -> (Name, Strict, Type) -> Q Type
repField' gk dv dt ns (f, _, t) = conT s1TypeName
`appT` conT (genName dv [dt, ns, f])
`appT` (repFieldArg gk =<< expandSyn t)
repFieldArg :: GenericKind -> Type -> Q Type
repFieldArg _ ForallT{} = rankNError
repFieldArg gk (SigT t _) = repFieldArg gk t
repFieldArg Gen0 t = boxT t
repFieldArg (Gen1 nb) (VarT t) | NameBase t == nb = conT par1TypeName
repFieldArg gk@(Gen1 nb) t = do
let tyHead:tyArgs = unapplyTy t
numLastArgs = min 1 $ length tyArgs
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
rec0Type = boxT t
phiType = return $ applyTyToTys tyHead lhsArgs
inspectTy :: Type -> Q Type
inspectTy (VarT a)
| NameBase a == nb
= conT rec1TypeName `appT` phiType
inspectTy (SigT ty _) = inspectTy ty
inspectTy beta
| not (ground beta nb)
= conT composeTypeName `appT` phiType
`appT` repFieldArg gk beta
inspectTy _ = rec0Type
itf <- isTyFamily tyHead
if any (not . (`ground` nb)) lhsArgs
|| any (not . (`ground` nb)) tyArgs && itf
then outOfPlaceTyVarError
else case rhsArgs of
[] -> rec0Type
ty:_ -> inspectTy ty
boxT :: Type -> Q Type
boxT ty = case unboxedRepNames ty of
Just (boxTyName, _, _) -> conT boxTyName
Nothing -> conT rec0TypeName `appT` return ty
mkCaseExp :: GenericKind -> Name -> [Con]
-> (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])
-> Q Exp
mkCaseExp gk dt cs matchmaker = do
val <- newName "val"
lam1E (varP val) $ caseE (varE val) $ matchmaker gk 1 0 dt cs
mkFrom :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]
mkFrom _ _ _ dt [] = [errorFrom dt]
mkFrom gk m i _ cs = zipWith (fromCon gk wrapE (length cs)) [0..] cs
where
wrapE e = lrE m i e
errorFrom :: Name -> Q Match
errorFrom dt =
match
wildP
(normalB $ appE (conE m1DataName) $ varE errorValName `appE` stringE
("No generic representation for empty datatype " ++ nameBase dt))
[]
errorTo :: Name -> Q Match
errorTo dt =
match
(conP m1DataName [wildP])
(normalB $ varE errorValName `appE` stringE
("No values for empty datatype " ++ nameBase dt))
[]
mkTo :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]
mkTo _ _ _ dt [] = [errorTo dt]
mkTo gk m i _ cs = zipWith (toCon gk wrapP (length cs)) [0..] cs
where
wrapP p = lrP m i p
fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match
fromCon _ wrap m i (NormalC cn []) =
match
(conP cn [])
(normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ appE (conE m1DataName) $
conE m1DataName `appE` (conE u1DataName)) []
fromCon gk wrap m i (NormalC cn fs) =
match
(conP cn (map (varP . field) [0..length fs 1]))
(normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`
foldr1 prod (zipWith (fromField gk) [0..] (map snd fs))) []
where prod x y = conE productDataName `appE` x `appE` y
fromCon _ wrap m i (RecC cn []) =
match
(conP cn [])
(normalB $ appE (conE m1DataName)
$ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []
fromCon gk wrap m i (RecC cn fs) =
match
(conP cn (map (varP . field) [0..length fs 1]))
(normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`
foldr1 prod (zipWith (fromField gk) [0..] (map trd fs))) []
where prod x y = conE productDataName `appE` x `appE` y
fromCon gk wrap m i (InfixC t1 cn t2) =
fromCon gk wrap m i (NormalC cn [t1,t2])
fromCon _ _ _ _ (ForallC _ _ con) = forallCError con
fromField :: GenericKind -> Int -> Type -> Q Exp
fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t)
fromFieldWrap :: GenericKind -> Int -> Type -> Q Exp
fromFieldWrap _ _ ForallT{} = rankNError
fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t
fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE (field nr)
fromFieldWrap (Gen1 nb) nr t = wC t nb `appE` varE (field nr)
wC :: Type -> NameBase -> Q Exp
wC (VarT n) nb | NameBase n == nb = conE par1DataName
wC t nb
| ground t nb = conE $ boxRepName t
| otherwise = do
let tyHead:tyArgs = unapplyTy t
numLastArgs = min 1 $ length tyArgs
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
inspectTy :: Type -> Q Exp
inspectTy ForallT{} = rankNError
inspectTy (SigT ty _) = inspectTy ty
inspectTy (VarT a)
| NameBase a == nb
= conE rec1DataName
inspectTy beta = infixApp (conE comp1DataName)
(varE composeValName)
(varE fmapValName `appE` wC beta nb)
itf <- isTyFamily tyHead
if any (not . (`ground` nb)) lhsArgs
|| any (not . (`ground` nb)) tyArgs && itf
then outOfPlaceTyVarError
else case rhsArgs of
[] -> conE $ boxRepName t
ty:_ -> inspectTy ty
boxRepName :: Type -> Name
boxRepName = maybe k1DataName (\(_, boxName, _) -> boxName) . unboxedRepNames
toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match
toCon _ wrap m i (NormalC cn []) =
match
(wrap $ conP m1DataName [lrP m i $ conP m1DataName
[conP m1DataName [conP u1DataName []]]])
(normalB $ conE cn) []
toCon gk wrap m i (NormalC cn fs) =
match
(wrap $ conP m1DataName [lrP m i $ conP m1DataName
[foldr1 prod (zipWith (\nr -> toField gk nr . snd) [0..] fs)]])
(normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)
[0..] (map snd fs))) []
where prod x y = conP productDataName [x,y]
toCon _ wrap m i (RecC cn []) =
match
(wrap $ conP m1DataName [lrP m i $ conP m1DataName [conP u1DataName []]])
(normalB $ conE cn) []
toCon gk wrap m i (RecC cn fs) =
match
(wrap $ conP m1DataName [lrP m i $ conP m1DataName
[foldr1 prod (zipWith (\nr (_, _, t) -> toField gk nr t) [0..] fs)]])
(normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)
[0..] (map trd fs))) []
where prod x y = conP productDataName [x,y]
toCon gk wrap m i (InfixC t1 cn t2) =
toCon gk wrap m i (NormalC cn [t1,t2])
toCon _ _ _ _ (ForallC _ _ con) = forallCError con
toConUnwC :: GenericKind -> Int -> Type -> Q Exp
toConUnwC Gen0 nr _ = varE $ field nr
toConUnwC (Gen1 nb) nr t = unwC t nb `appE` varE (field nr)
toField :: GenericKind -> Int -> Type -> Q Pat
toField gk nr t = conP m1DataName [toFieldWrap gk nr t]
toFieldWrap :: GenericKind -> Int -> Type -> Q Pat
toFieldWrap Gen0 nr t = conP (boxRepName t) [varP (field nr)]
toFieldWrap (Gen1 _) nr _ = varP (field nr)
field :: Int -> Name
field n = mkName $ "f" ++ show n
unwC :: Type -> NameBase -> Q Exp
unwC (SigT t _) nb = unwC t nb
unwC (VarT n) nb | NameBase n == nb = varE unPar1ValName
unwC t nb
| ground t nb = varE $ unboxRepName t
| otherwise = do
let tyHead:tyArgs = unapplyTy t
numLastArgs = min 1 $ length tyArgs
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
inspectTy :: Type -> Q Exp
inspectTy ForallT{} = rankNError
inspectTy (SigT ty _) = inspectTy ty
inspectTy (VarT a)
| NameBase a == nb
= varE unRec1ValName
inspectTy beta = infixApp (varE fmapValName `appE` unwC beta nb)
(varE composeValName)
(varE unComp1ValName)
itf <- isTyFamily tyHead
if any (not . (`ground` nb)) lhsArgs
|| any (not . (`ground` nb)) tyArgs && itf
then outOfPlaceTyVarError
else case rhsArgs of
[] -> varE $ unboxRepName t
ty:_ -> inspectTy ty
unboxRepName :: Type -> Name
unboxRepName = maybe unK1ValName (\(_, _, unboxName) -> unboxName) . unboxedRepNames
lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP 1 0 p = p
lrP _ 0 p = conP l1DataName [p]
lrP m i p = conP r1DataName [lrP (m1) (i1) p]
lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE 1 0 e = e
lrE _ 0 e = conE l1DataName `appE` e
lrE m i e = conE r1DataName `appE` lrE (m1) (i1) e
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames ty
| ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName)
| ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName)
| ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)
| ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName)
| ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName)
| ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName)
| otherwise = Nothing
reifyDataInfo :: Name
-> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety))
reifyDataInfo name = do
info <- reify name
case info of
TyConI dec ->
return $ case dec of
DataD ctxt _ tvbs cons _ -> Right $
checkDataContext name ctxt (name, False, tvbs, cons, DataPlain)
NewtypeD ctxt _ tvbs con _ -> Right $
checkDataContext name ctxt (name, True, tvbs, [con], DataPlain)
TySynD{} -> Left $ ns ++ "Type synonyms are not supported."
_ -> Left $ ns ++ "Unsupported type: " ++ show dec
#if MIN_VERSION_template_haskell(2,7,0)
# if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ parentName -> do
# else
DataConI _ _ parentName _ -> do
# endif
parentInfo <- reify parentName
return $ case parentInfo of
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI (DataFamilyD _ tvbs _) decs ->
# else
FamilyI (FamilyD DataFam _ tvbs _) decs ->
# endif
let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons
in case instDec of
Just (DataInstD ctxt _ instTys cons _) -> Right $
checkDataContext parentName ctxt
(parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys)
Just (NewtypeInstD ctxt _ instTys con _) -> Right $
checkDataContext parentName ctxt
(parentName, True, tvbs, [con], DataFamily (constructorName con) instTys)
_ -> Left $ ns ++
"Could not find data or newtype instance constructor."
_ -> Left $ ns ++ "Data constructor " ++ show name ++
" is not from a data family instance constructor."
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI DataFamilyD{} _ ->
# else
FamilyI (FamilyD DataFam _ _ _) _ ->
# endif
return . Left $
ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
_ -> return . Left $ ns ++ "The name must be of a plain data type constructor, "
++ "or a data family instance constructor."
#else
DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor."
++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)"
_ -> return . Left $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "Generics.Deriving.TH.reifyDataInfo: "
buildTypeInstance :: Int
-> Name
-> [TyVarBndr]
-> [Con]
-> DataVariety
-> ([TyVarBndr], Type, GenericKind)
buildTypeInstance arity tyConName tvbs _ DataPlain
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError tyConName
| otherwise = (remaining, instanceType, genericKindFromArity arity droppedNbs)
where
instanceType :: Type
instanceType = applyTyToTvbs tyConName remaining
remainingLength :: Int
remainingLength = length tvbs arity
remaining, dropped :: [TyVarBndr]
(remaining, dropped) = splitAt remainingLength tvbs
droppedKinds :: [Kind]
droppedKinds = map tyVarBndrToKind dropped
droppedNbs :: [NameBase]
droppedNbs = map tyVarBndrToNameBase dropped
buildTypeInstance arity parentName tvbs _cons (DataFamily _ instTysAndKinds)
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError parentName
| canEtaReduce remaining dropped
= (lhsTvbs, instanceType, genericKindFromArity arity droppedNbs)
| otherwise = etaReductionError instanceType
where
instanceType :: Type
instanceType = applyTyToTys (ConT parentName) $ map unSigT remaining
remainingLength :: Int
remainingLength = length tvbs arity
remaining, dropped :: [Type]
(remaining, dropped) = splitAt remainingLength rhsTypes
droppedKinds :: [Kind]
droppedKinds = map tyVarBndrToKind . snd $ splitAt remainingLength tvbs
droppedNbs :: [NameBase]
droppedNbs = map varTToNameBase dropped
instTypes :: [Type]
instTypes =
#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
instTysAndKinds
#else
drop (Set.size . Set.unions $ map (distinctKindVars . tyVarBndrToKind) tvbs)
instTysAndKinds
where
distinctKindVars :: Kind -> Set Name
# if MIN_VERSION_template_haskell(2,8,0)
distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2
distinctKindVars (SigT k _) = distinctKindVars k
distinctKindVars (VarT k) = Set.singleton k
# endif
distinctKindVars _ = Set.empty
#endif
lhsTvbs :: [TyVarBndr]
lhsTvbs = map (uncurry replaceTyVarName)
. filter (isTyVar . snd)
. take remainingLength
$ zip tvbs rhsTypes
rhsTypes :: [Type]
rhsTypes =
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
instTypes ++ map tyVarBndrToType
(alignTyVarBndrs _cons $ drop (length instTypes) tvbs)
where
tyVarBndrToType :: TyVarBndr -> Type
tyVarBndrToType (PlainTV n) = VarT n
tyVarBndrToType (KindedTV n k) = SigT (VarT n) k
mapTyVarBndrName :: Name -> TyVarBndr -> TyVarBndr
mapTyVarBndrName n PlainTV{} = PlainTV n
mapTyVarBndrName n (KindedTV _ k) = KindedTV n k
alignTyVarBndrs :: [Con] -> [TyVarBndr] -> [TyVarBndr]
alignTyVarBndrs cons' tvbs' =
let nbSet = Set.fromList $ map tyVarBndrToNameBase tvbs'
nbMap = snd $ foldr alignCon (nbSet, Map.empty) cons'
in map (\tvb -> mapTyVarBndrName (Map.findWithDefault
(tyVarBndrToName tvb)
(tyVarBndrToNameBase tvb)
nbMap
) tvb
) tvbs'
alignCon :: Con
-> (Set NameBase, Map NameBase Name)
-> (Set NameBase, Map NameBase Name)
alignCon _ (nbs, m) | Set.null nbs = (nbs, m)
alignCon (NormalC _ tys) state = foldr alignTy state $ map snd tys
alignCon (RecC n tys) state = alignCon (NormalC n $ map shrink tys) state
where
shrink (_, b, c) = (b, c)
alignCon (InfixC ty1 n ty2) state = alignCon (NormalC n [ty1, ty2]) state
alignCon (ForallC _ _ con) _ = forallCError con
alignTy :: Type
-> (Set NameBase, Map NameBase Name)
-> (Set NameBase, Map NameBase Name)
alignTy _ (nbs, m) | Set.null nbs = (nbs, m)
alignTy ForallT{} _ = rankNError
alignTy (AppT t1 t2) state = alignTy t2 $ alignTy t1 state
alignTy (SigT t _) state = alignTy t state
alignTy (VarT n) (nbs, m) =
let nb = NameBase n
in if nb `Set.member` nbs
then let nbs' = nb `Set.delete` nbs
m' = Map.insert nb n m
in (nbs', m')
else (nbs, m)
alignTy _ state = state
#else
instTypes
#endif
ground :: Type -> NameBase -> Bool
ground (AppT t1 t2) nb = ground t1 nb && ground t2 nb
ground (SigT t _) nb = ground t nb
ground (VarT n) nb = NameBase n /= nb
ground ForallT{} _ = rankNError
ground _ _ = True
etaReductionError :: Type -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
derivingKindError :: Name -> a
derivingKindError tyConName = error
. showString "Cannot derive well-kinded instance of form ‘Generic1 "
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass Generic1 expects an argument of kind * -> *"
$ ""
outOfPlaceTyVarError :: a
outOfPlaceTyVarError = error $
"Type applied to an argument involving the last parameter is not of kind * -> *"
forallCError :: Con -> a
forallCError con = error $
nameBase (constructorName con) ++ " must be a vanilla data constructor"
rankNError :: a
rankNError = error "Cannot have polymorphic arguments"
checkDataContext :: Name -> Cxt -> a -> a
checkDataContext _ [] x = x
checkDataContext dataName _ _ = error $
nameBase dataName ++ " must not have a datatype context"
data GenericKind = Gen0 | Gen1 NameBase
genericKindFromArity :: Int -> [NameBase] -> GenericKind
genericKindFromArity 0 _ = Gen0
genericKindFromArity 1 nbs = Gen1 $ head nbs
genericKindFromArity _ _ = error "Invalid arity"
data DataVariety = DataPlain | DataFamily Name [Type]