{-# LANGUAGE TemplateHaskell #-}
module Apecs.THTuples where
import qualified Data.Vector.Unboxed as U
import Language.Haskell.TH
makeInstances :: [Int] -> Q [Dec]
makeInstances is = concat <$> traverse tupleInstances is
tupleInstances :: Int -> Q [Dec]
tupleInstances n = do
let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]]
m = VarT $ mkName "m"
tupleUpT :: [Type] -> Type
tupleUpT = foldl AppT (TupleT n)
varTuple :: Type
varTuple = tupleUpT vars
tupleName :: Name
tupleName = tupleDataName n
tuplE :: Exp
tuplE = ConE tupleName
compN = mkName "Component"
compT var = ConT compN `AppT` var
strgN = mkName "Storage"
strgT var = ConT strgN `AppT` var
compI = InstanceD Nothing (fmap compT vars) (compT varTuple)
[ TySynInstD strgN $
TySynEqn [varTuple] (tupleUpT . fmap strgT $ vars)
]
hasN = mkName "Has"
hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` m `AppT` var
getStoreN = mkName "getStore"
getStoreE = VarE getStoreN
apN = mkName "<*>"
apE = VarE apN
hasI = InstanceD Nothing (hasT <$> vars) (hasT varTuple)
[ FunD getStoreN
[Clause [] (NormalB$ liftAll tuplE (replicate n getStoreE )) [] ]
, PragmaD$ InlineP getStoreN Inline FunLike AllPhases
]
liftAll f mas = foldl (\a x -> AppE (AppE apE a) x) (AppE (VarE (mkName "pure")) f) mas
sequenceAll :: [Exp] -> Exp
sequenceAll = foldl1 (\a x -> AppE (AppE (VarE$ mkName ">>") a) x)
elemN = mkName "Elem"
elemT var = ConT elemN `AppT` var
elemI = TySynInstD elemN $ TySynEqn [varTuple] (tupleUpT $ fmap elemT vars)
sNs = [ mkName $ "s_" ++ show i | i <- [0..n-1]]
sPat = ConP tupleName (VarP <$> sNs)
sEs = VarE <$> sNs
etyN = mkName "ety"
etyE = VarE etyN
etyPat = VarP etyN
wNs = [ mkName $ "w_" ++ show i | i <- [0..n-1]]
wPat = ConP tupleName (VarP <$> wNs)
wEs = VarE <$> wNs
getN = mkName "ExplGet"
setN = mkName "ExplSet"
membersN = mkName "ExplMembers"
destroyN = mkName "ExplDestroy"
getT s = ConT getN `AppT` m `AppT` s
setT s = ConT setN `AppT` m `AppT` s
membersT s = ConT membersN `AppT` m `AppT` s
destroyT s = ConT destroyN `AppT` m `AppT` s
explSetN = mkName "explSet"
explDestroyN = mkName "explDestroy"
explExistsN = mkName "explExists"
explMembersN = mkName "explMembers"
explGetN = mkName "explGet"
explSetE = VarE explSetN
explDestroyE = VarE explDestroyN
explExistsE = VarE explExistsN
explMembersE = VarE explMembersN
explGetE = VarE explGetN
explSetF sE wE = AppE explSetE sE `AppE` etyE `AppE` wE
explDestroyF sE = AppE explDestroyE sE `AppE` etyE
explExistsF sE = AppE explExistsE sE
explMembersF sE = AppE explMembersE sE
explGetF sE = AppE explGetE sE `AppE` etyE
explExistsAnd va vb =
AppE (AppE (VarE '(>>=)) va)
(LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) []
, Match (ConP 'True []) (NormalB vb) []
])
explMembersFold va vb = AppE (VarE '(>>=)) va `AppE` AppE (VarE 'U.filterM) vb
getI = InstanceD Nothing (getT <$> vars) (getT varTuple)
[ FunD explGetN [Clause [sPat, etyPat]
(NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ]
, PragmaD$ InlineP explGetN Inline FunLike AllPhases
, FunD explExistsN [Clause [sPat, etyPat]
(NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ]
, PragmaD$ InlineP explExistsN Inline FunLike AllPhases
]
setI = InstanceD Nothing (setT <$> vars) (setT varTuple)
[ FunD explSetN [Clause [sPat, etyPat, wPat]
(NormalB$ sequenceAll (zipWith explSetF sEs wEs)) [] ]
, PragmaD$ InlineP explSetN Inline FunLike AllPhases
]
destroyI = InstanceD Nothing (destroyT <$> vars) (destroyT varTuple)
[ FunD explDestroyN [Clause [sPat, etyPat]
(NormalB$ sequenceAll (explDestroyF <$> sEs)) [] ]
, PragmaD$ InlineP explDestroyN Inline FunLike AllPhases
]
membersI = InstanceD Nothing (membersT (head vars) : (getT <$> tail vars)) (membersT varTuple)
[ FunD explMembersN [Clause [sPat]
(NormalB$ foldl explMembersFold (explMembersF (head sEs)) (explExistsF <$> tail sEs)) [] ]
, PragmaD$ InlineP explMembersN Inline FunLike AllPhases
]
return [compI, hasI, elemI, getI, setI, destroyI, membersI]