From 5f416adfb9739435d95f09ef05781a832b68bb74 Mon Sep 17 00:00:00 2001 From: David Eichmann Date: Wed, 21 Apr 2021 00:49:17 +0100 Subject: [PATCH] WIP remove MonadIO requirement --- apecs/bench/Main.hs | 8 +- apecs/src/Apecs.hs | 11 ++- apecs/src/Apecs/Components.hs | 36 ++++++--- apecs/src/Apecs/Core.hs | 23 +++--- apecs/src/Apecs/Experimental/Components.hs | 5 +- apecs/src/Apecs/Experimental/Reactive.hs | 6 +- apecs/src/Apecs/Experimental/Stores.hs | 16 ++-- apecs/src/Apecs/Stores.hs | 94 +++++++++++----------- apecs/src/Apecs/System.hs | 56 +++++++++---- apecs/src/Apecs/TH.hs | 46 +++++++++-- apecs/src/Apecs/THTuples.hs | 26 +++++- apecs/src/Apecs/Util.hs | 5 +- apecs/test/Main.hs | 28 ++++--- 13 files changed, 241 insertions(+), 119 deletions(-) diff --git a/apecs/bench/Main.hs b/apecs/bench/Main.hs index 04d49a2..61f84bc 100644 --- a/apecs/bench/Main.hs +++ b/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))) ] ] diff --git a/apecs/src/Apecs.hs b/apecs/src/Apecs.hs index 64c63e8..282def3 100644 --- a/apecs/src/Apecs.hs +++ b/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 diff --git a/apecs/src/Apecs/Components.hs b/apecs/src/Apecs/Components.hs index b1aa1ae..6069b3f 100644 --- a/apecs/src/Apecs/Components.hs +++ b/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 diff --git a/apecs/src/Apecs/Core.hs b/apecs/src/Apecs/Core.hs index 1d60696..d65718b 100644 --- a/apecs/src/Apecs/Core.hs +++ b/apecs/src/Apecs/Core.hs @@ -13,8 +13,9 @@ 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. @@ -22,16 +23,16 @@ import qualified Data.Vector.Unboxed as U -- 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 diff --git a/apecs/src/Apecs/Experimental/Components.hs b/apecs/src/Apecs/Experimental/Components.hs index d593c64..49e809c 100644 --- a/apecs/src/Apecs/Experimental/Components.hs +++ b/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 diff --git a/apecs/src/Apecs/Experimental/Reactive.hs b/apecs/src/Apecs/Experimental/Reactive.hs index 9620894..8330bd8 100644 --- a/apecs/src/Apecs/Experimental/Reactive.hs +++ b/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,7 +69,7 @@ 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 @@ -77,7 +77,7 @@ instance (Reacts m r, ExplDestroy m s, ExplGet m s, Elem s ~ Elem r) 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 #-} diff --git a/apecs/src/Apecs/Experimental/Stores.hs b/apecs/src/Apecs/Experimental/Stores.hs index f1d2cca..9726365 100644 --- a/apecs/src/Apecs/Experimental/Stores.hs +++ b/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 diff --git a/apecs/src/Apecs/Stores.hs b/apecs/src/Apecs/Stores.hs index 4a34625..46b3424 100644 --- a/apecs/src/Apecs/Stores.hs +++ b/apecs/src/Apecs/Stores.hs @@ -18,11 +18,9 @@ module Apecs.Stores ) where import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader +import Control.Monad.State import Data.Bits (shiftL, (.&.)) import qualified Data.IntMap.Strict as M -import Data.IORef import Data.Proxy import Data.Typeable (Typeable, typeRep) import qualified Data.Vector.Mutable as VM @@ -33,15 +31,15 @@ import GHC.TypeLits import Apecs.Core -- | A map based on 'Data.IntMap.Strict'. O(log(n)) for most operations. -newtype Map c = Map (IORef (M.IntMap c)) +newtype Map c = Map (M.IntMap c) type instance Elem (Map c) = c -instance MonadIO m => ExplInit m (Map c) where - explInit = liftIO$ Map <$> newIORef mempty +instance Applicative m => ExplInit m (Map c) where + explInit = pure (Map mempty) -instance (MonadIO m, Typeable c) => ExplGet m (Map c) where - explExists (Map ref) ety = liftIO$ M.member ety <$> readIORef ref - explGet (Map ref) ety = liftIO$ flip fmap (M.lookup ety <$> readIORef ref) $ \case +instance (Monad m, Typeable c) => ExplGet m (Map c) where + explExists (Map ref) ety = return (M.member ety ref) + explGet (Map ref) ety = return $ case M.lookup ety ref of Just c -> c notFound -> error $ unwords [ "Reading non-existent Map component" @@ -52,31 +50,29 @@ instance (MonadIO m, Typeable c) => ExplGet m (Map c) where {-# INLINE explExists #-} {-# INLINE explGet #-} -instance MonadIO m => ExplSet m (Map c) where +instance Monad m => ExplSet m (Map c) where {-# INLINE explSet #-} - explSet (Map ref) ety x = liftIO$ - modifyIORef' ref (M.insert ety x) + explSet (Map ref) ety x = return $ Map $ M.insert ety x ref -instance MonadIO m => ExplDestroy m (Map c) where +instance Monad m => ExplDestroy m (Map c) where {-# INLINE explDestroy #-} - explDestroy (Map ref) ety = liftIO$ - readIORef ref >>= writeIORef ref . M.delete ety + explDestroy (Map ref) ety = return $ Map $ M.delete ety ref -instance MonadIO m => ExplMembers m (Map c) where +instance Monad m => ExplMembers m (Map c) where {-# INLINE explMembers #-} - explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref + explMembers (Map ref) = return $ U.fromList $ M.keys 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. -newtype Unique c = Unique (IORef (Maybe (Int, c))) +newtype Unique c = Unique (Maybe (Int, c)) type instance Elem (Unique c) = c -instance MonadIO m => ExplInit m (Unique c) where - explInit = liftIO$ Unique <$> newIORef Nothing +instance Monad m => ExplInit m (Unique c) where + explInit = pure (Unique Nothing) -instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where +instance (Monad m, Typeable c) => ExplGet m (Unique c) where {-# INLINE explGet #-} - explGet (Unique ref) _ = liftIO$ flip fmap (readIORef ref) $ \case + explGet (Unique ref) _ = return $ case ref of Just (_, c) -> c notFound -> error $ unwords [ "Reading non-existent Unique component" @@ -84,20 +80,21 @@ instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where ] {-# INLINE explExists #-} - explExists (Unique ref) ety = liftIO$ maybe False ((==ety) . fst) <$> readIORef ref + explExists (Unique ref) ety = return $ maybe False ((==ety) . fst) ref -instance MonadIO m => ExplSet m (Unique c) where +instance Monad m => ExplSet m (Unique c) where {-# INLINE explSet #-} - explSet (Unique ref) ety c = liftIO$ writeIORef ref (Just (ety, c)) + explSet _ ety c = return $ Unique $ Just (ety, c) -instance MonadIO m => ExplDestroy m (Unique c) where +instance Monad m => ExplDestroy m (Unique c) where {-# INLINE explDestroy #-} - explDestroy (Unique ref) ety = liftIO$ readIORef ref >>= - mapM_ (flip when (writeIORef ref Nothing) . (==ety) . fst) + explDestroy u@(Unique ref) ety = return $ case ref of + Just (ety', _) | ety' == ety -> Unique Nothing + _ -> u -instance MonadIO m => ExplMembers m (Unique c) where +instance Monad m => ExplMembers m (Unique c) where {-# INLINE explMembers #-} - explMembers (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case + explMembers (Unique ref) = return $ case ref of Nothing -> mempty Just (ety, _) -> U.singleton ety @@ -109,21 +106,21 @@ instance MonadIO m => ExplMembers m (Unique c) where -- The convenience entity 'global' is defined as -1, and can be used to make operations on a global more explicit, i.e. 'Time t <- get global'. -- -- You also can read and write Globals during a 'cmap' over other components. -newtype Global c = Global (IORef c) +newtype Global c = Global c type instance Elem (Global c) = c -instance (Monoid c, MonadIO m) => ExplInit m (Global c) where +instance (Monoid c, Monad m) => ExplInit m (Global c) where {-# INLINE explInit #-} - explInit = liftIO$ Global <$> newIORef mempty + explInit = return $ Global mempty -instance MonadIO m => ExplGet m (Global c) where +instance Monad m => ExplGet m (Global c) where {-# INLINE explGet #-} - explGet (Global ref) _ = liftIO$ readIORef ref + explGet (Global ref) _ = return ref {-# INLINE explExists #-} explExists _ _ = return True -instance MonadIO m => ExplSet m (Global c) where +instance Monad m => ExplSet m (Global c) where {-# INLINE explSet #-} - explSet (Global ref) _ c = liftIO$ writeIORef ref c + explSet _ _ c = return $ Global c -- | Class of stores that behave like a regular map, and can therefore safely be cached. -- This prevents stores like `Unique` and 'Global', which do /not/ behave like simple maps, from being cached. @@ -180,14 +177,18 @@ instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where {-# INLINE explSet #-} - explSet (Cache mask tags cache s) ety x = do + explSet c@(Cache mask tags cache s) ety x = do let index = ety .&. mask tag <- liftIO$ UM.unsafeRead tags index - when (tag /= (-2) && tag /= ety) $ do - cached <- liftIO$ VM.unsafeRead cache index - explSet s tag cached + c' <- if (tag /= (-2) && tag /= ety) + then do + cached <- liftIO$ VM.unsafeRead cache index + s' <- explSet s tag cached + return $ Cache mask tags cache s' + else return c liftIO$ UM.unsafeWrite tags index ety liftIO$ VM.unsafeWrite cache index x + return c' instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where {-# INLINE explDestroy #-} @@ -197,7 +198,8 @@ instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where when (tag == ety) $ liftIO $ do UM.unsafeWrite tags index (-2) VM.unsafeWrite cache index cacheMiss - explDestroy s ety + s' <- explDestroy s ety + return (Cache mask tags cache s') instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where {-# INLINE explMembers #-} @@ -233,8 +235,9 @@ setReadOnly :: forall w m s c. , ExplSet m s ) => Entity -> c -> SystemT w m () setReadOnly (Entity ety) c = do - ReadOnly s <- getStore - lift $ explSet s ety c + ReadOnly s :: ReadOnly s <- getStore + s' <- lift $ explSet s ety c + setStore $ ReadOnly s' destroyReadOnly :: forall w m s c. ( Has w m c @@ -244,4 +247,5 @@ destroyReadOnly :: forall w m s c. ) => Entity -> Proxy c -> SystemT w m () destroyReadOnly (Entity ety) _ = do ReadOnly s :: Storage c <- getStore - lift $ explDestroy s ety + s' <- lift $ explDestroy s ety + setStore $ ReadOnly s' diff --git a/apecs/src/Apecs/System.hs b/apecs/src/Apecs/System.hs index f210207..cc7da44 100644 --- a/apecs/src/Apecs/System.hs +++ b/apecs/src/Apecs/System.hs @@ -6,24 +6,34 @@ module Apecs.System where -import Control.Monad -import Control.Monad.Reader +import Control.Monad.State hiding (modify) import Data.Proxy import qualified Data.Vector.Unboxed as U import Apecs.Components () import Apecs.Core +import Control.Monad.Identity -- | Run a system in a game world {-# INLINE runSystem #-} -runSystem :: SystemT w m a -> w -> m a -runSystem sys = runReaderT (unSystem sys) +runSystem :: System w a -> w -> (a, w) +runSystem sys = runIdentity . runStateT (unSystem sys) -- | Run a system in a game world {-# INLINE runWith #-} -runWith :: w -> SystemT w m a -> m a +runWith :: w -> System w a -> (a, w) runWith = flip runSystem +-- | Run a system in a game world +{-# INLINE runSystemM #-} +runSystemM :: Monad m => SystemT w m a -> w -> m (a, w) +runSystemM sys = runStateT (unSystem sys) + +-- | Run a system in a game world +{-# INLINE runWithM #-} +runWithM :: Monad m => w -> SystemT w m a -> m (a, w) +runWithM = flip runSystemM + -- | Read a Component {-# INLINE get #-} get :: forall w m c. Get w m c => Entity -> SystemT w m c @@ -36,7 +46,8 @@ get (Entity ety) = do set, ($=) :: forall w m c. Set w m c => Entity -> c -> SystemT w m () set (Entity ety) x = do s :: Storage c <- getStore - lift$ explSet s ety x + s' <- lift$ explSet s ety x + setStore s' -- | @set@ operator ($=) = set @@ -54,7 +65,8 @@ exists (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 - lift$ explDestroy s ety + s' <- lift$ explDestroy s ety + setStore s' -- | Applies a function, if possible. {-# INLINE modify #-} @@ -62,11 +74,14 @@ modify, ($~) :: forall w m cx cy. (Get w m cx, Set w m cy) => Entity -> (cx -> c modify (Entity ety) f = do sx :: Storage cx <- getStore sy :: Storage cy <- getStore - lift$ do + sy' <- lift$ do possible <- explExists sx ety - when possible $ do - x <- explGet sx ety - explSet sy ety (f x) + if possible + then do + x <- explGet sx ety + explSet sy ety (f x) + else return sy + setStore sy' -- | @modify@ operator ($~) = modify @@ -100,13 +115,20 @@ cmapIf cond f = do sp :: Storage cp <- getStore sx :: Storage cx <- getStore sy :: Storage cy <- getStore - lift$ do + sy' <- lift$ do sl <- explMembers (sx,sp) - U.forM_ sl $ \ e -> do - p <- explGet sp e - when (cond p) $ do - x <- explGet sx e - explSet sy e (f x) + U.foldM' + (\sy' e -> do + p <- explGet sp e + if (cond p) + then do + x <- explGet sx e + explSet sy' e (f x) + else return sy' + ) + sy + sl + setStore sy' -- | Monadically iterates over all entites with a @cx@, and writes their @cy@. {-# INLINE cmapM #-} diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs index 1a305d5..0fffdbe 100644 --- a/apecs/src/Apecs/TH.hs +++ b/apecs/src/Apecs/TH.hs @@ -10,11 +10,13 @@ module Apecs.TH ) where import Control.Monad +import Control.Monad.State (modify) import Language.Haskell.TH import Apecs.Core import Apecs.Stores import Apecs.Util (EntityCounter) +import Control.Monad.Identity (Identity(runIdentity)) genName :: String -> Q Name genName s = mkName . show <$> newName s @@ -41,17 +43,51 @@ makeWorldNoEC worldName cTypes = do [ FunD (mkName "getStore") [Clause [] (NormalB$ ConE sys `AppE` (VarE (mkName "asks") `AppE` VarE n)) [] ] + , FunD (mkName "setStore") [let sN = mkName "s" in Clause [VarP sN] + -- modify (\w -> w { n = s }) + (NormalB$ AppE + (VarE 'modify) + (let wN = mkName "w" in LamE [VarP wN] (RecUpdE (VarE wN) [(n, VarE sN)])) + ) + [] ] ] - 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) + + + + -- initMyWorldM :: forall m . (ExplInit m FieldA, ExplInit m FieldB, ...) => m MyWorld + initSig' functionName typeVars monadT f = SigD functionName + (let explInitT = ConT ''ExplInit + in ForallT + typeVars + (ConT ''Monad `AppT` monadT : [explInitT `AppT` monadT `AppT` rT | (_, _, rT) <- records]) + (f (ConT wld)) + ) + -- initMyWorldM = return MyWorld <*> explInit <*> ... <*> explInit + initDecl' functionName f = FunD functionName [Clause [] + (NormalB$ f $ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "explInit")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records) [] ] + + + initWorldMName = mkName $ "init" ++ worldName ++ "M" + initMSig = let mN = mkName "m" in initSig' initWorldMName [PlainTV mN] (VarT mN) (AppT (VarT mN)) + initMDecl = initDecl' initWorldMName id + + initWorldName = mkName $ "init" ++ worldName + initSig = initSig' initWorldName [] (ConT ''Identity) id + initDecl = initDecl' initWorldName (AppE (VarE 'runIdentity)) + hasDecl = makeInstance <$> cTypesNames - return $ wldDecl : initSig : initDecl : hasDecl + + return + $ wldDecl + : initMSig + : initMDecl + : initSig + : initDecl + : hasDecl -- | Creates 'Component' instances with 'Map' stores makeMapComponents :: [Name] -> Q [Dec] diff --git a/apecs/src/Apecs/THTuples.hs b/apecs/src/Apecs/THTuples.hs index 4873138..4aa34c8 100644 --- a/apecs/src/Apecs/THTuples.hs +++ b/apecs/src/Apecs/THTuples.hs @@ -12,6 +12,7 @@ instance (Component a, Component b) => Component (a, b) where instance (Has w a, Has w b) => Has w (a,b) where getStore = liftM2 (,) getStore getStore + setStore (a, b) = setStore a >> setStore b type instance Elem (a,b) = (Elem a, Elem b) @@ -35,7 +36,8 @@ makeInstances is = concat <$> traverse tupleInstances is tupleInstances :: Int -> Q [Dec] tupleInstances n = do - let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]] + let varNs = [ mkName $ "t_" ++ show i | i <- [0..n-1]] + vars = VarT <$> varNs m = VarT $ mkName "m" -- [''a,''b] -> ''(a,b) @@ -70,15 +72,35 @@ tupleInstances n = do getStoreE = VarE getStoreN apN = mkName "<*>" apE = VarE apN + setStoreN = mkName "setStore" + setStoreE = VarE setStoreN hasI = InstanceD Nothing (hasT <$> vars) (hasT varTuple) [ FunD getStoreN [Clause [] (NormalB$ liftAll tuplE (replicate n getStoreE )) [] ] , PragmaD$ InlineP getStoreN Inline FunLike AllPhases + , FunD setStoreN + [Clause + [TupP (VarP <$> varNs)] + (NormalB $ DoE [NoBindS (AppE setStoreE (VarE varN)) | varN <- varNs]) + [] + ] + , PragmaD$ InlineP setStoreN Inline FunLike AllPhases ] liftAll f mas = foldl (\a x -> AppE (AppE apE a) x) (AppE (VarE (mkName "pure")) f) mas sequenceAll :: [Exp] -> Exp - sequenceAll = foldl1 (\a x -> AppE (AppE (VarE$ mkName ">>") a) x) + sequenceAll es = DoE $ + [BindS (VarP name) e | (name, e) <- namedEs] + ++ [NoBindS $ AppE + (VarE (mkName "return")) +#if MIN_VERSION_template_haskell(2,16,0) + (TupE (Just . VarE . fst <$> namedEs)) +#else + (TupE (VarE . fst <$> namedEs)) +#endif + ] + where + namedEs = zip (mkName . ("t_" ++) . show <$> [(1 :: Int)..]) es -- Elem elemN = mkName "Elem" diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs index f2125fc..e98c3c8 100644 --- a/apecs/src/Apecs/Util.hs +++ b/apecs/src/Apecs/Util.hs @@ -18,7 +18,6 @@ module Apecs.Util ( import Control.Applicative (liftA2) import Control.Monad.IO.Class -import Control.Monad.Reader import Data.Monoid import Data.Semigroup import System.Mem (performMajorGC) @@ -64,5 +63,5 @@ newEntity_ component = do set entity component -- | Explicitly invoke the garbage collector -runGC :: System w () -runGC = lift performMajorGC +runGC :: MonadIO m => SystemT w m () +runGC = liftIO performMajorGC diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs index 6053c3b..038dd37 100644 --- a/apecs/test/Main.hs +++ b/apecs/test/Main.hs @@ -12,6 +12,8 @@ {-# OPTIONS_GHC -w #-} import Control.Monad +import Control.Monad.IO.Class +import Data.Functor.Identity import qualified Data.IntSet as S import Data.IORef import Data.List (sort) @@ -33,8 +35,8 @@ type Vec = (Double, Double) instance Arbitrary Entity where arbitrary = Entity . getNonNegative <$> arbitrary -assertSys :: IO w -> System w Bool -> Property -assertSys initW sys = monadicIO $ run (initW >>= runSystem sys) >>= assert +assertSys :: IO w -> SystemT w IO Bool -> Property +assertSys initW sys = monadicIO $ run (initW >>= runSystemM sys) >>= (assert . fst) genericSetGet :: forall w c. ( ExplGet IO (Storage c) @@ -94,19 +96,19 @@ newtype MapInt = MapInt Int deriving (Eq, Show, Arbitrary) instance Component MapInt where type Storage MapInt = Map MapInt makeWorld "Simple" [''MapInt] -prop_setGetMap = genericSetGet initSimple (undefined :: MapInt) -prop_setSetMap = genericSetSet initSimple (undefined :: MapInt) +prop_setGetMap = genericSetGet initSimpleM (undefined :: MapInt) +prop_setSetMap = genericSetSet initSimpleM (undefined :: MapInt) -- Tests whether this is also true for caches newtype CacheInt = CacheInt Int deriving (Eq, Show, Arbitrary) instance Component CacheInt where type Storage CacheInt = Cache 2 (Map CacheInt) makeWorld "Cached" [''CacheInt] -prop_setGetCache = genericSetGet initCached (undefined :: CacheInt) -prop_setSetCache = genericSetSet initCached (undefined :: CacheInt) +prop_setGetCache = genericSetGet initCachedM (undefined :: CacheInt) +prop_setSetCache = genericSetSet initCachedM (undefined :: CacheInt) prop_cacheUnique :: [CacheInt] -> [Entity] -> [(Entity, CacheInt)] -> Property -prop_cacheUnique eInit eDel eSet = assertSys initCached $ do +prop_cacheUnique eInit eDel eSet = assertSys initCachedM $ do mapM newEntity eInit mapM (flip set (Not @CacheInt)) eDel mapM (uncurry set) eSet @@ -123,8 +125,8 @@ instance Component T3 where type Storage T3 = Map T3 makeWorld "Tuples" [''T1, ''T2, ''T3] -prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3)) -prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3)) +prop_setGetTuple = genericSetGet initTuplesM (undefined :: (T1,T2,T3)) +prop_setSetTuple = genericSetSet initTuplesM (undefined :: (T1,T2,T3)) -- Tests Reactive store properties newtype TestEnum = TestEnum Bool deriving (Eq, Show, Bounded, Enum, Arbitrary) @@ -132,10 +134,10 @@ instance Component TestEnum where type Storage TestEnum = Reactive (EnumMap Test makeWorld "ReactiveWld" [''TestEnum] -prop_setGetReactive = genericSetGet initReactiveWld (undefined :: TestEnum) -prop_setSetReactive = genericSetSet initReactiveWld (undefined :: TestEnum) +prop_setGetReactive = genericSetGet initReactiveWldM (undefined :: TestEnum) +prop_setSetReactive = genericSetSet initReactiveWldM (undefined :: TestEnum) prop_lookupValid :: [(Entity, TestEnum)] -> [Entity] -> Property -prop_lookupValid writes deletes = assertSys initReactiveWld $ do +prop_lookupValid writes deletes = assertSys initReactiveWldM $ do forM_ writes $ uncurry set forM_ deletes $ flip destroy (Proxy @TestEnum) @@ -157,7 +159,7 @@ instance Component StackInt where type Storage StackInt = Pushdown Map StackInt makeWorld "StackWld" [''StackInt] -prop_setGetStack = genericSetSet initStackWld (undefined :: StackInt) +prop_setGetStack = genericSetSet initStackWldM (undefined :: StackInt) return [] main = $quickCheckAll