apecs 0.4.1.1 → 0.5.0.0

raw patch · 12 files changed

+366/−209 lines, 12 filesdep +stmdep −asyncPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

Dependencies removed: async

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−0
• README.md +4/−3
• apecs.cabal +8/−5
• bench/Main.hs +19/−11
• src/Apecs.hs +1/−1
• src/Apecs/Concurrent.hs +0/−45
• src/Apecs/Core.hs +83/−44
• src/Apecs/Stores.hs +134/−36
• src/Apecs/System.hs +44/−44
• src/Apecs/TH.hs +3/−2
• src/Apecs/THTuples.hs +9/−6
• src/Apecs/Util.hs +26/−12

@@ -0,0 +1,35 @@+## [Unreleased]+### Changed+- `System w a` is now a synonym for `SystemT w IO a`.+  A variable monad argument allows apecs to be run in monads like ST or STM.+  Most of the library has been rewritten to be as permissive as possible in its monad argument.++## [0.4.1.2]+### Changed+- Either can now be deleted, deleting `Either a b` is the same as deleting `(a,b)`.+- Some were missing their inline pragma's, now they don't++## [0.4.1.1]+### Changed+- Export `Get`, `Set`, `Destroy`, `Members` by default+- Export `cfold`, `cfoldM`, `cfoldM_` by default+- Fix () instance++## [0.4.1.0]+### Added+- `cfold`, `cfoldM`, `cfoldM_`+- `Either` instances and `EitherStore`++### Changed+- Changed MaybeStore implementation to no longer use -1 for missing entities.+- Fixed some outdated documentation.+- Change the `global` void entity to -2, just to be sure it won't conflict if accidentally used in a cache.++## [0.4.0.0]+### Added+- A changelog++### Changed+- `Store` is now split into 5 separate type classes; `ExplInit`, `ExplGet`, `ExplSet`, `ExplDestroy`, and `ExplMembers`.+    This makes it illegal to e.g. iterate over a `Not`.+- phantom arguments are now given as `Proxy` values, re-exported from `Data.Proxy`. This makes phantom arguments explicit and avoids undefined values.

