WIP remove MonadIO requirement

apecs/bench/Main.hs

@@ -25,19 +25,19 @@ instance Component ECSVel where type Storage ECSVel = Cache 1000 (Map ECSVel)
 
 makeWorld "PosVel" [''ECSPos, ''ECSVel]
 
-posVelInit :: System PosVel ()
+posVelInit :: SystemT PosVel IO ()
 posVelInit = do
   replicateM_ 1000 $ newEntity (ECSPos 0, ECSVel 1)
   replicateM_ 9000 $ newEntity (ECSPos 0)
 
-posVelStep :: System PosVel ()
+posVelStep :: SystemT PosVel IO ()
 posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v)
 
 main :: IO ()
 main = C.defaultMainWith (C.defaultConfig {timeLimit = 10})
   [ bgroup "pos_vel"
-    [ bench "init" $ whnfIO (initPosVel >>= runSystem posVelInit)
-    , bench "step" $ whnfIO (initPosVel >>= runSystem (posVelInit >> posVelStep))
+    [ bench "init" $ whnfIO (initPosVelM >>= (fmap fst . runSystemM posVelInit))
+    , bench "step" $ whnfIO (initPosVelM >>= (fmap fst . runSystemM (posVelInit >> posVelStep)))
     ]
   ]
 

apecs/src/Apecs.hs

@@ -20,15 +20,16 @@ module Apecs (
 
   -- * Other
     runSystem, runWith,
+    runSystemM, runWithM,
     runGC, EntityCounter, newEntity, newEntity_, global,
     makeWorld, makeWorldAndComponents,
 
   -- * Re-exports
-    asks, ask, liftIO, lift, Proxy (..)
+    asks, ask, liftIO, S.lift, Proxy (..)
 ) where
 
 import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Reader (ask, asks, lift)
+import qualified Control.Monad.State as S
 import           Data.Proxy
 
 import           Apecs.Components
@@ -37,3 +38,9 @@ import           Apecs.Stores
 import           Apecs.System
 import           Apecs.TH
 import           Apecs.Util
+
+ask :: S.MonadState a f => f a
+ask = S.get
+
+asks :: S.MonadState a f => (a -> b) -> f b
+asks f = f <$> S.get

apecs/src/Apecs/Components.hs

@@ -17,6 +17,7 @@ import Data.Functor.Identity
 
 import           Apecs.Core
 import qualified Apecs.THTuples as T
+import Data.Coerce (coerce)
 
 -- | Identity component. @Identity c@ is equivalent to @c@, so mostly useless.
 instance Component c => Component (Identity c) where
@@ -25,6 +26,7 @@ instance Component c => Component (Identity c) where
 instance Has w m c => Has w m (Identity c) where
   {-# INLINE getStore #-}
   getStore = Identity <$> getStore
+  setStore (Identity s) = setStore s
 
 type instance Elem (Identity s) = Identity (Elem s)
 
@@ -36,13 +38,13 @@ instance ExplGet m s => ExplGet m (Identity s) where
 
 instance ExplSet m s => ExplSet m (Identity s) where
   {-# INLINE explSet #-}
-  explSet (Identity s) e (Identity x) = explSet s e x
+  explSet (Identity s) e (Identity x) = coerce <$> explSet s e x
 instance ExplMembers m s => ExplMembers m (Identity s) where
   {-# INLINE explMembers #-}
   explMembers (Identity s) = explMembers s
 instance ExplDestroy m s => ExplDestroy m (Identity s) where
   {-# INLINE explDestroy #-}
-  explDestroy (Identity s) = explDestroy s
+  explDestroy (Identity s) = fmap coerce . explDestroy s
 
 T.makeInstances [2..8]
 
@@ -60,6 +62,8 @@ instance Component c => Component (Not c) where
 instance (Has w m c) => Has w m (Not c) where
   {-# INLINE getStore #-}
   getStore = NotStore <$> getStore
+  {-# INLINE setStore #-}
+  setStore (NotStore s) = setStore s
 
 type instance Elem (NotStore s) = Not (Elem s)
 
@@ -71,7 +75,7 @@ instance ExplGet m s => ExplGet m (NotStore s) where
 
 instance ExplDestroy m s => ExplSet m (NotStore s) where
   {-# INLINE explSet #-}
-  explSet (NotStore sa) ety _ = explDestroy sa ety
+  explSet (NotStore sa) ety _ = coerce <$> explDestroy sa ety
 
 -- | Pseudostore used to produce values of type @Maybe a@.
 --   Will always return @True@ for @explExists@.
@@ -83,6 +87,8 @@ instance Component c => Component (Maybe c) where
 instance (Has w m c) => Has w m (Maybe c) where
   {-# INLINE getStore #-}
   getStore = MaybeStore <$> getStore
+  {-# INLINE setStore #-}
+  setStore (MaybeStore s) = setStore s
 
 type instance Elem (MaybeStore s) = Maybe (Elem s)
 
@@ -96,8 +102,8 @@ instance ExplGet m s => ExplGet m (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
+  explSet (MaybeStore sa) ety Nothing  = coerce <$> explDestroy sa ety
+  explSet (MaybeStore sa) ety (Just x) = coerce <$> explSet sa ety x
 
 -- | Used for 'Either', a logical disjunction between two components.
 --   As expected, Either is used to model error values.
@@ -110,6 +116,10 @@ instance (Component ca, Component cb) => Component (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
+  {-# INLINE setStore #-}
+  setStore (EitherStore sa sb) = do
+    setStore sa
+    setStore sb
 
 type instance Elem (EitherStore sa sb) = Either (Elem sa) (Elem sb)
 
@@ -127,19 +137,23 @@ instance (ExplGet m sa, ExplGet m sb) => ExplGet m (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
+  explSet (EitherStore sa sb) ety (Right b) = (\sb' -> EitherStore sa sb') <$> explSet sb ety b
+  explSet (EitherStore sa sb) ety (Left a)  = (\sa' -> EitherStore sa' sb) <$> explSet sa ety a
 
 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
+  explDestroy (EitherStore sa sb) ety = do
+    sa' <- explDestroy sa ety
+    sb' <- explDestroy sb ety
+    return $ EitherStore sa' sb'
 
 -- Unit instances ()
 instance Monad m => Has w m () where
   {-# INLINE getStore #-}
   getStore = return ()
+  {-# INLINE setStore #-}
+  setStore _ = return ()
 instance Component () where
   type Storage () = ()
 type instance Elem () = ()
@@ -171,6 +185,8 @@ instance Component c => Component (Filter c) where
 instance Has w m c => Has w m (Filter c) where
   {-# INLINE getStore #-}
   getStore = FilterStore <$> getStore
+  {-# INLINE setStore #-}
+  setStore (FilterStore s) = setStore s
 
 type instance Elem (FilterStore s) = Filter (Elem s)
 
@@ -194,6 +210,8 @@ instance Component Entity where
 instance Monad m => Has w m Entity where
   {-# INLINE getStore #-}
   getStore = return EntityStore
+  {-# INLINE setStore #-}
+  setStore _ = return ()
 
 type instance Elem EntityStore = Entity
 instance Monad m => ExplGet m EntityStore where

apecs/src/Apecs/Core.hs

@@ -13,25 +13,26 @@ module Apecs.Core where
 
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
-import           Control.Monad.Reader
+import           Control.Monad.State
 import qualified Data.Vector.Unboxed  as U
+import Control.Monad.Identity
 
 -- | 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, Enum)
 
--- | A SystemT is a newtype around `ReaderT w m a`, where `w` is the game world variable.
+-- | A SystemT is a newtype around `StateT w m a`, where `w` is the game world variable.
 --   Systems serve to
 --
 --   * Allow type-based lookup of a component's store through @getStore@.
 --
 --   * Lift side effects into their host Monad.
-newtype SystemT w m a = SystemT {unSystem :: ReaderT w m a} deriving (Functor, Monad, Applicative, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)
-type System w a = SystemT w IO a
+newtype SystemT w m a = SystemT {unSystem :: StateT w m a} deriving (Functor, Monad, Applicative, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)
+type System w a = SystemT w Identity a
 
-deriving instance Monad m => MonadReader w (SystemT w m)
+deriving instance Monad m => MonadState 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.
@@ -42,6 +43,7 @@ class (Elem (Storage c) ~ c) => Component c where
 --   It is parameterized over @m@ to allow stores to be foreign.
 class (Monad m, Component c) => Has w m c where
   getStore :: SystemT w m (Storage c)
+  setStore :: Storage c -> SystemT w m ()
 
 -- | The type of components stored by a store, e.g. @Elem (Map c) = c@.
 type family Elem s
@@ -62,13 +64,16 @@ class Monad m => ExplGet m s where
 
 -- | Stores that can be written.
 class Monad m => ExplSet m s where
-  -- | Writes a component to the store.
-  explSet :: s -> Int -> Elem s -> m ()
+  -- | Writes a component to the store. Returns @Just@ a new store if the store
+  -- has changed. If the store is mutable and only undergoes internal mutation,
+  -- then you can safely return @Nothing@
+  explSet :: s -> Int -> Elem s -> m s
 
 -- | Stores that components can be removed from.
 class Monad m => ExplDestroy m s where
-  -- | Destroys the component for a given index.
-  explDestroy :: s -> Int -> m ()
+  -- | Destroys the component for a given index. Return the new store (similar
+  -- to @explSet@).
+  explDestroy :: s -> Int -> m s
 
 -- | Stores that we can request a list of member entities for.
 class Monad m => ExplMembers m s where

apecs/src/Apecs/Experimental/Components.hs

@@ -28,9 +28,11 @@ type instance Elem (RedirectStore s) = Redirect (Elem s)
 
 instance Has w m c => Has w m (Redirect c) where
   getStore = RedirectStore <$> getStore
+  setStore (RedirectStore s) = setStore s
 
 instance (ExplSet m s) => ExplSet m (RedirectStore s) where
-  explSet (RedirectStore s) _ (Redirect (Entity ety) c) = explSet s ety c
+  explSet (RedirectStore s) _ (Redirect (Entity ety) c)
+    = RedirectStore <$> explSet s ety c
 
 
 -- | Pseudocomponent that can be read like any other component, but will only
@@ -45,6 +47,7 @@ type instance Elem (HeadStore s) = Head (Elem s)
 
 instance Has w m c => Has w m (Head c) where
   getStore = HeadStore <$> getStore
+  setStore (HeadStore s) = setStore s
 
 instance (ExplGet m s) => ExplGet m (HeadStore s) where
   explExists (HeadStore s) ety = explExists s ety

apecs/src/Apecs/Experimental/Reactive.hs

@@ -27,7 +27,7 @@ module Apecs.Experimental.Reactive
 
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Control.Monad.Reader
+import           Control.Monad.State
 import qualified Data.Array.IO        as A
 import qualified Data.IntMap.Strict   as IM
 import qualified Data.IntSet          as S
@@ -69,15 +69,15 @@ instance (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ Elem r)
   explSet (Reactive r s) ety c = do
     old <- explGet (MaybeStore s) ety
     react (Entity ety) old (Just c) r
-    explSet s ety c
+    Reactive r <$> explSet s ety c
 
 instance (Reacts m r, ExplDestroy m s, ExplGet m s, Elem s ~ Elem r)
   => ExplDestroy m (Reactive r s) where
   {-# INLINE explDestroy #-}
   explDestroy (Reactive r s) ety = do
     old <- explGet (MaybeStore s) ety
     react (Entity ety) old Nothing r
-    explDestroy s ety
+    Reactive r <$> explDestroy s ety
 
 instance ExplGet m s => ExplGet m (Reactive r s) where
   {-# INLINE explExists #-}

apecs/src/Apecs/Experimental/Stores.hs

@@ -19,7 +19,7 @@ module Apecs.Experimental.Stores
   ( Pushdown(..), Stack(..)
   ) where
 
-import Control.Monad.Reader
+import Control.Monad.State
 import Data.Proxy
 import Data.Semigroup
 
@@ -62,7 +62,7 @@ instance
       ms <- explGet (MaybeStore s) ety
       let tail (StackList _ cs) = cs
           tail _                = []
-      explSet s ety (Stack (c:tail ms))
+      Pushdown <$> explSet s ety (Stack (c:tail ms))
 
 instance
   ( Monad m
@@ -73,7 +73,7 @@ instance
   ) => ExplDestroy m (Pushdown s c) where
     explDestroy (Pushdown s) ety = do
       mscs <- explGet (MaybeStore s) ety
-      case mscs of
+      Pushdown <$> case mscs of
         StackList _ cs' -> explSet s ety (Stack cs')
         _               -> explDestroy s ety
 
@@ -92,6 +92,7 @@ type instance Elem (StackStore s) = Stack (Elem s)
 
 instance (Storage c ~ Pushdown s c, Has w m c) => Has w m (Stack c) where
   getStore = StackStore <$> getStore
+  setStore (StackStore s) = setStore s
 
 instance
   ( Elem (s (Stack c)) ~ Stack c
@@ -105,14 +106,17 @@ instance
   , ExplSet     m (s (Stack c))
   , ExplDestroy m (s (Stack c))
   ) => ExplSet m (StackStore (Pushdown s c)) where
-  explSet (StackStore (Pushdown s)) ety (Stack []) = explDestroy s ety
-  explSet (StackStore (Pushdown s)) ety st         = explSet s ety st
+  explSet (StackStore (Pushdown s)) ety (Stack [])
+    = StackStore . Pushdown <$> explDestroy s ety
+  explSet (StackStore (Pushdown s)) ety st
+    = StackStore . Pushdown <$> explSet s ety st
 
 instance
   ( Elem (s (Stack c)) ~ Stack c
   , ExplDestroy m (s (Stack c))
   ) => ExplDestroy m (StackStore (Pushdown s c)) where
-  explDestroy (StackStore (Pushdown s)) = explDestroy s
+  explDestroy (StackStore (Pushdown s)) ety
+    =  StackStore . Pushdown <$> explDestroy s ety
 
 instance
   ( Elem (s (Stack c)) ~ Stack c