{-# 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

-- | Same as 'makeWorld', but does not include an 'EntityCounter'
--   You don't typically want to use this, but it's exposed in case you know what you're doing.
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

-- | Creates 'Component' instances with 'Map' stores
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

-- | Allows customization of the store to be used. For example, the base 'Map' or an STM 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)

-- | Calls 'makeWorld' and 'makeMapComponents', i.e. makes a world and also defines 'Component' instances with a 'Map' 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

{-|

The typical way to create a @world@ record, associated 'Has' instances, and initialization function.

> makeWorld "MyWorld" [''Component1, ''Component2, ...]

turns into

> data MyWorld = MyWorld Component1 Component2 ... EntityCounter
> instance MyWorld `Has` Component1 where ...
> instance MyWorld `Has` Component2 where ...
> ...
> instance MyWorld `Has` EntityCounter where ...
>
> initMyWorld :: IO MyWorld
> initMyWorld = MyWorld <$> initStore <*> initStore <*> ... <*> initStore

-}
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])