{-# 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 fname :: Name
fname = do
Just (DataInfo _cxt :: Cxt
_cxt tname :: Name
tname targs :: [TyVarBndr]
targs constrs :: [Con]
constrs _deriving :: [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 iVar :: Name
iVar (ForallC _ cxt :: Cxt
cxt _) =
case [Type
y | Just (x :: Type
x, y :: 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
tp :: Type
tp:_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
iTp _ _ = Maybe Type
forall a. Maybe a
Nothing
genSmartConstr :: [Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr targs :: [Name]
targs tname :: Name
tname ((name :: Name
name, args :: Int
args), miTp :: 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
$ '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' targs :: [Name]
targs tname :: Name
tname sname :: Name
sname name :: Name
name args :: Int
args miTp :: Maybe Type
miTp = do
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args "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 targs :: [Name]
targs tname :: Name
tname sname :: Name
sname 0 miTp :: 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 "f"
Name
hvar <- String -> Q Name
newName "h"
Name
avar <- String -> Q Name
newName "a"
Name
ivar <- String -> Q Name
newName "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] -> TypeQ
classP ''(:<:) [TypeQ
ftype, 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 _ _ _ _ _ = []