{-# 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 (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
s
makeWorldNoEC :: String -> [Name] -> Q [Dec]
makeWorldNoEC :: String -> [Name] -> Q [Dec]
makeWorldNoEC String
worldName [Name]
cTypes = do
[(Type, Name)]
cTypesNames <- [Name] -> (Name -> Q (Type, Name)) -> Q [(Type, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
cTypes ((Name -> Q (Type, Name)) -> Q [(Type, Name)])
-> (Name -> Q (Type, Name)) -> Q [(Type, Name)]
forall a b. (a -> b) -> a -> b
$ \Name
t -> do
Name
rec <- String -> Q Name
genName String
"rec"
(Type, Name) -> Q (Type, Name)
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 (Name -> Type) -> Name -> Type
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 [] Maybe Type
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 = (Type, Name) -> VarBangType
forall a. (Type, a) -> (a, Bang, Type)
makeRecord ((Type, Name) -> VarBangType) -> [(Type, Name)] -> [VarBangType]
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 Maybe Overlap
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
NormalB(Exp -> Body) -> Exp -> Body
forall 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 (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"init" String -> String -> String
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
NormalB(Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> Exp -> [Exp]
forall a. (a -> a) -> a -> [a]
iterate (\Exp
wE -> 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
wE) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"explInit")) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"return") (Name -> Exp
ConE Name
wld)) [Exp] -> Int -> Exp
forall a. [a] -> Int -> a
!! [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
records)
[] ]
hasDecl :: [Dec]
hasDecl = (Type, Name) -> Dec
makeInstance ((Type, Name) -> Dec) -> [(Type, Name)] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Name)]
cTypesNames
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
wldDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
initSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
initDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
hasDecl
makeMapComponents :: [Name] -> Q [Dec]
makeMapComponents :: [Name] -> Q [Dec]
makeMapComponents = (Name -> Q Dec) -> [Name] -> Q [Dec]
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 = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
comp
st :: Q Type
st = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
store
[Dec] -> Dec
forall a. [a] -> a
head ([Dec] -> Dec) -> Q [Dec] -> Q Dec
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 = (Name -> Q Dec) -> [Name] -> Q [Dec]
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
wdecls [Dec] -> [Dec] -> [Dec]
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 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''EntityCounter])