apecs 0.3.0.2 → 0.4.0.0

raw patch · 10 files changed

+260/−236 lines, 10 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +3/−3
• apecs.cabal +3/−1
• src/Apecs.hs +5/−3
• src/Apecs/Concurrent.hs +4/−4
• src/Apecs/Core.hs +56/−77
• src/Apecs/Stores.hs +74/−61
• src/Apecs/System.hs +26/−23
• src/Apecs/TH.hs +21/−5
• src/Apecs/THTuples.hs +65/−53
• src/Apecs/Util.hs +3/−6

@@ -1,10 +1,10 @@ # apecs [![Build Status](https://travis-ci.org/jonascarpay/apecs.svg?branch=master)](https://travis-ci.org/jonascarpay/apecs) [![Hackage](https://img.shields.io/hackage/v/apecs.svg)](https://hackage.haskell.org/package/apecs)-[![apecs on Stackage LTS 10](http://stackage.org/package/apecs/badge/lts-10)](http://stackage.org/lts-10/package/apecs)+[![apecs on Stackage LTS 11](http://stackage.org/package/apecs/badge/lts-11)](http://stackage.org/lts-10/package/apecs) -apecs is an _Entity Component System_ inspired by [specs](https://github.com/slide-rs/specs) and [Entitas](https://github.com/sschmid/Entitas-CSharp).-It provides a collection of mutable component stores, and an expressive DSL for operating on those stores, both easily extended.+apecs is an _Entity Component System_ framework inspired by [specs](https://github.com/slide-rs/specs) and [Entitas](https://github.com/sschmid/Entitas-CSharp).+The front-end DSL allows you to concisely express your game logic, with an efficient back-end storage framework that can be extended to meet any performance needs.  #### Links - [documentation](https://hackage.haskell.org/package/apecs/docs/Apecs.html)

@@ -1,5 +1,5 @@ name:                apecs-version:             0.3.0.2+version:             0.4.0.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -53,6 +53,8 @@     base >= 4.7 && < 5,     apecs,     QuickCheck,+    criterion,+    linear,     containers,     vector   default-language:

@@ -3,12 +3,13 @@ It selectively re-exports the user-facing functions from the submodules. -} module Apecs (+  module Data.Proxy,   -- * Core types     System(..), Component(..), Entity(..), Has(..), Not(..),    -- * Stores     Map, Unique, Global, Cache,-    initStore,+    explInit,    -- * Systems     get, set, getAll,@@ -17,14 +18,15 @@    -- * Other     runSystem, runWith,-    runGC, EntityCounter, newEntity, global, proxy,-    makeWorld,+    runGC, EntityCounter, newEntity, global,+    makeWorld, makeWorldAndComponents,    -- * Re-exports     asks, ask, liftIO, lift, ) where  import           Control.Monad.Reader (ask, asks, lift, liftIO)+import           Data.Proxy  import           Apecs.Stores import           Apecs.System

