{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Data.Comp.Multi.Strategy.Derive (
makeDynCase
) where
import Control.Arrow ( (&&&) )
import Control.Monad
import Data.List ( nub )
import Data.Maybe ( catMaybes )
import Data.Type.Equality ( (:~:)(..) )
import Language.Haskell.TH hiding ( Cxt )
import Data.Comp.Multi.Strategy.Classification ( KDynCase, kdyncase )
makeDynCase :: Name -> Q [Dec]
makeDynCase :: Name -> Q [Dec]
makeDynCase fname :: Name
fname = do
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
#else
TyConI (DataD _cxt :: Cxt
_cxt tname :: Name
tname targs :: [TyVarBndr]
targs _ constrs :: [Con]
constrs _deriving :: [DerivClause]
_deriving) <- Q Info -> Q Info
abstractNewtypeQ (Q Info -> Q Info) -> Q Info -> Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
#endif
let iVar :: Name
iVar = TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
targs
let labs :: Cxt
labs = Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> Cxt) -> [Maybe Type] -> Cxt
forall a b. (a -> b) -> a -> b
$ (Con -> Maybe Type) -> [Con] -> [Maybe Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Con -> Maybe Type
iTp Name
iVar) [Con]
constrs
let cons :: [((Name, Int), Maybe Type)]
cons = (Con -> ((Name, Int), Maybe Type))
-> [Con] -> [((Name, Int), Maybe Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Int)
abstractConType (Con -> (Name, Int))
-> (Con -> Maybe Type) -> Con -> ((Name, Int), Maybe Type)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Con -> Maybe Type
iTp Name
iVar) [Con]
constrs
(Type -> Q Dec) -> Cxt -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
genDyn Name
tname [((Name, Int), Maybe Type)]
cons) Cxt
labs
where
iTp :: Name -> Con -> Maybe Type
iTp :: Name -> Con -> Maybe Type
iTp iVar :: Name
iVar (ForallC _ cxt :: Cxt
cxt t :: Con
t) =
case [Type
y | AppT (AppT (ConT eqN :: Name
eqN) x :: Type
x) y :: Type
y <- Cxt
cxt, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
iVar, Name
eqN Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(~)] of
[] -> Name -> Con -> Maybe Type
iTp Name
iVar Con
t
tp :: Type
tp:_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
iTp _iVar :: Name
_iVar (GadtC _ _ (AppT _ tp :: Type
tp)) =
case Type
tp of
VarT _ -> Maybe Type
forall a. Maybe a
Nothing
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
iTp _iVar :: Name
_iVar (RecGadtC _ _ (AppT _ tp :: Type
tp)) =
case Type
tp of
VarT _ -> Maybe Type
forall a. Maybe a
Nothing
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
iTp _ _ = Maybe Type
forall a. Maybe a
Nothing
genDyn :: Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
genDyn :: Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
genDyn tname :: Name
tname cons :: [((Name, Int), Maybe Type)]
cons tp :: Type
tp = do
[Clause]
clauses <- ([[Clause]] -> [Clause]) -> Q [[Clause]] -> Q [Clause]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Clause]] -> Q [Clause]) -> Q [[Clause]] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe Type) -> Q [Clause])
-> [((Name, Int), Maybe Type)] -> Q [[Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> ((Name, Int), Maybe Type) -> Q [Clause]
mkClause Type
tp) [((Name, Int), Maybe Type)]
cons
let body :: [Dec]
body = [Name -> [Clause] -> Dec
FunD 'kdyncase [Clause]
clauses]
Type
instTp <- [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT []
(Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return [])
((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''KDynCase) [Name -> TypeQ
conT Name
tname, Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tp])
Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instTp [Dec]
body
mkClause :: Type -> ((Name, Int), Maybe Type) -> Q [Clause]
mkClause :: Type -> ((Name, Int), Maybe Type) -> Q [Clause]
mkClause tp :: Type
tp (con :: (Name, Int)
con, Just tp' :: Type
tp')
| Type
tp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tp' = [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [(Name, Int) -> Pat
conPat (Name, Int)
con]
(Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) (Name -> Exp
ConE 'Refl)))
[]]
mkClause _ (con :: (Name, Int)
con, _) = [Clause] -> Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [(Name, Int) -> Pat
conPat (Name, Int)
con]
(Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing))
[]]
conPat :: (Name, Int) -> Pat
conPat :: (Name, Int) -> Pat
conPat (con :: Name
con, n :: Int
n) = Name -> [Pat] -> Pat
ConP Name
con (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
n Pat
WildP)
abstractNewtypeQ :: Q Info -> Q Info
abstractNewtypeQ :: Q Info -> Q Info
abstractNewtypeQ = (Info -> Info) -> Q Info -> Q Info
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Info -> Info
abstractNewtype
abstractNewtype :: Info -> Info
#if __GLASGOW_HASKELL__ < 800
abstractNewtype (TyConI (NewtypeD cxt name args constr derive))
= TyConI (DataD cxt name args [constr] derive)
#else
abstractNewtype :: Info -> Info
abstractNewtype (TyConI (NewtypeD cxt :: Cxt
cxt name :: Name
name args :: [TyVarBndr]
args mk :: Maybe Type
mk constr :: Con
constr derive :: [DerivClause]
derive))
= Dec -> Info
TyConI (Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
cxt Name
name [TyVarBndr]
args Maybe Type
mk [Con
constr] [DerivClause]
derive)
#endif
abstractNewtype owise :: Info
owise = Info
owise
abstractConType :: Con -> (Name,Int)
abstractConType :: Con -> (Name, Int)
abstractConType (NormalC constr :: Name
constr args :: [BangType]
args) = (Name
constr, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecC constr :: Name
constr args :: [VarBangType]
args) = (Name
constr, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
abstractConType (InfixC _ constr :: Name
constr _) = (Name
constr, 2)
abstractConType (ForallC _ _ constr :: Con
constr) = Con -> (Name, Int)
abstractConType Con
constr
abstractConType (GadtC [constr :: Name
constr] args :: [BangType]
args _) = (Name
constr, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecGadtC [constr :: Name
constr] args :: [VarBangType]
args _) = (Name
constr, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV n :: Name
n) = Name
n
tyVarBndrName (KindedTV n :: Name
n _) = Name
n
newNames :: Int -> String -> Q [Name]
newNames :: Int -> String -> Q [Name]
newNames n :: Int
n name :: String
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
name)