{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

module Apecs.THTuples where

import qualified Data.Vector.Unboxed as U
import           Language.Haskell.TH

{--
instance (Component a, Component b) => Component (a, b) where
  type Storage (a,b) = (Storage a, Storage b)

instance (Has w a, Has w b) => Has w (a,b) where
  getStore = liftM2 (,) getStore getStore

type instance Elem (a,b) = (Elem a, Elem b)

instance (ExplGet a, ExplGet b) => ExplGet (a, b) where
  explExists (sa, sb) ety = liftM2 (&&) (explExists sa ety) (explExists sb ety)
  explGet (sa, sb) ety = liftM2 (,) (explGet sa ety) (explGet sb ety)

instance (ExplSet a, ExplSet b) => ExplSet (a, b) where
  explSet (sa,sb) ety (a,b) = explSet sa ety a >> explSet sb ety b

instance (ExplDestroy a, ExplDestroy b) => ExplDestroy (a, b) where
  explDestroy (sa, sb) ety = explDestroy sa ety >> explDestroy sb ety

instance (ExplMembers a, ExplGet b) => ExplMembers (a, b) where
  explMembers (sa, sb) = explMembers sa >>= U.filterM (explExists sb)
--}

-- | Generate tuple instances for the following tuple sizes.
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"

      -- [''a,''b] -> ''(a,b)
      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)
      -- ''(t_0, t_1, .. )
      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

      -- Component
      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
        ]

      -- Has
      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)

      -- Elem
      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

      -- s, ety, w arguments
      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]