@@ -4,12 +4,13 @@ [![Stackage](https://www.stackage.org/package/apecs/badge/lts?label=Stackage)](https://www.stackage.org/package/apecs)  apecs is an _Entity Component System_ (ECS) framework inspired by [specs](https://github.com/slide-rs/specs) and [Entitas](https://github.com/sschmid/Entitas-CSharp).-The front-end DSL uses a small set of combinators to concisely express game logic, which then translate to fast primitive operations on back-end stores.-Both the DSL and storage framework can easily be extended to meet any performance/expressivity needs.+ECS presents a data-driven approach to game development, that elegantly tackles many of the unique issues of game programming.+The apecs front-end DSL exposes a small number of combinators that allow game logic to be expressive and extremely fast.  #### Links-- [documentation](https://hackage.haskell.org/package/apecs/docs/Apecs.html) - [manual](https://github.com/jonascarpay/apecs/blob/master/prepub.pdf) (see [#19](https://github.com/jonascarpay/apecs/issues/19))+- [tutorial](https://github.com/jonascarpay/apecs/blob/master/examples/Shmup.md)+- [documentation](https://hackage.haskell.org/package/apecs/docs/Apecs.html) - [apecs-physics](https://github.com/jonascarpay/apecs-physics)  #### Performance

@@ -1,5 +1,5 @@ name:                apecs-version:             0.4.1.1+version:             0.5.0.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -8,11 +8,15 @@ category:            Game, Control, Data build-type:          Simple cabal-version:       >=1.10-extra-source-files:  README.md synopsis:            Fast ECS framework for game programming description:-  Apecs is an Entity Component System framework, suitable for high-performance game programming.+  Entity-Component-System frameworks provide a game programming paradigm that tackles many of the shortcomings of a more OO-oriented approach.+  apecs is a type-driven ECS, that leverages strong typing for an expressive DSL that turns into fast game code. +extra-source-files:+  README.md,+  CHANGELOG.md+ source-repository head   type:     git   location: git://github.com/jonascarpay/apecs.git@@ -25,7 +29,6 @@     Apecs.Core,     Apecs.Stores,     Apecs.System,-    Apecs.Concurrent,     Apecs.TH,     Apecs.Util   other-modules:@@ -37,7 +40,7 @@     containers,     mtl,     template-haskell,-    async,+    stm,     vector   ghc-options:     -Wall

@@ -1,14 +1,20 @@-{-# LANGUAGE Strict, ScopedTypeVariables, DataKinds, TypeFamilies, MultiParamTypeClasses, TypeOperators #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE Strict                #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} -import Criterion-import Criterion.Types-import qualified Criterion.Main as C-import Control.Monad-import Linear+import           Control.Monad+import           Criterion+import qualified Criterion.Main  as C+import           Criterion.Types+import           Linear -import Apecs+import           Apecs  -- pos_vel newtype ECSPos = ECSPos (V2 Float) deriving (Eq, Show)@@ -20,8 +26,9 @@ makeWorld "PosVel" [''ECSPos, ''ECSVel]  posVelInit :: System PosVel ()-posVelInit = do replicateM_ 1000 (newEntity (ECSPos 0, ECSVel 1))-                replicateM_ 9000 (newEntity (ECSPos 0))+posVelInit = do+  mapM_ (`set` ECSPos 0) [0..9999]+  mapM_ (`set` ECSVel 1) [0..999]  posVelStep :: System PosVel () posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v)@@ -33,3 +40,4 @@     , bench "step" $ whnfIO (initPosVel >>= runSystem (posVelInit >> posVelStep))     ]   ]+

@@ -5,7 +5,7 @@ module Apecs (   module Data.Proxy,   -- * Core types-    System(..), Component(..), Entity(..), Has(..), Not(..),+    SystemT(..), System, Component(..), Entity(..), Has(..), Not(..),     Get, Set, Destroy, Members,    -- * Stores

@@ -1,45 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}--module Apecs.Concurrent (-  concurrently,-  pmap,-) where--import qualified Control.Concurrent.Async as A-import           Control.Monad.Reader-import qualified Data.Vector.Unboxed      as U--import           Apecs.System-import           Apecs.Core---- | Executes a list of systems concurrently, and blocks until all have finished.---   Provides zero protection against race conditions and other hazards, so use with caution.-concurrently :: [System w ()] -> System w ()-concurrently ss = do w <- System ask-                     liftIO . A.mapConcurrently_ (runWith w) $ ss---- | Parallel version of @cmap@. -{-# INLINE pmap #-}-pmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy)-     => Int -- ^ Entities per thread-     -> (cx -> cy) -> System w ()-pmap grainSize f =-  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--  where-    parallelize grainSize sys vec-      | U.length vec <= grainSize = U.mapM_ sys vec-      | otherwise = A.mapConcurrently_ (U.mapM_ sys) vecSplits-        where-          vecSplits = go vec-          go vec-            | U.null vec = []-            | otherwise = let (h,t) = U.splitAt grainSize vec in h : go t-

@@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-} @@ -18,26 +19,29 @@  -- | An Entity is just an integer, used to index into a component store. --   In general, use @newEntity@, @cmap@, and component tags instead of manipulating these directly.---   +-- --   For performance reasons, negative values like (-1) are reserved for stores to represent special values, so avoid using these.-newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show)+newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show, Enum) --- | A System is a newtype around `ReaderT w IO a`, where `w` is the game world variable.+-- | A SystemT is a newtype around `ReaderT w IO a`, where `w` is the game world variable. --   Systems mainly serve to---   +-- --   * Lift side effects into the IO Monad. -- --   * Allow type-based lookup of a component's store through @getStore@.-newtype System w a = System {unSystem :: ReaderT w IO a} deriving (Functor, Monad, Applicative, MonadIO)+newtype SystemT w m a = SystemT {unSystem :: ReaderT w m a} deriving (Functor, Monad, Applicative, MonadTrans, MonadIO)+type System w a = SystemT w IO a +deriving instance Monad m => MonadReader w (SystemT w m)+ -- | A component is defined by specifying how it is stored. --   The constraint ensures that stores and components are mapped one-to-one. class (Elem (Storage c) ~ c) => Component c where   type Storage c --- | @Has w c@ means that world @w@ can produce a @Storage c@.-class Component c => Has w c where-  getStore :: System w (Storage c)+-- | @Has w m c@ means that world @w@ can produce a @Storage c@.+class (Monad m, Component c) => Has w m c where+  getStore :: SystemT w m (Storage c)  -- | The type of components stored by a store, e.g. @Elem (Map c) = c@. type family Elem s@@ -50,50 +54,56 @@  -- | Stores that we can read using @explGet@ and @explExists@. --   For some entity @e@, @eplGet s e@ is only guaranteed to be safe if @explExists s e@ returns @True@.-class ExplGet s where+class Monad m => ExplGet m s where   -- | Reads a component from the store. What happens if the component does not exist is left undefined, and might not necessarily crash.-  explGet :: s -> Int -> IO (Elem s)+  explGet :: s -> Int -> m (Elem s)   -- | Returns whether there is a component for the given index.-  explExists :: s -> Int -> IO Bool+  explExists :: s -> Int -> m Bool  -- | Stores that can be written.-class ExplSet s where+class Monad m => ExplSet m s where   -- | Writes a component to the store.-  explSet :: s -> Int -> Elem s -> IO ()+  explSet :: s -> Int -> Elem s -> m ()  -- | Stores that components can be removed from.-class ExplDestroy s where+class Monad m => ExplDestroy m s where   -- | Destroys the component for a given index.-  explDestroy :: s -> Int -> IO ()+  explDestroy :: s -> Int -> m ()  -- | Stores that we can request a list of member entities for.-class ExplMembers s where+class Monad m => ExplMembers m s where   -- | Returns an unboxed vector of member indices-  explMembers :: s -> IO (U.Vector Int)+  explMembers :: s -> m (U.Vector Int) -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))+type Get     w m c = (Has w m c, ExplGet     m (Storage c))+type Set     w m c = (Has w m c, ExplSet     m (Storage c))+type Members w m c = (Has w m c, ExplMembers m (Storage c))+type Destroy w m c = (Has w m c, ExplDestroy m (Storage c))  -- | Identity component/store. @Identity c@ is equivalent to @c@, so using it is mostly useless. instance Component c => Component (Identity c) where   type Storage (Identity c) = Identity (Storage c) -instance Has w c => Has w (Identity c) where+instance Has w m c => Has w m (Identity c) where+  {-# INLINE getStore #-}   getStore = Identity <$> getStore  type instance Elem (Identity s) = Identity (Elem s) -instance ExplGet s => ExplGet (Identity s) where+instance ExplGet m s => ExplGet m (Identity s) where+  {-# INLINE explGet #-}   explGet (Identity s) e = Identity <$> explGet s e+  {-# INLINE explExists  #-}   explExists  (Identity s) = explExists s -instance ExplSet s => ExplSet (Identity s) where+instance ExplSet m s => ExplSet m (Identity s) where+  {-# INLINE explSet #-}   explSet (Identity s) e (Identity x) = explSet s e x-instance ExplMembers s => ExplMembers (Identity s) where+instance ExplMembers m s => ExplMembers m (Identity s) where+  {-# INLINE explMembers #-}   explMembers (Identity s) = explMembers s-instance ExplDestroy s => ExplDestroy (Identity s) where+instance ExplDestroy m s => ExplDestroy m (Identity s) where+  {-# INLINE explDestroy #-}   explDestroy (Identity s) = explDestroy s  T.makeInstances [2..8]@@ -109,16 +119,20 @@ instance Component c => Component (Not c) where   type Storage (Not c) = NotStore (Storage c) -instance (Has w c) => Has w (Not c) where+instance (Has w m c) => Has w m (Not c) where+  {-# INLINE getStore #-}   getStore = NotStore <$> getStore  type instance Elem (NotStore s) = Not (Elem s) -instance ExplGet s => ExplGet (NotStore s) where+instance ExplGet m s => ExplGet m (NotStore s) where+  {-# INLINE explGet #-}   explGet _ _ = return Not+  {-# INLINE explExists #-}   explExists (NotStore sa) ety = not <$> explExists sa ety -instance ExplDestroy s => ExplSet (NotStore s) where+instance ExplDestroy m s => ExplSet m (NotStore s) where+  {-# INLINE explSet #-}   explSet (NotStore sa) ety _ = explDestroy sa ety  -- | Pseudostore used to produce values of type @Maybe a@.@@ -128,19 +142,22 @@ instance Component c => Component (Maybe c) where   type Storage (Maybe c) = MaybeStore (Storage c) -instance (Has w c) => Has w (Maybe c) where+instance (Has w m c) => Has w m (Maybe c) where+  {-# INLINE getStore #-}   getStore = MaybeStore <$> getStore  type instance Elem (MaybeStore s) = Maybe (Elem s) -instance ExplGet s => ExplGet (MaybeStore s) where+instance ExplGet m s => ExplGet m (MaybeStore s) where+  {-# INLINE explGet #-}   explGet (MaybeStore sa) ety = do     e <- explExists sa ety     if e then Just <$> explGet sa ety          else return Nothing   explExists _ _ = return True -instance (ExplDestroy s, ExplSet s) => ExplSet (MaybeStore s) where+instance (ExplDestroy m s, ExplSet m s) => ExplSet m (MaybeStore s) where+  {-# INLINE explSet #-}   explSet (MaybeStore sa) ety Nothing  = explDestroy sa ety   explSet (MaybeStore sa) ety (Just x) = explSet sa ety x @@ -152,36 +169,51 @@ instance (Component ca, Component cb) => Component (Either ca cb) where   type Storage (Either ca cb) = EitherStore (Storage ca) (Storage cb) -instance (Has w ca, Has w cb) => Has w (Either ca cb) where+instance (Has w m ca, Has w m cb) => Has w m (Either ca cb) where+  {-# INLINE getStore #-}   getStore = EitherStore <$> getStore <*> getStore  type instance Elem (EitherStore sa sb) = Either (Elem sa) (Elem sb) -instance (ExplGet sa, ExplGet sb) => ExplGet (EitherStore sa sb) where+instance (ExplGet m sa, ExplGet m sb) => ExplGet m (EitherStore sa sb) where+  {-# INLINE explGet #-}   explGet (EitherStore sa sb) ety = do     e <- explExists sb ety     if e then Right <$> explGet sb ety          else Left <$> explGet sa ety+  {-# INLINE explExists #-}   explExists (EitherStore sa sb) ety = do     e <- explExists sb ety     if e then return True          else explExists sa ety -instance (ExplSet sa, ExplSet sb) => ExplSet (EitherStore sa sb) where+instance (ExplSet m sa, ExplSet m sb) => ExplSet m (EitherStore sa sb) where+  {-# INLINE explSet #-}   explSet (EitherStore _ sb) ety (Right b) = explSet sb ety b   explSet (EitherStore sa _) ety (Left a)  = explSet sa ety a -instance Has w () where+instance (ExplDestroy m sa, ExplDestroy m sb)+       => ExplDestroy m (EitherStore sa sb) where+  {-# INLINE explDestroy #-}+  explDestroy (EitherStore sa sb) ety =+    explDestroy sa ety >> explDestroy sb ety++instance Monad m => Has w m () where+  {-# INLINE getStore #-}   getStore = return () instance Component () where   type Storage () = () type instance Elem () = ()-instance ExplGet () where+instance Monad m => ExplGet m () where+  {-# INLINE explExists #-}   explExists _ _ = return True+  {-# INLINE explGet #-}   explGet _ _ = return ()-instance ExplSet () where+instance Monad m => ExplSet m () where+  {-# INLINE explSet #-}   explSet _ _ _ = return ()-instance ExplDestroy () where+instance Monad m => ExplDestroy m () where+  {-# INLINE explDestroy #-}   explDestroy _ _ = return ()  -- | Pseudocomponent that functions normally for @explExists@ and @explMembers@, but always return @Filter@ for @explGet@.@@ -196,16 +228,20 @@ instance Component c => Component (Filter c) where   type Storage (Filter c) = FilterStore (Storage c) -instance Has w c => Has w (Filter c) where+instance Has w m c => Has w m (Filter c) where+  {-# INLINE getStore #-}   getStore = FilterStore <$> getStore  type instance Elem (FilterStore s) = Filter (Elem s) -instance ExplGet s => ExplGet (FilterStore s) where+instance ExplGet m s => ExplGet m (FilterStore s) where+  {-# INLINE explGet #-}   explGet _ _ = return Filter+  {-# INLINE explExists #-}   explExists (FilterStore s) ety = explExists s ety -instance ExplMembers s => ExplMembers (FilterStore s) where+instance ExplMembers m s => ExplMembers m (FilterStore s) where+  {-# INLINE explMembers #-}   explMembers (FilterStore s) = explMembers s  -- | Pseudostore used to produce components of type 'Entity'.@@ -215,10 +251,13 @@ instance Component Entity where   type Storage Entity = EntityStore -instance (Has w Entity) where+instance Monad m => Has w m Entity where+  {-# INLINE getStore #-}   getStore = return EntityStore  type instance Elem EntityStore = Entity-instance ExplGet EntityStore where+instance Monad m => ExplGet m EntityStore where+  {-# INLINE explGet #-}   explGet _ ety = return $ Entity ety+  {-# INLINE explExists #-}   explExists _ _ = return True

@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE Strict                #-}@@ -13,8 +13,12 @@   ( Map, Cache, Unique,     Global,     Cachable,+    RawGlobal,   ) where +import           Control.Concurrent.STM      as S+import           Control.Concurrent.STM.TVar as S+ import           Control.Monad.Reader import qualified Data.IntMap.Strict          as M import           Data.IORef@@ -27,80 +31,168 @@  import           Apecs.Core --- | A map based on @Data.Intmap.Strict@. O(log(n)) for most operations.-newtype Map c = Map (IORef (M.IntMap c))+-- | A map based on @Data.IntMap.Strict@. O(log(n)) for most operations.+newtype Map c = Map (TVar (M.IntMap (TVar c)))  type instance Elem (Map c) = c instance ExplInit (Map c) where-  explInit = Map <$> newIORef mempty+  explInit = Map <$> newTVarIO 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+instance ExplGet IO (Map c) where+  explExists (Map ref) ety = M.member ety <$> readTVarIO ref+  explGet    (Map ref) ety =+    readTVarIO ref >>= readTVarIO . fromJust . M.lookup ety   {-# INLINE explExists #-}   {-# INLINE explGet #-} -instance ExplSet (Map c) where+instance ExplSet IO (Map c) where   {-# INLINE explSet #-}-  explSet (Map ref) ety x = modifyIORef' ref $ M.insert ety x+  explSet (Map ref) ety x = do+    m <- readTVarIO ref+    case M.lookup ety m of+      Nothing -> do+        rInsert <- newTVarIO x+        atomically . writeTVar ref $ M.insert ety rInsert m+      Just cref -> atomically $ writeTVar cref x -instance ExplDestroy (Map c) where+instance ExplDestroy IO (Map c) where   {-# INLINE explDestroy #-}-  explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety)+  explDestroy (Map ref) ety =+    readTVarIO ref >>= atomically . writeTVar ref . M.delete ety -instance ExplMembers (Map c) where+instance ExplMembers IO (Map c) where   {-# INLINE explMembers #-}-  explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref+  explMembers (Map ref) = U.fromList . M.keys <$> readTVarIO ref +instance ExplGet STM (Map c) where+  explExists (Map ref) ety = M.member ety <$> readTVar ref+  explGet    (Map ref) ety =+    readTVar ref >>= readTVar . fromJust . M.lookup ety+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}++instance ExplSet STM (Map c) where+  {-# INLINE explSet #-}+  explSet (Map ref) ety x = do+    m <- readTVar ref+    case M.lookup ety m of+      Nothing -> do+        rInsert <- newTVar x+        writeTVar ref $ M.insert ety rInsert m+      Just cref -> writeTVar cref x++instance ExplDestroy STM (Map c) where+  {-# INLINE explDestroy #-}+  explDestroy (Map ref) ety = do+    m <- readTVar ref+    writeTVar ref $ M.delete ety m++instance ExplMembers STM (Map c) where+  {-# INLINE explMembers #-}+  explMembers (Map ref) = U.fromList . M.keys <$> readTVar 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 (Maybe (Int, c)))+newtype Unique c = Unique (TVar (Maybe (Int, c))) type instance Elem (Unique c) = c instance ExplInit (Unique c) where-  explInit = Unique <$> newIORef Nothing+  explInit = Unique <$> newTVarIO Nothing -instance ExplGet (Unique c) where+instance ExplGet IO (Unique c) where   {-# INLINE explGet #-}-  explGet (Unique ref) _ = flip fmap (readIORef ref) $ \case+  explGet (Unique ref) _ = flip fmap (readTVarIO ref) $ \case     Nothing -> error "Reading empty Unique"     Just (_, c)  -> c   {-# INLINE explExists #-}-  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readIORef ref+  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVarIO ref -instance ExplSet (Unique c) where+instance ExplSet IO (Unique c) where   {-# INLINE explSet #-}-  explSet (Unique ref) ety c = writeIORef ref (Just (ety, c))+  explSet (Unique ref) ety c = atomically $ writeTVar ref (Just (ety, c)) -instance ExplDestroy (Unique c) where+instance ExplDestroy IO (Unique c) where   {-# INLINE explDestroy #-}-  explDestroy (Unique ref) ety = do-    readIORef ref >>= mapM_ (flip when (writeIORef ref Nothing) . (==ety) . fst)+  explDestroy (Unique ref) ety = readTVarIO ref >>=+    mapM_ (flip when (atomically $ writeTVar ref Nothing) . (==ety) . fst) -instance ExplMembers (Unique c) where+instance ExplMembers IO (Unique c) where   {-# INLINE explMembers #-}-  explMembers (Unique ref) = flip fmap (readIORef ref) $ \case+  explMembers (Unique ref) = flip fmap (readTVarIO ref) $ \case     Nothing -> mempty     Just (ety, _) -> U.singleton ety +instance ExplGet STM (Unique c) where+  {-# INLINE explGet #-}+  explGet (Unique ref) _ = flip fmap (readTVar ref) $ \case+    Nothing -> error "Reading empty Unique"+    Just (_, c)  -> c+  {-# INLINE explExists #-}+  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVar ref++instance ExplSet STM (Unique c) where+  {-# INLINE explSet #-}+  explSet (Unique ref) ety c = writeTVar ref (Just (ety, c))++instance ExplDestroy STM (Unique c) where+  {-# INLINE explDestroy #-}+  explDestroy (Unique ref) ety = readTVar ref >>=+    mapM_ (flip when (writeTVar ref Nothing) . (==ety) . fst)++instance ExplMembers STM (Unique c) where+  {-# INLINE explMembers #-}+  explMembers (Unique ref) = flip fmap (readTVar ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> U.singleton ety+ -- | A Global contains exactly one component. --   The initial value is 'mempty' from the component's 'Monoid' instance.+-- --   When operating on a global, any entity arguments are ignored. --   For example, we can get a global component with @get 0@ or @get 1@ or even @get undefined@.-newtype Global c = Global (IORef c)+newtype Global c = Global (TVar c) type instance Elem (Global c) = c instance Monoid c => ExplInit (Global c) where-  explInit = Global <$> newIORef mempty+  {-# INLINE explInit #-}+  explInit = Global <$> newTVarIO mempty -instance ExplGet (Global c) where-  explGet (Global ref) _ = readIORef ref+instance ExplGet IO (Global c) where+  {-# INLINE explGet #-}+  explGet (Global ref) _ = readTVarIO ref+  {-# INLINE explExists #-}   explExists _ _ = return True -instance ExplSet (Global c) where-  explSet (Global ref) _ c = writeIORef ref c+instance ExplSet IO (Global c) where+  {-# INLINE explSet #-}+  explSet (Global ref) _ c = atomically $ writeTVar ref c +instance ExplGet STM (Global c) where+  {-# INLINE explGet #-}+  explGet (Global ref) _ = readTVar ref+  {-# INLINE explExists #-}+  explExists _ _ = return True++instance ExplSet STM (Global c) where+  {-# INLINE explSet #-}+  explSet (Global ref) _ c = writeTVar ref c++newtype RawGlobal c = RawGlobal (IORef c)+type instance Elem (RawGlobal c) = c+instance Monoid c => ExplInit (RawGlobal c) where+  {-# INLINE explInit #-}+  explInit = RawGlobal <$> newIORef mempty++instance ExplGet IO (RawGlobal c) where+  {-# INLINE explGet #-}+  explGet (RawGlobal ref) _ = readIORef ref+  {-# INLINE explExists #-}+  explExists _ _ = return True++instance ExplSet IO (RawGlobal c) where+  {-# INLINE explSet #-}+  explSet (RawGlobal ref) _ c = writeIORef ref c+ -- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached.---   An example of a store that cannot be cached is 'Unique'. class Cachable s instance Cachable (Map s) instance (KnownNat n, Cachable s) => Cachable (Cache n s)@@ -123,6 +215,7 @@ type instance Elem (Cache n s) = Elem s  instance (ExplInit s, KnownNat n, Cachable s) => ExplInit (Cache n s) where+  {-# INLINE explInit #-}   explInit = do     let n = fromIntegral$ natVal (Proxy @n)     tags <- UM.replicate n (-1)@@ -130,7 +223,8 @@     child <- explInit     return (Cache n tags cache child) -instance ExplGet s => ExplGet (Cache n s) where+instance ExplGet IO s => ExplGet IO (Cache n s) where+  {-# INLINE explGet #-}   explGet (Cache n tags cache s) ety = do     let index = ety `rem` n     tag <- UM.unsafeRead tags index@@ -138,11 +232,13 @@        then VM.unsafeRead cache index        else explGet 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 -instance ExplSet s => ExplSet (Cache n s) where+instance ExplSet IO s => ExplSet IO (Cache n s) where+  {-# INLINE explSet #-}   explSet (Cache n tags cache s) ety x = do     let index = ety `rem` n     tag <- UM.unsafeRead tags index@@ -152,7 +248,8 @@     UM.unsafeWrite tags  index ety     VM.unsafeWrite cache index x -instance ExplDestroy s => ExplDestroy (Cache n s) where+instance ExplDestroy IO s => ExplDestroy IO (Cache n s) where+  {-# INLINE explDestroy #-}   explDestroy (Cache n tags cache s) ety = do     let index = ety `rem` n     tag <- UM.unsafeRead tags (ety `rem` n)@@ -162,7 +259,8 @@          VM.unsafeWrite cache index cacheMiss        else explDestroy s ety -instance ExplMembers s => ExplMembers (Cache n s) where+instance ExplMembers IO s => ExplMembers IO (Cache n s) where+  {-# INLINE explMembers #-}   explMembers (Cache _ tags _ s) = do     cached <- U.filter (/= (-1)) <$> U.freeze tags     stored <- explMembers s

@@ -14,45 +14,45 @@  -- | Run a system with a game world {-# INLINE runSystem #-}-runSystem :: System w a -> w -> IO a+runSystem :: SystemT w m a -> w -> m a runSystem sys = runReaderT (unSystem sys)  -- | Run a system with a game world {-# INLINE runWith #-}-runWith :: w -> System w a -> IO a+runWith :: w -> SystemT w m a -> m a runWith = flip runSystem  {-# INLINE get #-}-get :: forall w c. Get w c => Entity -> System w c+get :: forall w m c. Get w m c => Entity -> SystemT w m c get (Entity ety) = do   s :: Storage c <- getStore-  liftIO$ explGet s ety+  lift$ explGet s ety  -- | Writes a component to a given entity. Will overwrite existing components.---   The type was originally 'Entity c -> c -> System w ()', but is relaxed to 'Entity e'+--   The type was originally 'Entity c -> c -> SystemT w m ()', but is relaxed to 'Entity e' --   so you don't always have to write 'set . cast' {-# INLINE set #-}-set :: forall w c. Set w c => Entity -> c -> System w ()+set :: forall w m c. Set w m c => Entity -> c -> SystemT w m () set (Entity ety) x = do   s :: Storage c <- getStore-  liftIO$ explSet s ety x+  lift$ explSet s ety x  -- | 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. Get w c => Entity -> Proxy c -> System w Bool+exists :: forall w m c. Get w m c => Entity -> Proxy c -> SystemT w m Bool exists (Entity ety) _ = do   s :: Storage c <- getStore-  liftIO$ explExists s ety+  lift$ explExists s ety  -- | Maps a function over all entities with a @cx@, and writes their @cy@. {-# INLINE cmap #-}-cmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy)-     => (cx -> cy) -> System w ()+cmap :: forall w m cx cy. (Get w m cx, Members w m cx, Set w m cy)+     => (cx -> cy) -> SystemT w m () cmap f = do   sx :: Storage cx <- getStore   sy :: Storage cy <- getStore-  liftIO$ do+  lift$ do     sl <- explMembers sx     U.forM_ sl $ \ e -> do       r <- explGet sx e@@ -60,89 +60,89 @@  -- | Monadically iterates over all entites with a @cx@, and writes their @cy@. {-# INLINE cmapM #-}-cmapM :: forall w cx cy. (Get w cx, Set w cy, Members w cx)-      => (cx -> System w cy) -> System w ()+cmapM :: forall w m cx cy. (Get w m cx, Set w m cy, Members w m cx)+      => (cx -> SystemT w m cy) -> SystemT w m () cmapM sys = do   sx :: Storage cx <- getStore   sy :: Storage cy <- getStore-  sl <- liftIO$ explMembers sx+  sl <- lift$ explMembers sx   U.forM_ sl $ \ e -> do-    x <- liftIO$ explGet sx e+    x <- lift$ explGet sx e     y <- sys x-    liftIO$ explSet sy e y+    lift$ explSet sy e y  -- | Monadically iterates over all entites with a @cx@ {-# INLINE cmapM_ #-}-cmapM_ :: forall w c a. (Get w c, Members w c)-       => (c -> System w a) -> System w ()+cmapM_ :: forall w m c a. (Get w m c, Members w m c)+       => (c -> SystemT w m a) -> SystemT w m () cmapM_ sys = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s+  sl <- lift$ explMembers s   U.forM_ sl $ \ ety -> do-    x <- liftIO$ explGet s ety+    x <- lift$ explGet s ety     sys x  -- | Fold over the game world; for example, @cfold max (minBound :: Foo)@ will find the maximum value of @Foo@. --   Strict in the accumulator. {-# INLINE cfold #-}-cfold :: forall w c a. (Members w c, Get w c)-      => (a -> c -> a) -> a -> System w a+cfold :: forall w m c a. (Members w m c, Get w m c)+      => (a -> c -> a) -> a -> SystemT w m a cfold f a0 = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s-  liftIO$ U.foldM' (\a e -> f a <$> explGet s e) a0 sl+  sl <- lift$ explMembers s+  lift$ U.foldM' (\a e -> f a <$> explGet s e) a0 sl  -- | Monadically fold over the game world. --   Strict in the accumulator. {-# INLINE cfoldM #-}-cfoldM :: forall w c a. (Members w c, Get w c)-       => (a -> c -> System w a) -> a -> System w a+cfoldM :: forall w m c a. (Members w m c, Get w m c)+       => (a -> c -> SystemT w m a) -> a -> SystemT w m a cfoldM sys a0 = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s-  U.foldM' (\a e -> liftIO (explGet s e) >>= sys a) a0 sl+  sl <- lift$ explMembers s+  U.foldM' (\a e -> lift (explGet s e) >>= sys a) a0 sl  -- | Monadically fold over the game world. --   Strict in the accumulator. {-# INLINE cfoldM_ #-}-cfoldM_ :: forall w c a. (Members w c, Get w c)-       => (a -> c -> System w a) -> a -> System w ()+cfoldM_ :: forall w m c a. (Members w m c, Get w m c)+       => (a -> c -> SystemT w m a) -> a -> SystemT w m () cfoldM_ sys a0 = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s-  U.foldM'_ (\a e -> liftIO (explGet s e) >>= sys a) a0 sl+  sl <- lift$ explMembers s+  U.foldM'_ (\a e -> lift (explGet s e) >>= sys a) a0 sl  -- | Get all components @c@. --   Call as @[(c,Entity)]@ to also read the entity index. {-# INLINE getAll #-}-getAll :: forall w c. (Get w c, Members w c)-      => System w [c]+getAll :: forall w m c. (Get w m c, Members w m c)+      => SystemT w m [c] getAll = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s-  forM (U.toList sl) $ liftIO . explGet s+  sl <- lift$ explMembers s+  forM (U.toList sl) $ lift . explGet s  -- | 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. Destroy w c => Entity -> Proxy c -> System w ()-destroy (Entity ety) _ = do+destroy :: forall w m c. Destroy w m c => Entity -> Proxy c -> SystemT w m ()+destroy (Entity ety) ~_ = do   s :: Storage c <- getStore-  liftIO$ explDestroy s ety+  lift$ explDestroy s ety  -- | Applies a function, if possible. {-# INLINE modify #-}-modify :: forall w c. (Get w c, Set w c) => Entity -> (c -> c) -> System w ()+modify :: forall w m c. (Get w m c, Set w m c) => Entity -> (c -> c) -> SystemT w m () modify (Entity ety) f = do   s :: Storage c <- getStore-  liftIO$ do+  lift$ do     x <- explGet s ety     explSet s ety (f x)  -- | Counts the number of entities with a @c@ {-# INLINE count #-}-count :: forall w c. Members w c => c -> System w Int+count :: forall w m c. Members w m c => Proxy c -> SystemT w m Int count ~_ = do   s :: Storage c <- getStore-  sl <- liftIO$ explMembers s+  sl <- lift$ explMembers s   return $ U.length sl

@@ -23,14 +23,15 @@    let wld = mkName worldName       has = mkName "Has"-      sys = mkName "System"+      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 has `AppT` ConT wld) `AppT` t)+        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))             [] ]

