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

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

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

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

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

{-|

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 forall a. [a] -> [a] -> [a]
++ [''EntityCounter])