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