@@ -35,9 +35,12 @@ tupleInstances :: Int -> Q [Dec] tupleInstances n = do   let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]]+      m = VarT $ mkName "m" +      -- [''a,''b] -> ''(a,b)       tupleUpT :: [Type] -> Type       tupleUpT = foldl AppT (TupleT n)+      -- ''(t_0, t_1, .. )       varTuple :: Type       varTuple = tupleUpT vars @@ -58,14 +61,14 @@        -- Has       hasN = mkName "Has"-      hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` var+      hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` m `AppT` var       getStoreN = mkName "getStore"       getStoreE = VarE getStoreN       apN = mkName "<*>"       apE = VarE apN       hasI = InstanceD Nothing (hasT <$> vars) (hasT varTuple)         [ FunD getStoreN-          [Clause [] (NormalB$ liftAll tuplE (replicate n $ getStoreE )) [] ]+          [Clause [] (NormalB$ liftAll tuplE (replicate n getStoreE )) [] ]         , PragmaD$ InlineP getStoreN Inline FunLike AllPhases         ] @@ -94,10 +97,10 @@       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+      getT     s = ConT getN     `AppT` m `AppT` s+      setT     s = ConT setN     `AppT` m `AppT` s+      membersT s = ConT membersN `AppT` m `AppT` s+      destroyT s = ConT destroyN `AppT` m `AppT` s        explSetN     = mkName "explSet"       explDestroyN = mkName "explDestroy"

