module Generics.Instant.TH (
deriveAll, deriveAllL
, deriveConstructors
, deriveRepresentable
, deriveRep
, simplInstance, gadtInstance
, genRepName, typeVariables, tyVarBndrToName
) where
import Generics.Instant.Base
import Generics.SYB (everywhere, mkT, everything, mkQ, gshow)
import Language.Haskell.TH hiding (Fixity())
import Language.Haskell.TH.Syntax (Lift(..), showName)
import Data.List (intercalate, nub, elemIndex)
import qualified Data.Map as M
import Control.Monad
import Control.Arrow ((&&&))
data TypeArgsEqs = TypeArgsEqs { args :: [Type]
, vars :: [Name]
, teqs :: [(Type,Type)]
} deriving Show
simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
simplInstance cl ty fn df = do
i <- reify ty
let typ = return (foldl (\a -> AppT a . VarT . tyVarBndrToName)
(ConT ty) (typeVariables i))
fmap (: []) $ instanceD (cxt []) (conT cl `appT` typ)
[funD fn [clause [] (normalB (varE df)) []]]
gadtInstance :: Name -> Name -> Name -> Name -> Q [Dec]
gadtInstance cl ty fn df = do
i <- reify ty
let typ = (foldl (\a -> AppT a . VarT . tyVarBndrToName)
(ConT ty) (typeVariables i))
dt :: ([TyVarBndr],[Con])
dt = case i of
TyConI (DataD _ _ vs cs _) -> (vs, cs)
_ -> error ("gadtInstance: " ++ show ty ++ "is not a valid type")
idxs :: [Name]
idxs = extractIndices (fst dt) (snd dt)
eqs :: [Name] -> [Con] -> [TypeArgsEqs]
eqs nms cs = map f cs where
f :: Con -> TypeArgsEqs
f (NormalC _ tys) = TypeArgsEqs (map snd tys) [] []
f (RecC _ tys) = TypeArgsEqs (map (\(_,_,t) -> t) tys) [] []
f (InfixC t1 _ t2) = TypeArgsEqs [snd t1, snd t2] [] []
f (ForallC vs cxt c) = case f c of
TypeArgsEqs ts vs' eqs' ->
TypeArgsEqs ts (tyVarBndrsToNames vs ++ vs')
((concatMap g cxt) ++ eqs')
g :: Pred -> [(Type,Type)]
g (EqualP (VarT t1) t2) | t1 `elem` nms = [(VarT t1,t2)]
| otherwise = []
g _ = []
subst :: [(Type,Type)] -> Type -> Type
subst s = everywhere (mkT f) where
f (VarT a) = case lookup (VarT a) s of
Nothing -> VarT a
Just t -> t
f x = x
mkInst :: TypeArgsEqs -> Dec
mkInst t = InstanceD (map mkCxt (args t))
(ConT cl `AppT` subst (teqs t) typ) instBody
mkCxt :: Type -> Pred
mkCxt = ClassP cl . (:[])
instBody :: [Dec]
instBody = [FunD fn [Clause [] (NormalB (VarE df)) []]]
update :: TypeArgsEqs -> [TypeArgsEqs] -> [TypeArgsEqs]
update _ [] = []
update t1 (t2:ts) | teqs t1 == teqs t2 =
t2 {args = nub (args t1 ++ args t2)} : ts
| otherwise = t2 : update t1 ts
handleADTs :: ([TypeArgsEqs] -> [TypeArgsEqs])
-> [TypeArgsEqs] -> [TypeArgsEqs]
handleADTs f ts | and (map (null . teqs) ts)
= [TypeArgsEqs (concatMap args ts) [] []]
| otherwise = f ts
filterMerge :: [TypeArgsEqs] -> [TypeArgsEqs]
filterMerge (t0@(TypeArgsEqs ts vs eqs):t)
| eqs == [] = update t0 (filterMerge t)
| otherwise = case filterMerge t of
l -> if or (concat
[ [ typeMatch vs (vars t2) eq1 eq2
| eq1 <- eqs, eq2 <- teqs t2 ] | t2 <- l ])
then update t0 l
else t0 : l
filterMerge [] = []
typeMatch :: [Name] -> [Name] -> (Type,Type) -> (Type,Type) -> Bool
typeMatch vs1 vs2 eq1 eq2 | length vs1 /= length vs2 = False
| otherwise
= eq1 == everywhere (mkT f) eq2
where f (VarT n) = case n `elemIndex` vs2 of
Nothing -> VarT n
Just i -> VarT (vs1 !! i)
f x = x
allTypeArgsEqs = eqs idxs (snd dt)
normInsts = map mkInst (handleADTs filterMerge allTypeArgsEqs)
return $ normInsts
deriveAll :: Name -> Q [Dec]
deriveAll n =
do a <- deriveConstructors n
b <- deriveRepresentable n
return (a ++ b)
deriveAllL :: [Name] -> Q [Dec]
deriveAllL = fmap concat . mapM deriveAll
deriveConstructors :: Name -> Q [Dec]
deriveConstructors = constrInstance
deriveRepresentable :: Name -> Q [Dec]
deriveRepresentable n = do
rep <- deriveRep n
inst <- deriveInst n
return $ rep ++ inst
deriveRep :: Name -> Q [Dec]
deriveRep n = do
i <- reify n
let d = case i of
TyConI dec -> dec
_ -> error "unknown construct"
exTyFamsInsts <- genExTyFamInsts d
fmap (: exTyFamsInsts) $
tySynD (genRepName n) (typeVariables i) (repType d (typeVariables i))
deriveInst :: Name -> Q [Dec]
deriveInst t = do
i <- reify t
let typ q = return $ foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q)
(typeVariables i)
fcs <- mkFrom t 1 0 t
tcs <- mkTo t 1 0 t
liftM (:[]) $
instanceD (cxt [])
(conT ''Representable `appT` typ t)
[ tySynInstD ''Rep [typ t] (typ (genRepName t))
, funD 'from fcs, funD 'to tcs]
constrInstance :: Name -> Q [Dec]
constrInstance n = do
i <- reify n
case i of
TyConI (DataD _ n _ cs _) -> mkInstance n cs
TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]
_ -> return []
where
mkInstance n cs = do
ds <- mapM (mkConstrData n) cs
is <- mapM (mkConstrInstance n) cs
return $ ds ++ is
typeVariables :: Info -> [TyVarBndr]
typeVariables (TyConI (DataD _ _ tv _ _)) = tv
typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
typeVariables _ = []
tyVarBndrsToNames :: [TyVarBndr] -> [Name]
tyVarBndrsToNames = map tyVarBndrToName
tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV name) = name
tyVarBndrToName (KindedTV name _) = name
stripRecordNames :: Con -> Con
stripRecordNames (RecC n f) =
NormalC n (map (\(_, s, t) -> (s, t)) f)
stripRecordNames c = c
genName :: [Name] -> Name
genName = mkName . (++"_") . intercalate "_" . map nameBase
genRepName :: Name -> Name
genRepName = mkName . (++"_") . ("Rep" ++) . nameBase
mkConstrData :: Name -> Con -> Q Dec
mkConstrData dt (NormalC n _) =
dataD (cxt []) (genName [dt, n]) [] [] []
mkConstrData dt r@(RecC _ _) =
mkConstrData dt (stripRecordNames r)
mkConstrData dt (InfixC t1 n t2) =
mkConstrData dt (NormalC n [t1,t2])
mkConstrData dt (ForallC _ _ c) = mkConstrData dt c
instance Lift Fixity where
lift Prefix = conE 'Prefix
lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
instance Lift Associativity where
lift LeftAssociative = conE 'LeftAssociative
lift RightAssociative = conE 'RightAssociative
lift NotAssociative = conE 'NotAssociative
mkConstrInstance :: Name -> Con -> Q Dec
mkConstrInstance dt (ForallC _ _ c) = mkConstrInstance dt c
mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n
[ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
mkConstrInstance dt (InfixC t1 n t2) =
do
i <- reify n
let fi = case i of
DataConI _ _ _ f -> convertFixity f
_ -> Prefix
instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
[funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []],
funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
where
convertFixity (Fixity n d) = Infix (convertDirection d) n
convertDirection InfixL = LeftAssociative
convertDirection InfixR = RightAssociative
convertDirection InfixN = NotAssociative
mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
mkConstrInstanceWith dt n extra =
instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
(funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
repType :: Dec -> [TyVarBndr] -> Q Type
repType i repVs =
do let sum :: Q Type -> Q Type -> Q Type
sum a b = conT ''(:+:) `appT` a `appT` b
case i of
(DataD _ dt vs cs _) ->
(foldBal' sum (error "Empty datatypes are not supported.")
(map (repConGADT (dt, tyVarBndrsToNames vs) repVs
(extractIndices vs cs)) cs))
(NewtypeD _ dt vs c _) -> repConGADT (dt, tyVarBndrsToNames vs) repVs
(extractIndices vs [c]) c
(TySynD t _ _) -> error "type synonym?"
_ -> error "unknown construct"
extractIndices :: [TyVarBndr] -> [Con] -> [Name]
extractIndices vs = nub . everything (++) ([] `mkQ` isIndexEq) where
isIndexEq :: Pred -> [Name]
isIndexEq (EqualP (VarT a) (VarT b)) = if a `elem` tyVarBndrsToNames vs
then (a:)
(if b `elem` tyVarBndrsToNames vs
then [b] else []) else []
isIndexEq (EqualP (VarT a) _) = if a `elem` tyVarBndrsToNames vs
then [a] else []
isIndexEq (EqualP _ (VarT a)) = if a `elem` tyVarBndrsToNames vs
then [a] else []
isIndexEq _ = []
repConGADT :: (Name, [Name]) -> [TyVarBndr] -> [Name] -> Con -> Q Type
repConGADT _ _ vs@(_:_:_) (ForallC _ _ _) =
error ("Datatype indexed over >1 variable: " ++ show vs)
repConGADT d@(dt, dtVs) repVs [indexVar] (ForallC vs ctx c) =
do
let
genTypeEqs ((EqualP t1 t2):r) | otherwise = case genTypeEqs r of
(t1s,t2s) -> ( ConT ''(:*:) `AppT` (substTyVar vsN t1) `AppT` t1s
, ConT ''(:*:) `AppT` (substTyVar vsN t2) `AppT` t2s)
genTypeEqs (_:r) = genTypeEqs r
genTypeEqs [] = baseEqs
substTyVar :: [Name] -> Type -> Type
substTyVar ns = everywhere (mkT f) where
f (VarT v) = case elemIndex v ns of
Nothing -> VarT v
Just i -> ConT ''X
`AppT` ConT (genName [dt,getConName c])
`AppT` int2TLNat i
`AppT` VarT indexVar
f x = x
vsN :: [Name]
vsN = tyVarBndrsToNames vs
repCon (dt, dtVs) (everywhere (mkT (substTyVar vsN)) c) (genTypeEqs ctx)
repConGADT d _repVs _ c = repCon d c baseEqs
getConName :: Con -> Name
getConName (NormalC n _) = n
getConName (RecC n _) = n
getConName (InfixC _ n _) = n
getConName (ForallC _ _ c) = getConName c
int2TLNat :: Int -> Type
int2TLNat 0 = ConT ''Ze
int2TLNat n = ConT ''Su `AppT` int2TLNat (n1)
genExTyFamInsts :: Dec -> Q [Dec]
genExTyFamInsts (DataD _ n _ cs _) = fmap concat $
mapM (genExTyFamInsts' n) cs
genExTyFamInsts (NewtypeD _ n _ c _) = genExTyFamInsts' n c
genExTyFamInsts' :: Name -> Con -> Q [Dec]
genExTyFamInsts' dt (ForallC vs cxt c) =
do let mR = mobilityRules (tyVarBndrsToNames vs) cxt
conName = ConT (genName [dt,getConName c])
tySynInst ty n x = TySynInstD ''X [conName, int2TLNat n, ty] x
return [ tySynInst ty n (VarT nm) | (n,(nm, ty)) <- zip [0..] mR ]
genExTyFamInsts' _ _ = return []
mobilityRules :: [Name] -> Cxt -> [(Name,Type)]
mobilityRules [] _ = []
mobilityRules vs cxt = concat [ mobilityRules' v p | v <- vs, p <- cxt ] where
mobilityRules' :: Name -> Pred -> [(Name,Type)]
mobilityRules' _ (EqualP (VarT _) (VarT _)) = []
mobilityRules' v (EqualP (VarT a) x) | v `inComplex` x = [(v,x)]
| otherwise = []
mobilityRules' v (EqualP x (VarT a)) = mobilityRules' v (EqualP (VarT a) x)
mobilityRules' v _ = []
inComplex :: Name -> Type -> Bool
inComplex v (VarT _) = False
inComplex v x = everything (||) (False `mkQ` q) x where
q (VarT x) | x == v = True
q (VarT x) | otherwise = False
q _ = False
flattenEqs :: (Type, Type) -> Q Type
flattenEqs (t1, t2) = return t1 `appT` return t2
baseEqs :: (Type, Type)
baseEqs = (TupleT 0, TupleT 0)
repCon :: (Name, [Name]) -> Con -> (Type,Type) -> Q Type
repCon _ (ForallC _ _ _) _ = error "impossible"
repCon (dt, vs) (NormalC n []) (t1,t2) =
conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
`appT` return t2 `appT` conT ''U
repCon (dt, vs) (NormalC n fs) (t1,t2) =
conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
`appT` return t2 `appT`
(foldBal prod (map (repField (dt, vs) . snd) fs)) where
prod :: Q Type -> Q Type -> Q Type
prod a b = conT ''(:*:) `appT` a `appT` b
repCon (dt, vs) r@(RecC n []) (t1,t2) =
conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
`appT` return t2 `appT` conT ''U
repCon (dt, vs) r@(RecC n fs) (t1,t2) =
conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
`appT` return t2 `appT`
(foldBal prod (map (repField' (dt, vs) n) fs)) where
prod :: Q Type -> Q Type -> Q Type
prod a b = conT ''(:*:) `appT` a `appT` b
repCon d (InfixC t1 n t2) eqs = repCon d (NormalC n [t1,t2]) eqs
repField :: (Name, [Name]) -> Type -> Q Type
repField d t = conT ''Rec `appT` return t
repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
repField' (dt, vs) ns (f, _, t) = conT ''Rec `appT` return t
mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
mkFrom ns m i n =
do
let wrapE e = e
i <- reify n
let b = case i of
TyConI (DataD _ dt vs cs _) ->
zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
(length cs)) [1..] cs
TyConI (NewtypeD _ dt vs c _) ->
[fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
TyConI (TySynD t _ _) -> error "type synonym?"
_ -> error "unknown construct"
return b
mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
mkTo ns m i n =
do
let wrapP p = p
i <- reify n
let b = case i of
TyConI (DataD _ dt vs cs _) ->
zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
(length cs)) [1..] cs
TyConI (NewtypeD _ dt vs c _) ->
[toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
TyConI (TySynD t _ _) -> error "type synonym?"
_ -> error "unknown construct"
return b
fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
fromCon wrap ns d m i (ForallC _ _ c) = fromCon wrap ns d m i c
fromCon wrap ns (dt, vs) m i (NormalC cn []) =
clause
[conP cn []]
(normalB $ wrap $ lrE m i $ appE (conE 'C) $ conE 'U) []
fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
clause
[conP cn (map (varP . field) [0..length fs 1])]
(normalB $ wrap $ lrE m i $ conE 'C `appE`
foldBal prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
where prod x y = conE '(:*:) `appE` x `appE` y
fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
clause
[conP cn []]
(normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
clause
[conP cn (map (varP . field) [0..length fs 1])]
(normalB $ wrap $ lrE m i $ conE 'C `appE`
foldBal prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
where prod x y = conE '(:*:) `appE` x `appE` y
fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
fromField (dt, vs) nr t = conE 'Rec `appE` varE (field nr)
toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
toCon wrap ns d m i (ForallC _ _ c) = toCon wrap ns d m i c
toCon wrap ns (dt, vs) m i (NormalC cn []) =
clause
[wrap $ lrP m i $ conP 'C [conP 'U []]]
(normalB $ conE cn) []
toCon wrap ns (dt, vs) m i (NormalC cn fs) =
clause
[wrap $ lrP m i $ conP 'C
[foldBal prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]
(normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs 1])) []
where prod x y = conP '(:*:) [x,y]
toCon wrap ns (dt, vs) m i r@(RecC cn []) =
clause
[wrap $ lrP m i $ conP 'U []]
(normalB $ conE cn) []
toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
clause
[wrap $ lrP m i $ conP 'C
[foldBal prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]
(normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs 1])) []
where prod x y = conP '(:*:) [x,y]
toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
toField :: (Name, [Name]) -> Int -> Type -> Q Pat
toField (dt, vs) nr t = conP 'Rec [varP (field nr)]
field :: Int -> Name
field n = mkName $ "f" ++ show n
lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP m i p | m == 0 = error "1"
| m == 1 = p
| i <= div m 2 = conP 'L [lrP (div m 2) i p]
| i > div m 2 = conP 'R [lrP (m div m 2) (i div m 2) p]
lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE m i e | m == 0 = error "2"
| m == 1 = e
| i <= div m 2 = conE 'L `appE` lrE (div m 2) i e
| i > div m 2 = conE 'R `appE` lrE (m div m 2) (i div m 2) e
trd (_,_,c) = c
foldr1' f x [] = x
foldr1' _ _ [x] = x
foldr1' f x (h:t) = f h (foldr1' f x t)
foldBal :: (a -> a -> a) -> [a] -> a
foldBal op = foldBal' op (error "foldBal: empty list")
foldBal' :: (a -> a -> a) -> a -> [a] -> a
foldBal' _ x [] = x
foldBal' _ _ [y] = y
foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
in foldBal' op x a `op` foldBal' op x b