{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Derive.SmartAConstructors
(
smartAConstructors
) where
import Control.Monad
import Data.Comp.Annotation
import Data.Comp.Derive.Utils
import Data.Comp.Sum
import Data.Comp.Term
import Language.Haskell.TH hiding (Cxt)
smartAConstructors :: Name -> Q [Dec]
smartAConstructors :: Name -> Q [Dec]
smartAConstructors Name
fname = do
Just (DataInfo Cxt
_cxt Name
_tname [TyVarBndr flag]
_targs [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let cons :: [(Name, Int)]
cons = forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [Con]
constrs
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, Int) -> Q [Dec]
genSmartConstr [(Name, Int)]
cons
where genSmartConstr :: (Name, Int) -> Q [Dec]
genSmartConstr (Name
name, Int
args) = do
let bname :: String
bname = Name -> String
nameBase Name
name
Name -> Name -> Int -> Q [Dec]
genSmartConstr' (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"iA" forall a. [a] -> [a] -> [a]
++ String
bname) Name
name Int
args
genSmartConstr' :: Name -> Name -> Int -> Q [Dec]
genSmartConstr' Name
sname Name
name Int
args = do
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args String
"x"
Name
varPr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_p"
let pats :: [Q Pat]
pats = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name
varPr forall a. a -> [a] -> [a]
: [Name]
varNs)
vars :: [Q Exp]
vars = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
val :: Q Exp
val = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|injectA $(varE varPr)|] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|inj|] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) [Q Exp]
vars
function :: [Q Dec]
function = [forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
sname [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|Term $val|]) []]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Dec]
function