@@ -23,12 +23,12 @@  -- | Parallel version of @cmap@.  {-# INLINE pmap #-}-pmap :: forall w x y. (Has w y, Has w x)+pmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy)      => Int -- ^ Entities per thread-     -> (x -> y) -> System w ()+     -> (cx -> cy) -> System w () pmap grainSize f =-  do sr :: Storage x <- getStore-     sw :: Storage y <- getStore+  do sr :: Storage cx <- getStore+     sw :: Storage cy <- getStore      liftIO$ do        sl <- explMembers sr        parallelize grainSize (\e -> explGet sr e >>= explSet sw e . f) sl

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -11,54 +12,58 @@  import           Control.Monad.Reader import           Data.Functor.Identity-import qualified Data.Vector.Unboxed  as U+import qualified Data.Vector.Unboxed   as U -import qualified Apecs.THTuples       as T+import qualified Apecs.THTuples        as T --- | An Entity is really just an Int in a newtype, used to index into a component store.-newtype Entity = Entity Int deriving (Eq, Ord, Show)+-- | An Entity is just an integer, used to index into a component store.+newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show) --- | A system is a newtype around `ReaderT w IO a`, where `w` is the game world variable.+-- | A System is a newtype around `ReaderT w IO a`, where `w` is the game world variable. newtype System w a = System {unSystem :: ReaderT w IO a} deriving (Functor, Monad, Applicative, MonadIO)  -- | A component is defined by the type of its storage --   The storage in turn supplies runtime types for the component. --   For the component to be valid, its Storage must be an instance of Store.-class (Elem (Storage c) ~ c, Store (Storage c)) => Component c where+class (Elem (Storage c) ~ c) => Component c where   type Storage c  -- | A world `Has` a component if it can produce its Storage class Component c => Has w c where   getStore :: System w (Storage c) --- | Holds components indexed by entities------   Laws:------      * For all entities in @exmplMembers s@, @explExists s ety@ must be true.------      * If for some entity @explExists s ety@, @explGet s ety@ should safely return a non-bottom value.-class Store s where-  -- | The type of components stored by this Store-  type Elem s+-- | The type of components stored by a Store+type family Elem s +-- | Holds components indexed by entities+class ExplInit s where   -- | Initialize the store with its initialization arguments.-  initStore :: IO s+  explInit :: IO s -  -- | Writes a component-  explSet :: s -> Int -> Elem s -> IO ()+-- | Stores that support @get@ and @exists@ in the IO monad+--   If @existsIO@+class ExplGet s where   -- | Reads a component from the store. What happens if the component does not exist is left undefined.   explGet :: s -> Int -> IO (Elem s)+  -- | Returns whether there is a component for the given index+  explExists :: s -> Int -> IO Bool++class ExplSet s where+  -- | Writes a component+  explSet :: s -> Int -> Elem s -> IO ()++class ExplDestroy s where   -- | Destroys the component for a given index.   explDestroy :: s -> Int -> IO ()++class ExplMembers s where   -- | Returns an unboxed vector of member indices   explMembers :: s -> IO (U.Vector Int) -  -- | Returns whether there is a component for the given index-  explExists :: s -> Int -> IO Bool-  explExists s n = do-    mems <- explMembers s-    return $ U.elem n mems+type Get     w c = (Has w c, ExplGet     (Storage c))+type Set     w c = (Has w c, ExplSet     (Storage c))+type Members w c = (Has w c, ExplMembers (Storage c))+type Destroy w c = (Has w c, ExplDestroy (Storage c))  instance Component c => Component (Identity c) where   type Storage (Identity c) = Identity (Storage c)@@ -66,18 +71,23 @@ instance Has w c => Has w (Identity c) where   getStore = Identity <$> getStore -instance Store s => Store (Identity s) where-  type Elem (Identity s) = Identity (Elem s)-  initStore = error "Initializing Pseudostore"+type instance Elem (Identity s) = Identity (Elem s)++instance ExplGet s => ExplGet (Identity s) where   explGet (Identity s) e = Identity <$> explGet s e-  explSet (Identity s) e (Identity x) = explSet s e x   explExists  (Identity s) = explExists s++instance ExplSet s => ExplSet (Identity s) where+  explSet (Identity s) e (Identity x) = explSet s e x+instance ExplMembers s => ExplMembers (Identity s) where   explMembers (Identity s) = explMembers s+instance ExplDestroy s => ExplDestroy (Identity s) where   explDestroy (Identity s) = explDestroy s --- Tuple Instances+-- Tuple Instances TODO T.makeInstances [2..8] + -- | Psuedocomponent indicating the absence of @a@. data Not a = Not @@ -90,15 +100,15 @@ instance (Has w c) => Has w (Not c) where   getStore = NotStore <$> getStore -instance Store s => Store (NotStore s) where-  type Elem (NotStore s) = Not (Elem s)-  initStore = error "Initializing Pseudostore"+type instance Elem (NotStore s) = Not (Elem s)++instance ExplGet s => ExplGet (NotStore s) where   explGet _ _ = return Not-  explSet (NotStore sa) ety _ = explDestroy sa ety   explExists (NotStore sa) ety = not <$> explExists sa ety-  explMembers _ = return mempty-  explDestroy sa ety = explSet sa ety Not +instance ExplDestroy s => ExplSet (NotStore s) where+  explSet (NotStore sa) ety _ = explDestroy sa ety+ -- | Pseudostore used to produce values of type @Maybe a@ newtype MaybeStore s = MaybeStore s instance Component c => Component (Maybe c) where@@ -107,42 +117,18 @@ instance (Has w c) => Has w (Maybe c) where   getStore = MaybeStore <$> getStore -instance Store s => Store (MaybeStore s) where-  type Elem (MaybeStore s) = Maybe (Elem s)-  initStore = error "Initializing Pseudostore"+type instance Elem (MaybeStore s) = Maybe (Elem s)++instance ExplGet s => ExplGet (MaybeStore s) where   explGet (MaybeStore sa) ety = do     e <- explExists sa ety     if e then Just <$> explGet sa ety          else return Nothing-  explSet (MaybeStore sa) ety Nothing = explDestroy sa ety-  explSet (MaybeStore sa) ety (Just x) = explSet sa ety x   explExists _ _ = return True-  explMembers _ = return mempty-  explDestroy (MaybeStore sa) ety = explDestroy sa ety --- | Pseudostore used to produce values of type @Either p q@-data EitherStore sp sq = EitherStore sp sq-instance (Component p, Component q) => Component (Either p q) where-  type Storage (Either p q) = EitherStore (Storage p) (Storage q)--instance (Has w p, Has w q) => Has w (Either p q) where-  getStore = EitherStore <$> getStore <*> getStore--instance (Store sp, Store sq) => Store (EitherStore sp sq) where-  type Elem (EitherStore sp sq) = Either (Elem sp) (Elem sq)-  initStore = error "Initializing Pseudostore"-  explGet (EitherStore sp sq) ety = do-    e <- explExists sp ety-    if e then Left <$> explGet sp ety-         else Right <$> explGet sq ety-  explSet (EitherStore sp _) ety (Left p) = explSet sp ety p-  explSet (EitherStore _ sq) ety (Right q) = explSet sq ety q-  explExists (EitherStore sp sq) ety = do-    e <- explExists sp ety-    if e then return True-         else explExists sq ety-  explMembers _ = return mempty-  explDestroy _ _ = return ()+instance (ExplDestroy s, ExplSet s) => ExplSet (MaybeStore s) where+  explSet (MaybeStore sa) ety Nothing  = explDestroy sa ety+  explSet (MaybeStore sa) ety (Just x) = explSet sa ety x  data Filter c = Filter deriving (Eq, Show) newtype FilterStore s = FilterStore s@@ -153,14 +139,11 @@ instance Has w c => Has w (Filter c) where   getStore = FilterStore <$> getStore -instance Store s => Store (FilterStore s) where-  type Elem (FilterStore s) = Filter (Elem s)-  initStore = error "Initializing Pseudostore"+type instance Elem (FilterStore s) = Filter (Elem s)++instance ExplGet s => ExplGet (FilterStore s) where   explGet _ _ = return Filter-  explSet _ _ _ = return ()   explExists (FilterStore s) ety = explExists s ety-  explMembers (FilterStore s) = explMembers s-  explDestroy _ _ = return ()  -- | Pseudostore used to produce components of type @Entity@ data EntityStore = EntityStore@@ -170,11 +153,7 @@ instance (Has w Entity) where   getStore = return EntityStore -instance Store EntityStore where-  type Elem EntityStore = Entity-  initStore = error "Initializing Pseudostore"+type instance Elem EntityStore = Entity+instance ExplGet EntityStore where   explGet _ ety = return $ Entity ety-  explSet _ _ _ = liftIO$ putStrLn "Warning: Writing Entity is undefined"   explExists _ _ = return True-  explMembers _ = return mempty-  explDestroy _ _ = return ()

