{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Apecs.TH ( makeWorld , makeWorldNoEC , makeWorldAndComponents , makeMapComponents ) where import Control.Monad import Language.Haskell.TH import Apecs.Core import Apecs.Stores import Apecs.Util (EntityCounter) genName :: String -> Q Name genName s = mkName . show <$> newName 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 worldName cTypes = do cTypesNames <- forM cTypes $ \t -> do rec <- genName "rec" return (ConT t, rec) let wld = mkName worldName has = mkName "Has" sys = mkName "SystemT" m = VarT $ mkName "m" wldDecl = DataD [] wld [] Nothing [RecC wld records] [] makeRecord (t,n) = (n, Bang NoSourceUnpackedness SourceStrict, ConT (mkName "Storage") `AppT` t) records = makeRecord <$> cTypesNames makeInstance (t,n) = InstanceD Nothing [ConT (mkName "Monad") `AppT` m] (ConT has `AppT` ConT wld `AppT` m `AppT` t) [ FunD (mkName "getStore") [Clause [] (NormalB$ ConE sys `AppE` (VarE (mkName "asks") `AppE` VarE n)) [] ] ] initWorldName = mkName $ "init" ++ worldName initSig = SigD initWorldName (AppT (ConT (mkName "IO")) (ConT wld)) initDecl = FunD initWorldName [Clause [] (NormalB$ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "explInit")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records) [] ] hasDecl = makeInstance <$> cTypesNames return $ wldDecl : initSig : initDecl : hasDecl -- | Creates 'Component' instances with 'Map' stores makeMapComponents :: [Name] -> Q [Dec] makeMapComponents = mapM makeMapComponent makeMapComponent :: Name -> Q Dec makeMapComponent comp = do let ct = return$ ConT comp head <$> [d| instance Component $ct where type Storage $ct = Map $ct |] -- | Calls 'makeWorld' and 'makeMapComponents', i.e. makes a world and also defines 'Component' instances with a 'Map' store. makeWorldAndComponents :: String -> [Name] -> Q [Dec] makeWorldAndComponents worldName cTypes = do wdecls <- makeWorld worldName cTypes cdecls <- makeMapComponents cTypes return $ wdecls ++ 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 worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])