{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Multi.Derive.SmartConstructors
(
smartConstructors
) where
import Control.Arrow ((&&&))
import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.Sum
import Data.Comp.Multi.Term
import Language.Haskell.TH hiding (Cxt)
smartConstructors :: Name -> Q [Dec]
smartConstructors :: Name -> Q [Dec]
smartConstructors Name
fname = do
Just (DataInfo Cxt
_cxt Name
tname [TyVarBndr]
targs [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
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 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
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe Type) -> Q [Dec])
-> [((Name, Int), Maybe Type)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
targs) Name
tname) [((Name, Int), Maybe Type)]
cons
where iTp :: Name -> Con -> Maybe Type
iTp Name
iVar (ForallC [TyVarBndr]
_ Cxt
cxt Con
_) =
case [Type
y | Just (Type
x, Type
y) <- (Type -> Maybe (Type, Type)) -> Cxt -> [Maybe (Type, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Maybe (Type, Type)
isEqualP Cxt
cxt, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
iVar] of
[] -> Maybe Type
forall a. Maybe a
Nothing
Type
tp:Cxt
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
iTp Name
_ Con
_ = Maybe Type
forall a. Maybe a
Nothing
genSmartConstr :: [Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr [Name]
targs Name
tname ((Name
name, Int
args), Maybe Type
miTp) = do
let bname :: String
bname = Name -> String
nameBase Name
name
[Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'i' Char -> String -> String
forall a. a -> [a] -> [a]
: String
bname) Name
name Int
args Maybe Type
miTp
genSmartConstr' :: [Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname Name
sname Name
name Int
args Maybe Type
miTp = do
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args String
"x"
let pats :: [PatQ]
pats = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
varNs
vars :: [ExpQ]
vars = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
varNs
val :: ExpQ
val = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
name) [ExpQ]
vars
sig :: [Q Dec]
sig = [Name] -> Name -> Name -> Int -> Maybe Type -> [Q Dec]
forall a.
(Eq a, Num a) =>
[Name] -> Name -> Name -> a -> Maybe Type -> [Q Dec]
genSig [Name]
targs Name
tname Name
sname Int
args Maybe Type
miTp
function :: [Q Dec]
function = [Name -> [ClauseQ] -> Q Dec
funD Name
sname [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats (ExpQ -> BodyQ
normalB [|inject $val|]) []]]
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q Dec]
sig [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
function
genSig :: [Name] -> Name -> Name -> a -> Maybe Type -> [Q Dec]
genSig [Name]
targs Name
tname Name
sname a
0 Maybe Type
miTp = (Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> [Q Dec]) -> Q Dec -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ do
Name
fvar <- String -> Q Name
newName String
"f"
Name
hvar <- String -> Q Name
newName String
"h"
Name
avar <- String -> Q Name
newName String
"a"
Name
ivar <- String -> Q Name
newName String
"i"
let targs' :: [Name]
targs' = [Name] -> [Name]
forall a. [a] -> [a]
init ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
init [Name]
targs
vars :: [Name]
vars = Name
hvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
fvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
avarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name] -> (Type -> [Name]) -> Maybe Type -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Name
ivar] ([Name] -> Type -> [Name]
forall a b. a -> b -> a
const []) Maybe Type
miTp[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Name]
targs'
f :: TypeQ
f = Name -> TypeQ
varT Name
fvar
h :: TypeQ
h = Name -> TypeQ
varT Name
hvar
a :: TypeQ
a = Name -> TypeQ
varT Name
avar
i :: TypeQ
i = Name -> TypeQ
varT Name
ivar
ftype :: TypeQ
ftype = (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 Name
tname) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
targs')
constr :: TypeQ
constr = (Name -> TypeQ
conT ''(:<:) TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
ftype) TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
f
typ :: TypeQ
typ = (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 ''Cxt) [TypeQ
h, TypeQ
f, TypeQ
a, TypeQ -> (Type -> TypeQ) -> Maybe Type -> TypeQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeQ
i Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
miTp]
typeSig :: TypeQ
typeSig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
vars) ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ
constr]) TypeQ
typ
Name -> TypeQ -> Q Dec
sigD Name
sname TypeQ
typeSig
genSig [Name]
_ Name
_ Name
_ a
_ Maybe Type
_ = []