{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Multi.Derive.SmartAConstructors
(
smartAConstructors
) where
import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.Annotation
import Data.Comp.Multi.Sum
import Data.Comp.Multi.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]
_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 cons :: [(Name, Int)]
cons = (Con -> (Name, Int)) -> [Con] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [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) -> Q [Dec]) -> [(Name, Int)] -> Q [[Dec]]
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 (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"iA" String -> String -> String
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 <- String -> Q Name
newName String
"_p"
let pats :: [PatQ]
pats = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP (Name
varPr Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [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
appE [|injectA $(varE varPr)|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
ExpQ -> ExpQ -> ExpQ
appE [|inj|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (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
function :: [DecQ]
function = [Name -> [ClauseQ] -> DecQ
funD Name
sname [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
pats (ExpQ -> BodyQ
normalB [|Term $val|]) []]]
[DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [DecQ]
function