{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.TH
( makeWorld
, makeWorldNoEC
, makeWorldAndComponents
, makeMapComponents
, makeMapComponentsFor
) where
import Control.Monad
import Language.Haskell.TH
import Apecs.Core
import Apecs.Stores
import Apecs.Util (EntityCounter)
genName :: String -> Q Name
genName :: String -> Q Name
genName String
s = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
s
makeWorldNoEC :: String -> [Name] -> Q [Dec]
makeWorldNoEC :: String -> [Name] -> Q [Dec]
makeWorldNoEC String
worldName [Name]
cTypes = do
[(Type, Name)]
cTypesNames <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
cTypes forall a b. (a -> b) -> a -> b
$ \Name
t -> do
Name
rec <- String -> Q Name
genName String
"rec"
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
t, Name
rec)
let wld :: Name
wld = String -> Name
mkName String
worldName
has :: Name
has = String -> Name
mkName String
"Has"
sys :: Name
sys = String -> Name
mkName String
"SystemT"
m :: Type
m = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"m"
wldDecl :: Dec
wldDecl = Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
wld [] forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
wld [VarBangType]
records] []
makeRecord :: (Type, a) -> (a, Bang, Type)
makeRecord (Type
t,a
n) = (a
n, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Name -> Type
ConT (String -> Name
mkName String
"Storage") Type -> Type -> Type
`AppT` Type
t)
records :: [VarBangType]
records = forall {a}. (Type, a) -> (a, Bang, Type)
makeRecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Name)]
cTypesNames
makeInstance :: (Type, Name) -> Dec
makeInstance (Type
t,Name
n) =
Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Name -> Type
ConT (String -> Name
mkName String
"Monad") Type -> Type -> Type
`AppT` Type
m] (Name -> Type
ConT Name
has Type -> Type -> Type
`AppT` Name -> Type
ConT Name
wld Type -> Type -> Type
`AppT` Type
m Type -> Type -> Type
`AppT` Type
t)
[ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"getStore") [[Pat] -> Body -> [Dec] -> Clause
Clause []
(Exp -> Body
NormalBforall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
sys Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE (String -> Name
mkName String
"asks") Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
n))
[] ]
]
initWorldName :: Name
initWorldName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"init" forall a. [a] -> [a] -> [a]
++ String
worldName
initSig :: Dec
initSig = Name -> Type -> Dec
SigD Name
initWorldName (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"IO")) (Name -> Type
ConT Name
wld))
initDecl :: Dec
initDecl = Name -> [Clause] -> Dec
FunD Name
initWorldName [[Pat] -> Body -> [Dec] -> Clause
Clause []
(Exp -> Body
NormalBforall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (\Exp
wE -> Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"<*>") Exp
wE) (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"explInit")) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"return") (Name -> Exp
ConE Name
wld)) forall a. [a] -> Int -> a
!! forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
records)
[] ]
hasDecl :: [Dec]
hasDecl = (Type, Name) -> Dec
makeInstance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Name)]
cTypesNames
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
wldDecl forall a. a -> [a] -> [a]
: Dec
initSig forall a. a -> [a] -> [a]
: Dec
initDecl forall a. a -> [a] -> [a]
: [Dec]
hasDecl
makeMapComponents :: [Name] -> Q [Dec]
makeMapComponents :: [Name] -> Q [Dec]
makeMapComponents = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Dec
makeMapComponent
makeMapComponent :: Name -> Q Dec
makeMapComponent :: Name -> Q Dec
makeMapComponent = Name -> Name -> Q Dec
makeMapComponentFor ''Map
makeMapComponentFor :: Name -> Name -> Q Dec
makeMapComponentFor :: Name -> Name -> Q Dec
makeMapComponentFor Name
store Name
comp = do
let ct :: Q Type
ct = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
comp
st :: Q Type
st = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
store
forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [d| instance Component $ct where type Storage $ct = $st $ct |]
makeMapComponentsFor :: Name -> [Name] -> Q [Dec]
makeMapComponentsFor :: Name -> [Name] -> Q [Dec]
makeMapComponentsFor Name
store = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Name -> Q Dec
makeMapComponentFor Name
store)
makeWorldAndComponents :: String -> [Name] -> Q [Dec]
makeWorldAndComponents :: String -> [Name] -> Q [Dec]
makeWorldAndComponents String
worldName [Name]
cTypes = do
[Dec]
wdecls <- String -> [Name] -> Q [Dec]
makeWorld String
worldName [Name]
cTypes
[Dec]
cdecls <- [Name] -> Q [Dec]
makeMapComponents [Name]
cTypes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
wdecls forall a. [a] -> [a] -> [a]
++ [Dec]
cdecls
makeWorld :: String -> [Name] -> Q [Dec]
makeWorld :: String -> [Name] -> Q [Dec]
makeWorld String
worldName [Name]
cTypes = String -> [Name] -> Q [Dec]
makeWorldNoEC String
worldName ([Name]
cTypes forall a. [a] -> [a] -> [a]
++ [''EntityCounter])