@@ -28,97 +28,93 @@  -- | A map based on @Data.Intmap.Strict@. O(log(n)) for most operations. newtype Map c = Map (IORef (M.IntMap c))-instance Store (Map c) where-  type Elem (Map c) = c-  initStore = Map <$> newIORef mempty-  explGet     (Map ref) ety   = fromJust . M.lookup ety <$> readIORef ref-  explSet     (Map ref) ety x = modifyIORef' ref $ M.insert ety x-  explExists  (Map ref) ety   = M.member ety <$> readIORef ref-  explDestroy (Map ref) ety   = modifyIORef' ref (M.delete ety)-  explMembers (Map ref)       = U.fromList . M.keys <$> readIORef ref++type instance Elem (Map c) = c+instance ExplInit (Map c) where+  explInit = Map <$> newIORef mempty++instance ExplGet (Map c) where+  explExists (Map ref) ety = M.member ety <$> readIORef ref+  explGet    (Map ref) ety = fromJust . M.lookup ety <$> readIORef ref+  {-# INLINE explExists #-}   {-# INLINE explGet #-}++instance ExplSet (Map c) where   {-# INLINE explSet #-}+  explSet (Map ref) ety x = modifyIORef' ref $ M.insert ety x++instance ExplDestroy (Map c) where   {-# INLINE explDestroy #-}+  explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety)++instance ExplMembers (Map c) where   {-# INLINE explMembers #-}-  {-# INLINE explExists #-}+  explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref  -- | A Unique contains zero or one component. --   Writing to it overwrites both the previous component and its owner. --   Its main purpose is to be a @Map@ optimized for when only ever one component inhabits it. data Unique c = Unique (IORef Int) (IORef c)-instance Store (Unique c) where-  type Elem (Unique c) = c-  initStore = Unique <$> newIORef (-1) <*> newIORef (error "Uninitialized Unique value")-  explGet     (Unique _ cref) _ = readIORef cref-  explSet     (Unique eref cref) ety x = writeIORef eref ety >> writeIORef cref x+type instance Elem (Unique c) = c+instance ExplInit (Unique c) where+  explInit = Unique <$> newIORef (-1) <*> newIORef (error "Uninitialized Unique value")++instance ExplGet (Unique c) where+  {-# INLINE explGet #-}+  explGet (Unique _ cref) _ = readIORef cref+  {-# INLINE explExists #-}+  explExists (Unique eref _) ety = (==ety) <$> readIORef eref++instance ExplSet (Unique c) where+  {-# INLINE explSet #-}+  explSet (Unique eref cref) ety x = writeIORef eref ety >> writeIORef cref x++instance ExplDestroy (Unique c) where+  {-# INLINE explDestroy #-}   explDestroy (Unique eref _) ety = do e <- readIORef eref; when (e==ety) (writeIORef eref (-1))++instance ExplMembers (Unique c) where+  {-# INLINE explMembers #-}   explMembers (Unique eref _) = f <$> readIORef eref     where f (-1) = mempty           f x    = U.singleton x-  explExists  (Unique eref _) ety = (==ety) <$> readIORef eref-  {-# INLINE explDestroy #-}-  {-# INLINE explMembers #-}-  {-# INLINE explExists #-}-  {-# INLINE explSet #-}-  {-# INLINE explGet #-}  -- | A Global contains exactly one component. --   Initialized with 'mempty' --   The store will return true for every existence check, but only ever gives (-1) as its inhabitant. --   The entity argument is ignored when setting/getting a global. newtype Global c = Global (IORef c)-instance Monoid c => Store (Global c) where-  type Elem   (Global c) = c-  initStore = Global <$> newIORef mempty-  explGet (Global ref) _   = readIORef ref+type instance Elem (Global c) = c+instance Monoid c => ExplInit (Global c) where+  explInit = Global <$> newIORef mempty++instance ExplGet (Global c) where+  explGet (Global ref) _ = readIORef ref+  explExists _ _ = return True++instance ExplSet (Global c) where   explSet (Global ref) _ c = writeIORef ref c-  explExists  _ _ = return True-  explDestroy s _ = explSet s 0 mempty-  explMembers _ = return $ U.singleton (-1)-  {-# INLINE explDestroy #-}-  {-# INLINE explMembers #-}-  {-# INLINE explExists #-}-  {-# INLINE explSet #-}-  {-# INLINE explGet #-} +-- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached.+class Cachable s+instance Cachable (Map s)+instance (KnownNat n, Cachable s) => Cachable (Cache n s)+ -- | A cache around another store. --   Note that iterating over a cache is linear in cache size, so sparsely populated caches might actually decrease performance. data Cache (n :: Nat) s =   Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s---- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached.-class Store s => Cachable s-instance Cachable (Map s)-instance (KnownNat n, Cachable s) => Cachable (Cache n s)+type instance Elem (Cache n s) = Elem s -instance (KnownNat n, Cachable s) => Store (Cache n s) where-  type Elem (Cache n s) = Elem s-  initStore = do+instance (ExplInit s, KnownNat n, Cachable s) => ExplInit (Cache n s) where+  explInit = do     let n = fromIntegral$ natVal (Proxy @n)     tags <- UM.replicate n (-1)     cache <- VM.new n-    child <- initStore+    child <- explInit     return (Cache n tags cache child) -  {-# INLINE explDestroy #-}-  explDestroy (Cache n tags _ s) ety = do-    tag <- UM.unsafeRead tags (ety `rem` n)-    if tag == ety-       then UM.unsafeWrite tags (ety `rem` n) (-1)-       else explDestroy s ety--  {-# INLINE explExists #-}-  explExists (Cache n tags _ s) ety = do-    tag <- UM.unsafeRead tags (ety `rem` n)-    if tag == ety then return True else explExists s ety--  {-# INLINE explMembers #-}-  explMembers (Cache _ tags _ s) = do-    cached <- U.filter (/= (-1)) <$> U.freeze tags-    stored <- explMembers s-    return $! cached U.++ stored--  {-# INLINE explGet #-}+instance ExplGet s => ExplGet (Cache n s) where   explGet (Cache n tags cache s) ety = do     let index = ety `rem` n     tag <- UM.unsafeRead tags index@@ -126,7 +122,11 @@        then VM.unsafeRead cache index        else explGet s ety -  {-# INLINE explSet #-}+  explExists (Cache n tags _ s) ety = do+    tag <- UM.unsafeRead tags (ety `rem` n)+    if tag == ety then return True else explExists s ety++instance ExplSet s => ExplSet (Cache n s) where   explSet (Cache n tags cache s) ety x = do     let index = ety `rem` n     tag <- UM.unsafeRead tags index@@ -135,3 +135,16 @@       explSet s tag cached     UM.unsafeWrite tags  index ety     VM.unsafeWrite cache index x++instance ExplDestroy s => ExplDestroy (Cache n s) where+  explDestroy (Cache n tags _ s) ety = do+    tag <- UM.unsafeRead tags (ety `rem` n)+    if tag == ety+       then UM.unsafeWrite tags (ety `rem` n) (-1)+       else explDestroy s ety++instance ExplMembers s => ExplMembers (Cache n s) where+  explMembers (Cache _ tags _ s) = do+    cached <- U.filter (/= (-1)) <$> U.freeze tags+    stored <- explMembers s+    return $! cached U.++ stored

@@ -7,6 +7,7 @@ module Apecs.System where  import           Control.Monad.Reader+import           Data.Proxy import qualified Data.Vector.Unboxed  as U  import           Apecs.Core@@ -22,7 +23,7 @@ runWith = flip runSystem  {-# INLINE get #-}-get :: forall w c. Has w c => Entity -> System w c+get :: forall w c. Get w c => Entity -> System w c get (Entity ety) = do   s :: Storage c <- getStore   liftIO$ explGet s ety@@ -31,7 +32,7 @@ --   The type was originally 'Entity c -> c -> System w ()', but is relaxed to 'Entity e' --   so you don't always have to write 'set . cast' {-# INLINE set #-}-set :: forall w c. Has w c => Entity -> c -> System w ()+set :: forall w c. Set w c => Entity -> c -> System w () set (Entity ety) x = do   s :: Storage c <- getStore   liftIO$ explSet s ety x@@ -39,39 +40,41 @@ -- | Returns whether the given entity has component @c@ --   Note that @c@ is a phantom argument, used only to convey the type of the entity to be queried. {-# INLINE exists #-}-exists :: forall w c. Has w c => Entity -> c -> System w Bool-exists (Entity ety) ~_ = do+exists :: forall w c. Get w c => Entity -> Proxy c -> System w Bool+exists (Entity ety) _ = do   s :: Storage c <- getStore   liftIO$ explExists s ety  -- | Maps a function over all entities with a @cx@, and writes their @cy@ {-# INLINE cmap #-}-cmap :: forall world cx cy. (Has world cx, Has world cy)-     => (cx -> cy) -> System world ()+cmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy)+     => (cx -> cy) -> System w () cmap f = do   sx :: Storage cx <- getStore   sy :: Storage cy <- getStore   liftIO$ do-    sl <- liftIO$ explMembers sx+    sl <- explMembers sx     U.forM_ sl $ \ e -> do       r <- explGet sx e       explSet sy e (f r) --- | Monadically iterates over all entites with a cx+-- | Monadically iterates over all entites with a cx, and writes their cy {-# INLINE cmapM #-}-cmapM :: forall world c a. Has world c-      => (c -> System world a) -> System world [a]+cmapM :: forall w cx cy. (Get w cx, Set w cy, Members w cx)+      => (cx -> System w cy) -> System w () cmapM sys = do-  s :: Storage c <- getStore-  sl <- liftIO$ explMembers s-  forM (U.toList sl) $ \ ety -> do-    x <- liftIO$ explGet s ety-    sys x+  sx :: Storage cx <- getStore+  sy :: Storage cy <- getStore+  sl <- liftIO$ explMembers sx+  U.forM_ sl $ \ e -> do+    x <- liftIO$ explGet sx e+    y <- sys x+    liftIO$ explSet sy e y  -- | Monadically iterates over all entites with a cx {-# INLINE cmapM_ #-}-cmapM_ :: forall world c a. Has world c-       => (c -> System world a) -> System world ()+cmapM_ :: forall w c a. (Get w c, Members w c)+       => (c -> System w a) -> System w () cmapM_ sys = do   s :: Storage c <- getStore   sl <- liftIO$ explMembers s@@ -82,8 +85,8 @@ -- | Get all components @c@. --   Call as @[(c,Entity)]@ to read the entity/index. {-# INLINE getAll #-}-getAll :: forall world c. Has world c-      => System world [c]+getAll :: forall w c. (Get w c, Members w c)+      => System w [c] getAll = do   s :: Storage c <- getStore   sl <- liftIO$ explMembers s@@ -93,14 +96,14 @@ -- | Destroys component @c@ for the given entity. -- Note that @c@ is a phantom argument, used only to convey the type of the entity to be destroyed. {-# INLINE destroy #-}-destroy :: forall w c. Has w c => Entity -> c -> System w ()-destroy (Entity ety) ~_ = do+destroy :: forall w c. Destroy w c => Entity -> Proxy c -> System w ()+destroy (Entity ety) _ = do   s :: Storage c <- getStore   liftIO$ explDestroy s ety  -- | Applies a function, if possible. {-# INLINE modify #-}-modify :: forall w c. Has w c => Entity -> (c -> c) -> System w ()+modify :: forall w c. (Get w c, Set w c) => Entity -> (c -> c) -> System w () modify (Entity ety) f = do   s :: Storage c <- getStore   liftIO$ do@@ -109,7 +112,7 @@  -- | Counts the number of entities with a @c@ {-# INLINE count #-}-count :: forall w c. Has w c => c -> System w Int+count :: forall w c. Members w c => c -> System w Int count ~_ = do   s :: Storage c <- getStore   sl <- liftIO$ explMembers s

@@ -1,11 +1,14 @@ {-# LANGUAGE TemplateHaskell #-}  module Apecs.TH-  ( makeWorld, makeWorldNoEC-  )where+  ( makeWorld, makeWorldNoEC, makeWorldAndComponents+  ) where  import           Language.Haskell.TH+import           Control.Monad +import           Apecs.Core+import           Apecs.Stores import           Apecs.Util          (EntityCounter)  genName :: String -> Q Name@@ -14,7 +17,9 @@ -- | Same as 'makeWorld', but has no 'EntityCounter' makeWorldNoEC :: String -> [Name] -> Q [Dec] makeWorldNoEC worldName cTypes = do-  cTypesNames <- mapM (\t -> do rec <- genName "rec"; return (ConT t, rec)) cTypes+  cTypesNames <- forM cTypes $ \t -> do+    rec <- genName "rec"+    return (ConT t, rec)    let wld = mkName worldName       has = mkName "Has"@@ -34,13 +39,25 @@       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 "initStore")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records)+        (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 +makeComponent :: Name -> Q Dec+makeComponent comp = do+  let ct = return$ ConT comp+  head <$> [d| instance Component $ct where type Storage $ct = Map $ct |]+  +-- | Same as makeWorld, but also makes a component instance:+makeWorldAndComponents :: String -> [Name] -> Q [Dec]+makeWorldAndComponents worldName cTypes = do+  wdecls <- makeWorld worldName cTypes+  cdecls <- mapM makeComponent cTypes+  return $ wdecls ++ cdecls+   {-|  > makeWorld "WorldName" [''Component1, ''Component2, ...]@@ -59,4 +76,3 @@ |-} makeWorld :: String -> [Name] -> Q [Dec] makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])-

@@ -5,46 +5,48 @@ import qualified Data.Vector.Unboxed as U import           Language.Haskell.TH --- | Generate tuple instances for the following tuple sizes.-makeInstances :: [Int] -> Q [Dec]-makeInstances is = concat <$> traverse tupleInstances is- {---instance (Component a, Component b) => Component (a,b) where+instance (Component a, Component b) => Component (a, b) where   type Storage (a,b) = (Storage a, Storage b)  instance (Has w a, Has w b) => Has w (a,b) where-  {-# INLINE getStore #-}-  getStore = (,) <$> getStore <*> getStore+  getStore = liftM2 (,) getStore getStore -instance (Store a, Store b) => Store (a,b) where-  type Elem (a, b) = (Elem a, Elem b)-  type SafeRW (a, b) = (SafeRW a, SafeRW b)-  initStore = (,) <$> initStore <*> initStore+type instance Elem (a,b) = (Elem a, Elem b) -  explSet       (sa,sb) ety (wa,wb) = explSet sa ety wa >> explSet sb ety wb-  explDestroy   (sa,sb) ety = explDestroy sa ety >> explDestroy sb ety-  explExists    (sa,sb) ety = explExists sa ety >>= \case False -> return False-                                                          True  -> explExists sb ety-  explMembers   (sa,sb) = explMembers sa >>= U.filterM (explExists sb)-  {-# INLINE explGet #-}-  {-# INLINE explSet #-}-  {-# INLINE explMembers #-}-  {-# INLINE explDestroy #-}-  {-# INLINE explExists #-}+instance (ExplGet a, ExplGet b) => ExplGet (a, b) where+  explExists (sa, sb) ety = liftM2 (&&) (explExists sa ety) (explExists sb ety)+  explGet (sa, sb) ety = liftM2 (,) (explGet sa ety) (explGet sb ety)++instance (ExplSet a, ExplSet b) => ExplSet (a, b) where+  explSet (sa,sb) ety (a,b) = explSet sa ety a >> explSet sb ety b++instance (ExplDestroy a, ExplDestroy b) => ExplDestroy (a, b) where+  explDestroy (sa, sb) ety = explDestroy sa ety >> explDestroy sb ety++instance (ExplMembers a, ExplGet b) => ExplMembers (a, b) where+  explMembers (sa, sb) = explMembers sa >>= U.filterM (explExists sb) --}++-- | Generate tuple instances for the following tuple sizes.+makeInstances :: [Int] -> Q [Dec]+makeInstances is = concat <$> traverse tupleInstances is+ tupleInstances :: Int -> Q [Dec] tupleInstances n = do   let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]]+       tupleUpT :: [Type] -> Type       tupleUpT = foldl AppT (TupleT n)       varTuple :: Type       varTuple = tupleUpT vars+       tupleName :: Name       tupleName = tupleDataName n       tuplE :: Exp       tuplE = ConE tupleName +      -- Component       compN = mkName "Component"       compT var = ConT compN `AppT` var       strgN = mkName "Storage"@@ -54,6 +56,7 @@           TySynEqn [varTuple] (tupleUpT . fmap strgT $ vars)         ] +      -- Has       hasN = mkName "Has"       hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` var       getStoreN = mkName "getStore"@@ -70,12 +73,12 @@       sequenceAll :: [Exp] -> Exp       sequenceAll = foldl1 (\a x -> AppE (AppE (VarE$ mkName ">>") a) x) -      strN  = mkName "Store"-      strsN = mkName "Elem"--      strT  var = ConT strN  `AppT` var-      strsT var = ConT strsN `AppT` var+      -- Elem+      elemN = mkName "Elem"+      elemT var = ConT elemN `AppT` var+      elemI = TySynInstD elemN $ TySynEqn [varTuple] (tupleUpT $ fmap elemT vars) +      -- s, ety, w arguments       sNs = [ mkName $ "s_" ++ show i | i <- [0..n-1]]       sPat = ConP tupleName (VarP <$> sNs)       sEs = VarE <$> sNs@@ -86,12 +89,21 @@       wPat = ConP tupleName (VarP <$> wNs)       wEs = VarE <$> wNs +      getN     = mkName "ExplGet"+      setN     = mkName "ExplSet"+      membersN = mkName "ExplMembers"+      destroyN = mkName "ExplDestroy"++      getT var     = ConT getN `AppT` var+      setT var     = ConT setN `AppT` var+      membersT var = ConT membersN `AppT` var+      destroyT var = ConT destroyN `AppT` var+       explSetN     = mkName "explSet"       explDestroyN = mkName "explDestroy"       explExistsN  = mkName "explExists"       explMembersN = mkName "explMembers"       explGetN     = mkName "explGet"-      initStoreN   = mkName "initStore"        explSetE     = VarE explSetN       explDestroyE = VarE explDestroyN@@ -99,46 +111,46 @@       explMembersE = VarE explMembersN       explGetE     = VarE explGetN -      explSetF sE wE = AppE explSetE sE `AppE` etyE `AppE` wE+      explSetF sE wE  = AppE explSetE sE `AppE` etyE `AppE` wE       explDestroyF sE = AppE explDestroyE sE `AppE` etyE-      explExistsF sE = AppE explExistsE sE+      explExistsF sE  = AppE explExistsE sE       explMembersF sE = AppE explMembersE sE-      explGetF sE = AppE explGetE sE `AppE` etyE+      explGetF sE     = AppE explGetE sE `AppE` etyE -      explExistsAnd va vb = AppE (AppE (VarE '(>>=)) va)-                                 (LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) []-                                           , Match (ConP 'True []) (NormalB vb) []-                                           ])+      explExistsAnd va vb =+        AppE (AppE (VarE '(>>=)) va)+          (LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) []+                    , Match (ConP 'True []) (NormalB vb) []+                    ])        explMembersFold va vb = AppE (VarE '(>>=)) va `AppE` AppE (VarE 'U.filterM) vb -      strI = InstanceD Nothing (strT <$> vars) (strT varTuple)-        [ TySynInstD strsN $ TySynEqn [varTuple] (tupleUpT $ fmap strsT vars)+      getI = InstanceD Nothing (getT <$> vars) (getT varTuple)+        [ FunD explGetN [Clause [sPat, etyPat]+            (NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ]+        , PragmaD$ InlineP explGetN Inline FunLike AllPhases -        , FunD explSetN [Clause [sPat, etyPat, wPat]+        , FunD explExistsN [Clause [sPat, etyPat]+            (NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ]+        , PragmaD$ InlineP explExistsN Inline FunLike AllPhases+        ]++      setI = InstanceD Nothing (setT <$> vars) (setT varTuple)+        [ FunD explSetN [Clause [sPat, etyPat, wPat]             (NormalB$ sequenceAll (zipWith explSetF sEs wEs)) [] ]         , PragmaD$ InlineP explSetN Inline FunLike AllPhases+        ] -        , FunD explDestroyN [Clause [sPat, etyPat]+      destroyI = InstanceD Nothing (destroyT <$> vars) (destroyT varTuple)+        [ FunD explDestroyN [Clause [sPat, etyPat]             (NormalB$ sequenceAll (explDestroyF <$> sEs)) [] ]         , PragmaD$ InlineP explDestroyN Inline FunLike AllPhases--        , FunD explExistsN [Clause [sPat, etyPat]-            (NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ]-        , PragmaD$ InlineP explExistsN Inline FunLike AllPhases+        ] -        , FunD explMembersN [Clause [sPat]+      membersI = InstanceD Nothing (membersT (head vars) : (getT <$> tail vars)) (membersT varTuple)+        [ FunD explMembersN [Clause [sPat]             (NormalB$ foldl explMembersFold (explMembersF (head sEs)) (explExistsF <$> tail sEs)) [] ]         , PragmaD$ InlineP explMembersN Inline FunLike AllPhases--        , FunD explGetN [Clause [sPat, etyPat]-            (NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ]-        , PragmaD$ InlineP explGetN Inline FunLike AllPhases--        , FunD initStoreN [Clause []-            (NormalB$ liftAll tuplE (VarE initStoreN <$ sEs)) [] ]-        , PragmaD$ InlineP initStoreN Inline FunLike AllPhases-         ] -  return [compI, hasI, strI]+  return [compI, hasI, elemI, getI, setI, destroyI, membersI]

@@ -8,7 +8,7 @@  module Apecs.Util (   -- * Utility-  runGC, global, proxy,+  runGC, global,    -- * EntityCounter   EntityCounter, nextEntity, newEntity,@@ -25,6 +25,7 @@ import           Control.Applicative  (liftA2) import           Control.Monad.Reader (liftIO) import           Data.Monoid+import           Data.Proxy import           System.CPUTime import           System.Mem           (performMajorGC) @@ -36,10 +37,6 @@ global :: Entity global = Entity (-1) --- | Convenience proxy value-proxy :: forall t. t-proxy = error "Proxy value"- -- | Component used by newEntity to track the number of issued entities. --   Automatically added to any world created with @makeWorld@ newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Monoid, Eq, Show)@@ -57,7 +54,7 @@ -- | Writes the given components to a new entity, and yields that entity. -- The return value is often ignored. {-# INLINE newEntity #-}-newEntity :: (Store (Storage c), Has w c, Has w EntityCounter)+newEntity :: (Set w c, Get w EntityCounter, Set w EntityCounter)           => c -> System w Entity newEntity c = do ety <- nextEntity                  set ety c