@@ -20,21 +20,26 @@   -- * Timing   timeSystem, timeSystem_, +  -- * Concurrency+  forkSys, atomically, sleep+   ) where -import           Control.Applicative  (liftA2)-import           Control.Monad.Reader (liftIO)+import qualified Control.Concurrent     as C+import qualified Control.Concurrent.STM as C+import           System.CPUTime++import           Control.Applicative    (liftA2)+import           Control.Monad.Reader import           Data.Monoid import           Data.Semigroup-import           System.CPUTime-import           System.Mem           (performMajorGC)+import           System.Mem             (performMajorGC) +import           Apecs.Core import           Apecs.Stores import           Apecs.System-import           Apecs.Core  -- | Convenience entity, for use in places where the entity value does not matter, i.e. a global store.--- Its value is -2, to avoid potential conflicts with caches, which reserve -1. global :: Entity global = Entity (-2) @@ -47,7 +52,7 @@  -- | Bumps the EntityCounter and yields its value {-# INLINE nextEntity #-}-nextEntity :: Has w EntityCounter => System w Entity+nextEntity :: (Get w m EntityCounter, Set w m EntityCounter) => SystemT w m Entity nextEntity = do EntityCounter n <- get global                 set global (EntityCounter $ n+1)                 return (Entity . getSum $ n)@@ -55,15 +60,15 @@ -- | Writes the given components to a new entity, and yields that entity. -- The return value is often ignored. {-# INLINE newEntity #-}-newEntity :: (Set w c, Get w EntityCounter, Set w EntityCounter)-          => c -> System w Entity+newEntity :: (Set w m c, Get w m EntityCounter, Set w m EntityCounter)+          => c -> SystemT w m Entity newEntity c = do ety <- nextEntity                  set ety c                  return ety  -- | Explicitly invoke the garbage collector runGC :: System w ()-runGC = liftIO performMajorGC+runGC = lift performMajorGC  -- $hash -- The following are helper functions for spatial hashing.@@ -119,11 +124,20 @@ -- | Runs a system and gives its execution time in seconds timeSystem :: System w a -> System w (Double, a) timeSystem sys = do-  s <- liftIO getCPUTime+  s <- lift getCPUTime   a <- sys-  t <- liftIO getCPUTime+  t <- lift getCPUTime   return (fromIntegral (t-s)/1e12, a)  -- | Runs a system, discards its output, and gives its execution time in seconds timeSystem_ :: System w a -> System w Double timeSystem_ = fmap fst . timeSystem++forkSys :: System w () -> System w C.ThreadId+forkSys sys = ask >>= liftIO . C.forkIO . runSystem sys++atomically :: SystemT w C.STM () -> SystemT w IO ()+atomically sys = ask >>= liftIO . C.atomically . runSystem sys++sleep :: Int -> System w ()+sleep = liftIO . C.threadDelay