ecstasy 0.1.1.1 → 0.2.0.0

raw patch · 7 files changed

+893/−443 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−2
• ecstasy.cabal +3/−2
• src/Data/Ecstasy.hs +216/−291
• src/Data/Ecstasy/Deriving.hs +0/−127
• src/Data/Ecstasy/Internal.hs +416/−0
• src/Data/Ecstasy/Internal/Deriving.hs +154/−0
• src/Data/Ecstasy/Types.hs +87/−21

@@ -1,8 +1,23 @@ # Revision history for ecstasy -## 0.1.1.1  -- 2018-05-17+## 0.2.0.0  -- 2018-05-10 -* Use strict datastructures to avoid memory leaks. Backported from 0.2 branch.+* Renamed 'get*' to 'query*'.+* Renamed 'newEntity' to 'createEntity'.+* Renamed 'defEntity' to 'newEntity'.+* Renamed 'defEntity'' to 'unchanged'.+* Renamed 'defWorld' to 'defStorage'.+* Significant performance improvements.+* Added a 'Virtual' component type, allowing for easy integration with systems+    that own their own data. Getting and setting on 'Virtual' components+    dispatch as actions in the underlying monad stack.+* Added proper type wrappers around 'SystemT' and 'QueryT' so they don't eat up+    valuable mtl instances.+* Removed the 'Ent' parameter from the 'efor' callback, since this can now be+    gotten in any 'QueryT' context via 'queryEnt'.+* Parameterized 'emap' and 'efor' by an 'EntityTarget', which allows for calling+    these functions over specific groups of entities.+* Added 'eover': a combination of 'emap' and 'efor'.  ## 0.1.1.0  -- 2018-02-18 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                ecstasy-version:             0.1.1.1+version:             0.2.0.0 synopsis:   A GHC.Generics based entity component system. @@ -35,8 +35,9 @@  library   exposed-modules: Data.Ecstasy-  other-modules:   Data.Ecstasy.Deriving                  , Data.Ecstasy.Types+                 , Data.Ecstasy.Internal+                 , Data.Ecstasy.Internal.Deriving   -- other-extensions:   build-depends:       base >=4.9 && <5, containers, mtl, transformers   hs-source-dirs:      src

@@ -1,323 +1,248 @@-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DefaultSignatures    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}-+-- | Ecstasy is a library architected around the+-- <http://reasonablypolymorphic.com/blog/higher-kinded-data/ HKD pattern>, the+-- gist of which is to define a "template" type that can be reused for several+-- purposes. Users of ecstasy should define a record type of 'Component's+-- parameterized over a variable of kind 'StorageType':+--+-- @+--   data World s = Entity+--     { position :: 'Component' s ''Field' (V2 Double)+--     , graphics :: 'Component' s ''Field' Graphics+--     , isPlayer :: 'Component' s ''Unique' ()+--     }+--     deriving ('Generic')+-- @+--+-- Ensure that this type have an instance of 'Generic'.+--+-- For usability, it might be desirable to also define the following type+-- synonym:+--+-- @+--   type Entity = World 'FieldOf+-- @+--+-- which is the only form of the @World@ that most users of ecstasy will+-- need to interact with.+--+-- Throughout this document there are references to the @HasWorld@ and+-- @HasWorld'@ classes, which are implementation details and provided+-- automatically by the library. module Data.Ecstasy-  ( module Data.Ecstasy-  , module Data.Ecstasy.Types-  , Generic-  ) where+  (+  -- * Defining components+  -- $components+    ComponentType (..)+  , Component -import           Control.Arrow (first, second)-import           Control.Monad (mzero, void)-import           Control.Monad.Trans.Class (lift)-import           Control.Monad.Trans.Maybe (runMaybeT)-import           Control.Monad.Trans.Reader (runReaderT, ask)-import           Control.Monad.Trans.State.Strict (modify, gets, evalStateT)-import qualified Control.Monad.Trans.State.Strict as S-import           Data.Ecstasy.Deriving-import qualified Data.Ecstasy.Types as T-import           Data.Ecstasy.Types hiding (unEnt)-import           Data.Foldable (for_)-import           Data.Functor.Identity (runIdentity)-import           Data.Maybe (catMaybes)-import           Data.Traversable (for)-import           Data.Tuple (swap)-import           GHC.Generics+  -- * Storage+  -- $world+  , defStorage +  -- * The SystemT monad+  -- $systemt+  , SystemT ()+  , runSystemT+  , yieldSystemT+  , System+  , runSystem+  , SystemState ---------------------------------------------------------------------------------- | This class provides all of the functionality necessary to manipulate the--- ECS.-class HasWorld world where+  -- * Working with SystemT+  , createEntity+  , newEntity+  , getEntity+  , setEntity+  , deleteEntity -  -----------------------------------------------------------------------------  -- | Fetches an entity from the world given its 'Ent'.-  getEntity-      :: ( Monad m-         )-      => Ent-      -> SystemT world m (world 'FieldOf)-  default getEntity-      :: ( GGetEntity (Rep (world 'WorldOf))-                      (Rep (world 'FieldOf))-         , Generic (world 'FieldOf)-         , Generic (world 'WorldOf)-         , Monad m-         )-      => Ent-      -> SystemT world m (world 'FieldOf)-  getEntity e = do-    w <- gets snd-    pure . to . gGetEntity (from w) $ T.unEnt e+  -- * SystemT traversals+  -- $traversals+  , emap+  , efor+  , eover+  , unchanged+  , delEntity -  -----------------------------------------------------------------------------  -- | Updates an 'Ent' in the world given its setter.-  setEntity-      :: Monad m-      => Ent-      -> world 'SetterOf-      -> SystemT world m ()-  default setEntity-      :: ( GSetEntity (Rep (world 'SetterOf))-                      (Rep (world 'WorldOf))-         , Generic (world 'WorldOf)-         , Generic (world 'SetterOf)-         , Monad m-         )-      => Ent-      -> world 'SetterOf-      -> SystemT world m ()-  setEntity e s = do-    w <- gets snd-    let x = to . gSetEntity (from s) (T.unEnt e) $ from w-    modify . second $ const x+  -- * Entity targets+  , EntTarget+  , allEnts+  , someEnts+  , anEnt -  -----------------------------------------------------------------------------  -- | Transforms an entity into a setter to transform the default entity into-  -- the given one. Used by 'newEntity'.-  convertSetter-      :: world 'FieldOf-      -> world 'SetterOf-  default convertSetter-      :: ( GConvertSetter (Rep (world 'FieldOf))-                          (Rep (world 'SetterOf))-         , Generic (world 'FieldOf)-         , Generic (world 'SetterOf)-         )-      => world 'FieldOf-      -> world 'SetterOf-  convertSetter = to . gConvertSetter . from-  {-# INLINE convertSetter #-}+  -- * The QueryT monad+  -- $queryt+  , QueryT ()+  , runQueryT -  -----------------------------------------------------------------------------  -- | The default entity, owning no components.-  defEntity :: world 'FieldOf-  default defEntity-      :: ( Generic (world 'FieldOf)-         , GDefault 'True (Rep (world 'FieldOf))-         )-      => world 'FieldOf-  defEntity = def @'True-  {-# INLINE defEntity #-}+  -- * Queries+  -- $querying+  , query+  , with+  , without+  , queryEnt+  , queryMaybe+  , queryFlag+  , queryDef -  -----------------------------------------------------------------------------  -- | The default setter, which keeps all components with their previous value.-  defEntity' :: world 'SetterOf-  default defEntity'-      :: ( Generic (world 'SetterOf)-         , GDefault 'True (Rep (world 'SetterOf))-         )-      => world 'SetterOf-  defEntity' = def @'True-  {-# INLINE defEntity' #-}+  -- * Updates+  , Update (..)+  , maybeToUpdate -  -----------------------------------------------------------------------------  -- | A setter which will delete the entity if its 'QueryT' matches.-  delEntity :: world 'SetterOf-  default delEntity-      :: ( Generic (world 'SetterOf)-         , GDefault 'False (Rep (world 'SetterOf))-         )-      => world 'SetterOf-  delEntity = def @'False-  {-# INLINE delEntity #-}+  -- * Miscellany+  , Ent ()+  , VTable (..) -  -----------------------------------------------------------------------------  -- | The default world, which contains only empty containers.-  defWorld :: world 'WorldOf-  default defWorld-      :: ( Generic (world 'WorldOf)-         , GDefault 'True (Rep (world 'WorldOf))-         )-      => world 'WorldOf-  defWorld = def @'True-  {-# INLINE defWorld #-}+  -- * Re-exports+  , Generic ()+  ) where +import Data.Ecstasy.Internal hiding (HasWorld, HasWorld')+import Data.Ecstasy.Types+import GHC.Generics -instance ( Generic (world 'SetterOf)-         , Generic (world 'WorldOf)-         , Generic (world 'FieldOf)-         , GSetEntity (Rep (world 'SetterOf))-                      (Rep (world 'WorldOf))-         , GGetEntity (Rep (world 'WorldOf))-                      (Rep (world 'FieldOf))-         , GConvertSetter (Rep (world 'FieldOf))-                          (Rep (world 'SetterOf))-         , GDefault 'True  (Rep (world 'FieldOf))-         , GDefault 'False (Rep (world 'SetterOf))-         , GDefault 'True  (Rep (world 'SetterOf))-         , GDefault 'True  (Rep (world 'WorldOf))-         ) => HasWorld world  ---------------------------------------------------------------------------------- | Retrieve a unique 'Ent'.-nextEntity-    :: Monad m-    => SystemT a m Ent-nextEntity = do-  (e, _) <- S.get-  modify . first . const $ e + 1-  pure $ Ent e+-- $components+-- Components are pieces of data that may or may not exist on a particular+-- entity. In fact, an 'Ent' is nothing more than an identifier, against which+-- components are linked.+--+-- Components classified by their 'ComponentType', which describes the+-- semantics behind a component.+--+-- [@Field@]  A 'Field' is a "normal" component and corresponds exactly to+-- a 'Maybe' value.+--+-- [@Unique@] A 'Unique' component may only exist on a single entity at a given+-- time. They are often used to annotate "notable" entites, such as whom the+-- camera should be following.+--+-- [@Virtual@] A 'Virtual' component is defined in terms of monadic 'vget' and+-- 'vset' actions, rather than having dedicated storage in the ECS. Virtual+-- components are often used to connect to external systems, eg. to a 3rd party+-- physics engine which wants to own its own data. For more information on+-- using virtual components, see <#world defStorage>.+--+--  ---------------------------------------------------------------------------------- | Create a new entity.-newEntity-    :: (HasWorld world, Monad m)-    => world 'FieldOf-    -> SystemT world m Ent-newEntity cs = do-  e <- nextEntity-  setEntity e $ convertSetter cs-  pure e +-- $world+-- #world# 'defStorage' provides a suitable container for storing entity data, to+-- be used with 'runSystemT' and friends. If you are not using any 'Virtual'+-- components, it can be used directly.+--+-- However, when using 'Virtual' components, the 'VTable' for each must be set+-- on 'defStorage' before being given as a parameter to 'runSystemT'. For+-- example, we can write a virtual 'String' component that writes its updates+-- to stdout:+--+-- @+--   data World s = Entity+--     { stdout :: 'Component' s ''Virtual' String+--     }+--     deriving ('Generic')+--+--  main :: IO ()+--  main = do+--    let storage = 'defStorage'+--          { stdout = 'VTable'+--              { 'vget' = \\_   -> pure Nothing+--              , 'vset' = \\_ m -> for_ m putStrLn+--              }+--          }+--    'runSystemT' storage $ do+--      void $ 'createEntity' 'unchanged+--        { stdout = Just "hello world"+--        }+-- @+--+-- In this example, if you were to use 'defStorage' rather than @storage@ as the+-- argument to 'runSystemT', you would receive the following error:+--+-- @unset VTable for Virtual component \'stdout\'@ ---------------------------------------------------------------------------------- | Delete an entity.-deleteEntity-    :: (HasWorld world, Monad m)-    => Ent-    -> SystemT world m ()-deleteEntity = flip setEntity delEntity  ---------------------------------------------------------------------------------- | Evaluate a 'QueryT'.-unQueryT-  :: QueryT world m a-  -> world 'FieldOf-  -> m (Maybe a)-unQueryT = (runMaybeT .) . runReaderT+-- $systemt+-- The 'SystemT' transformer provides capabilities for creating, modifying,+-- reading and deleting entities, as well as performing <#traversals query+-- traversals> over them. It is the main monad of ecstasy.  ---------------------------------------------------------------------------------- | Map a 'QueryT' transformation over all entites that match it.-emap-    :: ( HasWorld world-       , Monad m-       )-    => QueryT world m (world 'SetterOf)-    -> SystemT world m ()-emap f = do-  (es, _) <- S.get-  for_ [0 .. es - 1] $ \(Ent -> e) -> do-    cs <- getEntity e-    sets <- lift $ unQueryT f cs-    for_ sets $ setEntity e +-- $queryt+-- The 'QueryT' transformer provides an environment for <#traversals querying>+-- components of an entity. Due to its 'Control.Monad.MonadPlus' instance,+-- failing queries will prevent further computations in the monad from running. ---------------------------------------------------------------------------------- | Collect the results of a monadic computation over every entity matching--- a 'QueryT'.-efor-    :: ( HasWorld world-       , Monad m-       )-    => (Ent -> QueryT world m a)-    -> SystemT world m [a]-efor f = do-  (es, _) <- S.get-  fmap catMaybes $ for [0 .. es - 1] $ \(Ent -> e) -> do-    cs <- getEntity e-    lift $ unQueryT (f e) cs  ---------------------------------------------------------------------------------- | Run a 'QueryT' over a particular 'Ent'.-runQueryT-    :: ( HasWorld world-       , Monad m-       )-    => Ent-    -> QueryT world m a-    -> SystemT world m (Maybe a)-runQueryT e qt = do-  cs <- getEntity e-  lift $ unQueryT qt cs+-- $traversals+-- #traversals# 'SystemT' provides functionality for traversing over entities+-- that match a 'EntTarget' and a <#querying query>. The functions 'emap' and+-- 'eover' return a @world 'SetterOf@, corresponding to partial update of the+-- targeted entity.+--+-- A @world 'SetterOf@ is the world record where all of its selectors have the+-- type @'Update' a@. For example, given a world:+--+-- @+--   data World s = Entity+--     { position :: 'Component' s ''Field' (V2 Double)+--     , graphics :: 'Component' s ''Field' Graphics+--     , isPlayer :: 'Component' s ''Unique' ()+--     }+-- @+--+-- then @World 'SetterOf@ is equivalent to the following definition:+--+-- @+--   data World 'SetterOf = Entity+--     { position :: 'Update' (V2 Double)+--     , graphics :: 'Update' Graphics+--     , isPlayer :: 'Update' ()+--     }+-- @+--+-- 'unchanged' provides a @world 'SetterOf@ which will update no components,+-- and can have partial modifications added to it.+--+-- 'delEntity' provides a @world 'SetterOf@ which will delete all components+-- associated with the targeted entity.  ---------------------------------------------------------------------------------- | Provides a resumable 'SystemT'. This is a pretty big hack until I come up--- with a better formalization for everything.-yieldSystemT-    :: Monad m-    => SystemState world-    -> SystemT world m a-    -> m (SystemState world, a)-yieldSystemT = (fmap swap .) . flip S.runStateT ----------------------------------------------------------------------------------- | Evaluate a 'SystemT'.-runSystemT-    :: Monad m-    => world 'WorldOf-    -> SystemT world m a-    -> m a-runSystemT = flip evalStateT . (0,)------------------------------------------------------------------------------------ | Evaluate a 'System'.-runSystem-    :: world 'WorldOf-    -> System world a-    -> a-runSystem = (runIdentity .) . runSystemT------------------------------------------------------------------------------------ | Get the world.-getWorld-    :: Monad m-    => SystemT world m (world 'WorldOf)-getWorld = gets snd------------------------------------------------------------------------------------ | Only evaluate this 'QueryT' for entities which have the given component.-with-    :: Monad m-    => (world 'FieldOf -> Maybe a)-    -> QueryT world m ()-with = void . get------------------------------------------------------------------------------------ | Only evaluate this 'QueryT' for entities which do not have the given--- component.-without-    :: Monad m-    => (world 'FieldOf -> Maybe a)-    -> QueryT world m ()-without f = do-  e <- ask-  maybe (pure ()) (const mzero) $ f e------------------------------------------------------------------------------------ | Get the value of a component, failing the 'QueryT' if it isn't present.-get-    :: Monad m-    => (world 'FieldOf -> Maybe a)-    -> QueryT world m a-get f = do-  e <- ask-  maybe mzero pure $ f e-+-- $querying+-- #querying# The 'QueryT' monad provides functionality for performing+-- computations over an 'Ent''s components. The basic primitive is 'query',+-- which will pull the value of a component, and fail the query if it isn't+-- set.+--+-- For example, given the following world:+--+-- @+--   data World s = Entity+--     { position :: 'Component' s ''Field' (V2 Double)+--     , velocity :: 'Component' s ''Field' (V2 Double)+--     }+--     deriving ('Generic')+-- @+--+-- we could model a discrete time simulation via:+--+-- @+--   stepTime :: 'System' World ()+--   stepTime = do+--     'emap' 'allEnts' $ do+--       pos <- 'query' position+--       vel <- 'query' velocity+--       pure $ 'unchanged'+--         { position = 'Set' $ pos + vel+--         }+-- @+--+-- which will add an entity's velocity to its position, so long as it has both+-- components to begin with. ---------------------------------------------------------------------------------- | Attempt to get the value of a component.-getMaybe-    :: Monad m-    => (world 'FieldOf -> Maybe a)-    -> QueryT world m (Maybe a)-getMaybe f = fmap f ask 

@@ -1,127 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeOperators         #-}--module Data.Ecstasy.Deriving where--import           Data.Ecstasy.Types (Update (..))-import           Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I-import           GHC.Generics---class GConvertSetter a b where-  gConvertSetter :: a x -> b x--instance GConvertSetter (K1 i a) (K1 i' (Maybe a)) where-  gConvertSetter (K1 a) = K1 $ Just a-  {-# INLINE gConvertSetter #-}--instance GConvertSetter (K1 i a) (K1 i' (Update a)) where-  gConvertSetter (K1 a) = K1 $ Set a-  {-# INLINE gConvertSetter #-}--instance GConvertSetter (K1 i (Maybe a)) (K1 i' (Update a)) where-  gConvertSetter (K1 (Just a)) = K1 $ Set a-  gConvertSetter (K1 Nothing)  = K1 Unset-  {-# INLINE gConvertSetter #-}--instance GConvertSetter f f' => GConvertSetter (M1 i c f) (M1 i' c' f') where-  gConvertSetter (M1 a) = M1 $ gConvertSetter a-  {-# INLINE gConvertSetter #-}--instance (GConvertSetter a c , GConvertSetter b d) => GConvertSetter (a :*: b) (c :*: d) where-  gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b-  {-# INLINE gConvertSetter #-}---class GGetEntity a b where-  gGetEntity :: a x -> Int -> b x--instance GGetEntity (K1 i (IntMap a)) (K1 i' (Maybe a)) where-  gGetEntity (K1 a) e = K1 $ I.lookup e $ a-  {-# INLINE gGetEntity #-}--instance GGetEntity (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where-  gGetEntity (K1 (Just (e', a))) e | e == e' = K1 $ Just a-  gGetEntity _ _ = K1 Nothing-  {-# INLINE gGetEntity #-}--instance GGetEntity f f' => GGetEntity (M1 i c f) (M1 i' c' f') where-  gGetEntity (M1 a) e = M1 $ gGetEntity a e-  {-# INLINE gGetEntity #-}--instance (GGetEntity a c , GGetEntity b d) => GGetEntity (a :*: b) (c :*: d) where-  gGetEntity (a :*: b) e = gGetEntity a e :*: gGetEntity b e-  {-# INLINE gGetEntity #-}---class GSetEntity a b where-  gSetEntity :: a x -> Int -> b x -> b x--instance GSetEntity (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where-  gSetEntity (K1 (Set a)) e _ = K1 $ Just (e, a)-  gSetEntity (K1 Unset) e (K1 (Just (e', b))) =-    if e == e'-       then K1 Nothing-       else K1 $ Just (e', b)-  gSetEntity _  _ (K1 b) = K1 b-  {-# INLINE gSetEntity #-}--instance GSetEntity (K1 i (Update a)) (K1 i' (IntMap a)) where-  gSetEntity (K1 Keep) _ (K1 b) = K1 b-  gSetEntity (K1 (Set a)) e (K1 b) = K1 $ I.alter (const $ Just a) e b-  gSetEntity (K1 Unset) e (K1 b) = K1 $ I.alter (const Nothing) e b-  {-# INLINE gSetEntity #-}--instance GSetEntity f f' => GSetEntity (M1 i c f) (M1 i' c' f') where-  gSetEntity (M1 a) e (M1 b) = M1 $ gSetEntity a e b-  {-# INLINE gSetEntity #-}--instance (GSetEntity a c , GSetEntity b d) => GSetEntity (a :*: b) (c :*: d) where-  gSetEntity (a :*: b) e (c :*: d) = gSetEntity a e c :*: gSetEntity b e d-  {-# INLINE gSetEntity #-}---def :: forall keep a. (Generic a, GDefault keep (Rep a)) => a-def = to $ gdef @keep-{-# INLINE def #-}---class GDefault (keep :: Bool) f where-  gdef :: f a--instance GDefault keep U1 where-  gdef = U1-  {-# INLINE gdef #-}--instance GDefault keep (K1 i (Maybe c)) where-  gdef = K1 Nothing-  {-# INLINE gdef #-}--instance GDefault 'False (K1 i (Update c)) where-  gdef = K1 Unset-  {-# INLINE gdef #-}--instance GDefault 'True (K1 i (Update c)) where-  gdef = K1 Keep-  {-# INLINE gdef #-}--instance GDefault keep (K1 i (IntMap c)) where-  gdef = K1 I.empty-  {-# INLINE gdef #-}--instance GDefault keep f => GDefault keep (M1 i c f) where-  gdef = M1 $ gdef @keep-  {-# INLINE gdef #-}--instance (GDefault keep a, GDefault keep b) => GDefault keep (a :*: b) where-  gdef = gdef @keep :*: gdef @keep-  {-# INLINE gdef #-}-

@@ -0,0 +1,416 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE ViewPatterns           #-}++module Data.Ecstasy.Internal where++import           Control.Arrow (first, second)+import           Control.Monad (mzero, void)+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Maybe (runMaybeT)+import           Control.Monad.Trans.Reader (runReaderT, asks)+import           Control.Monad.Trans.State.Strict (modify, get, gets, evalStateT)+import qualified Control.Monad.Trans.State.Strict as S+import           Data.Ecstasy.Internal.Deriving+import qualified Data.Ecstasy.Types as T+import           Data.Ecstasy.Types hiding (unEnt)+import           Data.Foldable (for_)+import           Data.Functor.Identity (Identity (..))+import           Data.Maybe (catMaybes)+import           Data.Traversable (for)+import           Data.Tuple (swap)+import           GHC.Generics+++------------------------------------------------------------------------------+-- | This class provides all of the functionality necessary to manipulate the+-- ECS.+class HasWorld' world => HasWorld world m where++  ----------------------------------------------------------------------------+  -- | Fetches an entity from the world given its 'Ent'.+  getEntity+      :: Monad m+      => Ent+      -> SystemT world m (world 'FieldOf)+  default getEntity+      :: ( Monad m+         , GGetEntity m+                      (Rep (world ('WorldOf m)))+                      (Rep (world 'FieldOf))+         , Generic (world 'FieldOf)+         , Generic (world ('WorldOf m))+         )+      => Ent+      -> SystemT world m (world 'FieldOf)+  getEntity e = do+    w <- SystemT $ gets snd+    lift . fmap to . gGetEntity @m (from w) $ T.unEnt e+  {-# INLINE getEntity #-}++  ----------------------------------------------------------------------------+  -- | Updates an 'Ent' in the world given its setter.+  setEntity+      :: Ent+      -> world 'SetterOf+      -> SystemT world m ()+  default setEntity+      :: ( GSetEntity m+                      (Rep (world 'SetterOf))+                      (Rep (world ('WorldOf m)))+         , Generic (world ('WorldOf m))+         , Generic (world 'SetterOf)+         , Monad m+         )+      => Ent+      -> world 'SetterOf+      -> SystemT world m ()+  setEntity e s = do+    w <- SystemT $ gets snd+    x <- lift . fmap to . gSetEntity (from s) (T.unEnt e) $ from w+    SystemT . modify . second $ const x+  {-# INLINE setEntity #-}++  ----------------------------------------------------------------------------+  -- | The default world, which contains only empty containers.+  defStorage :: world ('WorldOf m)+  default defStorage+      :: ( Generic (world ('WorldOf m))+         , GDefault 'True (Rep (world ('WorldOf m)))+         )+      => world ('WorldOf m)+  defStorage = def @'True+++class HasWorld' world where+  ----------------------------------------------------------------------------+  -- | Transforms an entity into a setter to transform the default entity into+  -- the given one. Used by 'createEntity'.+  convertSetter+      :: world 'FieldOf+      -> world 'SetterOf+  default convertSetter+      :: ( GConvertSetter (Rep (world 'FieldOf))+                          (Rep (world 'SetterOf))+         , Generic (world 'FieldOf)+         , Generic (world 'SetterOf)+         )+      => world 'FieldOf+      -> world 'SetterOf+  convertSetter = to . gConvertSetter . from+  {-# INLINE convertSetter #-}++  ----------------------------------------------------------------------------+  -- | The default entity, owning no components.+  newEntity :: world 'FieldOf+  default newEntity+      :: ( Generic (world 'FieldOf)+         , GDefault 'True (Rep (world 'FieldOf))+         )+      => world 'FieldOf+  newEntity = def @'True+  {-# INLINE newEntity #-}++  ----------------------------------------------------------------------------+  -- | The default setter, which keeps all components with their previous value.+  unchanged :: world 'SetterOf+  default unchanged+      :: ( Generic (world 'SetterOf)+         , GDefault 'True (Rep (world 'SetterOf))+         )+      => world 'SetterOf+  unchanged = def @'True+  {-# INLINE unchanged #-}++  ----------------------------------------------------------------------------+  -- | A setter which will delete the entity if its 'QueryT' matches.+  delEntity :: world 'SetterOf+  default delEntity+      :: ( Generic (world 'SetterOf)+         , GDefault 'False (Rep (world 'SetterOf))+         )+      => world 'SetterOf+  delEntity = def @'False+  {-# INLINE delEntity #-}+++instance ( Generic (world 'SetterOf)+         , Generic (world 'FieldOf)+         , GConvertSetter (Rep (world 'FieldOf))+                          (Rep (world 'SetterOf))+         , GDefault 'True  (Rep (world 'FieldOf))+         , GDefault 'False (Rep (world 'SetterOf))+         , GDefault 'True  (Rep (world 'SetterOf))+         ) => HasWorld' world+++instance ( HasWorld' world+         , Generic (world 'SetterOf)+         , Generic (world ('WorldOf m))+         , Generic (world 'FieldOf)+         , GConvertSetter (Rep (world 'FieldOf))+                          (Rep (world 'SetterOf))+         , GDefault 'True  (Rep (world 'FieldOf))+         , GDefault 'False (Rep (world 'SetterOf))+         , GDefault 'True  (Rep (world 'SetterOf))+         , GDefault 'True  (Rep (world ('WorldOf m)))+         , GSetEntity m+                      (Rep (world 'SetterOf))+                      (Rep (world ('WorldOf m)))+         , GGetEntity m+                      (Rep (world ('WorldOf m)))+                      (Rep (world 'FieldOf))+         , Monad m+         ) => HasWorld world m+++------------------------------------------------------------------------------+-- | Retrieve a unique 'Ent'.+nextEntity+    :: Monad m+    => SystemT a m Ent+nextEntity = do+  (e, _) <- SystemT S.get+  SystemT . modify . first . const $ e + 1+  pure $ Ent e+++------------------------------------------------------------------------------+-- | Create a new entity.+createEntity+    :: (HasWorld world m, Monad m)+    => world 'FieldOf+    -> SystemT world m Ent+createEntity cs = do+  e <- nextEntity+  setEntity e $ convertSetter cs+  pure e+++------------------------------------------------------------------------------+-- | Delete an entity.+deleteEntity+    :: (HasWorld world m, Monad m)+    => Ent+    -> SystemT world m ()+deleteEntity = flip setEntity delEntity+++------------------------------------------------------------------------------+-- | Evaluate a 'QueryT'.+unQueryT+  :: QueryT world m a+  -> Ent+  -> world 'FieldOf+  -> m (Maybe a)+unQueryT q e f = runMaybeT $ flip runReaderT (e, f) $ runQueryT' q+++------------------------------------------------------------------------------+-- | Map a 'QueryT' transformation over all entites that match it.+emap+    :: ( HasWorld world m+       , Monad m+       )+    => EntTarget world m+    -> QueryT world m (world 'SetterOf)+    -> SystemT world m ()+emap t f = do+  es <- t+  for_ es $ \e -> do+    cs <- getEntity e+    sets <- lift $ unQueryT f e cs+    for_ sets $ setEntity e+++------------------------------------------------------------------------------+-- | Collect the results of a monadic computation over every entity matching+-- a 'QueryT'.+efor+    :: ( HasWorld world m+       , Monad m+       )+    => EntTarget world m+    -> QueryT world m a+    -> SystemT world m [a]+efor t f = do+  es <- t+  fmap catMaybes $ for es $ \e -> do+    cs <- getEntity e+    lift $ unQueryT f e cs+++------------------------------------------------------------------------------+-- | Do an 'emap' and an 'efor' at the same time.+eover+    :: ( HasWorld world m+       , Monad m+       )+    => EntTarget world m+    -> QueryT world m (a, world 'SetterOf)+    -> SystemT world m [a]+eover t f = do+  es <- t+  fmap catMaybes $ for es $ \e -> do+    cs <- getEntity e+    mset <- lift $ unQueryT f e cs+    for mset $ \(a, setter) -> do+      setEntity e setter+      pure a+++------------------------------------------------------------------------------+-- | Run a 'QueryT' over a particular 'Ent'.+runQueryT+    :: ( HasWorld world m+       , Monad m+       )+    => Ent+    -> QueryT world m a+    -> SystemT world m (Maybe a)+runQueryT e qt = do+  cs <- getEntity e+  lift $ unQueryT qt e cs+++------------------------------------------------------------------------------+-- | Provides a resumable 'SystemT'. This is a pretty big hack until I come up+-- with a better formalization for everything.+yieldSystemT+    :: Monad m+    => SystemState world m+    -> SystemT world m a+    -> m (SystemState world m, a)+yieldSystemT w = fmap swap . flip S.runStateT w . runSystemT'+++------------------------------------------------------------------------------+-- | Evaluate a 'SystemT'.+runSystemT+    :: Monad m+    => world ('WorldOf m)+    -> SystemT world m a+    -> m a+runSystemT w = flip evalStateT (0, w) . runSystemT'+++------------------------------------------------------------------------------+-- | Evaluate a 'System'.+runSystem+    :: world ('WorldOf Identity)+    -> System world a+    -> a+runSystem = (runIdentity .) . runSystemT+++------------------------------------------------------------------------------+-- | Only evaluate this 'QueryT' for entities which have the given component.+with+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m ()+with = void . query+{-# INLINE with #-}+++------------------------------------------------------------------------------+-- | Only evaluate this 'QueryT' for entities which do not have the given+-- component.+without+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m ()+without f = do+  e <- QueryT $ asks snd+  maybe (pure ()) (const mzero) $ f e+++------------------------------------------------------------------------------+-- | Get the value of a component, failing the 'QueryT' if it isn't present.+query+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m a+query f = do+  e <- QueryT $ asks snd+  maybe mzero pure $ f e+{-# INLINE query #-}+++------------------------------------------------------------------------------+-- | Attempt to get the value of a component.+queryMaybe+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m (Maybe a)+queryMaybe f = fmap f $ QueryT $ asks snd+++------------------------------------------------------------------------------+-- | Get the 'Ent' for whom this query is running.+queryEnt+    :: Monad m+    => QueryT world m Ent+queryEnt = QueryT $ asks fst+++------------------------------------------------------------------------------+-- | Query a flag as a 'Bool'.+queryFlag+    :: Monad m+    => (world 'FieldOf -> Maybe ())+    -> QueryT world m Bool+queryFlag = fmap (maybe False (const True)) . queryMaybe+++------------------------------------------------------------------------------+-- | Perform a query with a default.+queryDef+    :: Monad m+    => z+    -> (world 'FieldOf -> Maybe z)+    -> QueryT world m z+queryDef z = fmap (maybe z id) . queryMaybe+++------------------------------------------------------------------------------+-- | An 'EntTarget' is a set of 'Ent's to iterate over.+type EntTarget world m = SystemT world m [Ent]+++------------------------------------------------------------------------------+-- | Iterate over all entities.+allEnts :: Monad m => EntTarget world m+allEnts = do+  (es, _) <- SystemT get+  pure $ Ent <$> [0 .. es - 1]+++------------------------------------------------------------------------------+-- | Iterate over some entities.+someEnts :: Monad m => [Ent] -> EntTarget world m+someEnts = pure+++------------------------------------------------------------------------------+-- | Iterate over an entity.+anEnt :: Monad m => Ent -> EntTarget world m+anEnt = pure . pure+++------------------------------------------------------------------------------+-- | Turn a 'Maybe' into an 'Update'.+maybeToUpdate :: Maybe a -> Update a+maybeToUpdate Nothing  = Unset+maybeToUpdate (Just a) = Set a+

@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++module Data.Ecstasy.Internal.Deriving where++import           Data.Ecstasy.Types (Update (..), VTable (..), Ent (..))+import           Data.IntMap (IntMap)+import qualified Data.IntMap as I+import           Data.Proxy (Proxy (..))+import           GHC.Generics+import           GHC.TypeLits+++class GConvertSetter a b where+  gConvertSetter :: a x -> b x++instance GConvertSetter (K1 i a) (K1 i' (Maybe a)) where+  gConvertSetter (K1 a) = K1 $ Just a+  {-# INLINE gConvertSetter #-}++instance GConvertSetter (K1 i a) (K1 i' (Update a)) where+  gConvertSetter (K1 a) = K1 $ Set a+  {-# INLINE gConvertSetter #-}++instance GConvertSetter (K1 i (Maybe a)) (K1 i' (Update a)) where+  gConvertSetter (K1 (Just a)) = K1 $ Set a+  gConvertSetter (K1 Nothing)  = K1 Unset+  {-# INLINE gConvertSetter #-}++instance GConvertSetter f f' => GConvertSetter (M1 i c f) (M1 i' c' f') where+  gConvertSetter (M1 a) = M1 $ gConvertSetter a+  {-# INLINE gConvertSetter #-}++instance (GConvertSetter a c , GConvertSetter b d) => GConvertSetter (a :*: b) (c :*: d) where+  gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b+  {-# INLINE gConvertSetter #-}+++class GGetEntity m a b where+  gGetEntity :: a x -> Int -> m (b x)++instance (Applicative m)+      => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where+  gGetEntity (K1 (VTable vget _)) e = fmap K1 $ vget $ Ent e+  {-# INLINE gGetEntity #-}++instance Applicative m => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where+  gGetEntity (K1 a) e = pure . K1 $ I.lookup e $ a+  {-# INLINE gGetEntity #-}++instance Applicative m => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where+  gGetEntity (K1 (Just (e', a))) e | e == e' = pure . K1 $ Just a+  gGetEntity _ _ = pure $ K1 Nothing+  {-# INLINE gGetEntity #-}++instance (Functor m, GGetEntity m f f') => GGetEntity m (M1 i c f) (M1 i' c' f') where+  gGetEntity (M1 a) e = fmap M1 $ gGetEntity a e+  {-# INLINE gGetEntity #-}++instance (Applicative m, GGetEntity m a c , GGetEntity m b d) => GGetEntity m (a :*: b) (c :*: d) where+  gGetEntity (a :*: b) e = (:*:) <$> gGetEntity a e <*> gGetEntity b e+  {-# INLINE gGetEntity #-}+++class GSetEntity m a b where+  gSetEntity :: a x -> Int -> b x -> m (b x)++instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where+  gSetEntity (K1 (Set a)) e _ = pure . K1 $ Just (e, a)+  gSetEntity (K1 Unset) e (K1 (Just (e', b))) =+    pure $ if e == e'+       then K1 Nothing+       else K1 $ Just (e', b)+  gSetEntity _  _ (K1 b) = pure $ K1 b+  {-# INLINE gSetEntity #-}++instance (Applicative m)+      => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where+  gSetEntity (K1 a) e (K1 z@(VTable _ vset)) =+    vset (Ent e) a *> pure (K1 z)+  {-# INLINE gSetEntity #-}++instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where+  gSetEntity (K1 Keep) _ (K1 b) = pure $ K1 b+  gSetEntity (K1 (Set a)) e (K1 b) = pure . K1 $ I.alter (const $ Just a) e b+  gSetEntity (K1 Unset) e (K1 b) = pure . K1 $ I.alter (const Nothing) e b+  {-# INLINE gSetEntity #-}++instance (Functor m, GSetEntity m f f') => GSetEntity m (M1 i c f) (M1 i' c' f') where+  gSetEntity (M1 a) e (M1 b) = fmap M1 $ gSetEntity a e b+  {-# INLINE gSetEntity #-}++instance (Applicative m, GSetEntity m a c, GSetEntity m b d) => GSetEntity m (a :*: b) (c :*: d) where+  gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c <*> gSetEntity b e d+  {-# INLINE gSetEntity #-}+++def :: forall keep a. (Generic a, GDefault keep (Rep a)) => a+def = to $ gdef @keep+{-# INLINE def #-}+++class GDefault (keep :: Bool) f where+  gdef :: f a++instance GDefault keep U1 where+  gdef = U1+  {-# INLINE gdef #-}++instance GDefault keep (K1 i (Maybe c)) where+  gdef = K1 Nothing+  {-# INLINE gdef #-}++instance GDefault 'False (K1 i (Update c)) where+  gdef = K1 Unset+  {-# INLINE gdef #-}++instance GDefault 'True (K1 i (Update c)) where+  gdef = K1 Keep+  {-# INLINE gdef #-}++instance GDefault keep (K1 i (IntMap c)) where+  gdef = K1 I.empty+  {-# INLINE gdef #-}++instance {-# OVERLAPPING #-} (Applicative m, KnownSymbol sym)+      => GDefault keep (M1 S ('MetaSel ('Just sym) x y z) (K1 i (VTable m a))) where+  gdef = M1 $ K1 $ VTable (const err) (const $ const err)+    where+      err :: err+      err = error $ mconcat+            [ "unset VTable for Virtual component '"+            , symbolVal $ Proxy @sym+            , "'"+            ]+  {-# INLINE gdef #-}++instance GDefault keep f => GDefault keep (M1 i c f) where+  gdef = M1 $ gdef @keep+  {-# INLINE gdef #-}++instance (GDefault keep a, GDefault keep b) => GDefault keep (a :*: b) where+  gdef = gdef @keep :*: gdef @keep+  {-# INLINE gdef #-}+

@@ -1,14 +1,32 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeInType                 #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS_GHC -funbox-strict-fields   #-}  module Data.Ecstasy.Types where -import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Trans.Reader (ReaderT)-import Control.Monad.Trans.State.Strict (StateT)+import Control.Applicative (Alternative)+import Control.Monad (MonadPlus)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.State.Class (MonadState (..))+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Reader (ReaderT (..))+import Control.Monad.Trans.State.Strict (StateT (..))+import Control.Monad.Writer.Class (MonadWriter) import Data.Functor.Identity (Identity) import Data.IntMap.Strict (IntMap)+import Data.Kind   ------------------------------------------------------------------------------@@ -22,36 +40,83 @@  ------------------------------------------------------------------------------ -- | The internal state of the 'SystemT' monad.-type SystemState w = (Int, w 'WorldOf)+type SystemState w m = (Int, w ('WorldOf m))  ------------------------------------------------------------------------------ -- | A monad transformer over an ECS given a world 'w'.-type SystemT w = StateT (SystemState w)+newtype SystemT w m a = SystemT+  { runSystemT' :: StateT (SystemState w m) m a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadReader r+           , MonadWriter ww+           , MonadIO+           ) +instance MonadTrans (SystemT w) where+  lift = SystemT . lift++instance MonadState s m => MonadState s (SystemT w m) where+  get = SystemT . lift $ get+  put = SystemT . lift . put++ ------------------------------------------------------------------------------ -- | A monad over an ECS given a world 'w'.-type System  w = SystemT w Identity+type System w = SystemT w Identity + ------------------------------------------------------------------------------ -- | A computation to run over a particular entity.-type QueryT w m = ReaderT (w 'FieldOf) (MaybeT m)+newtype QueryT w m a = QueryT+  { runQueryT' :: ReaderT (Ent, w 'FieldOf) (MaybeT m) a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadState s+           , MonadWriter ww+           , MonadIO+           , Alternative+           , MonadPlus+           ) +instance MonadTrans (QueryT w) where+  lift = QueryT . lift . lift +instance MonadReader r m => MonadReader r (QueryT w m) where+  ask = QueryT $ lift ask+  local f = QueryT . runQueryT' . local f++ ------------------------------------------------------------------------------+-- | A collection of methods necessary to dispatch reads and writes to+-- a 'Virtual' component.+data VTable m a = VTable+  { -- | Get the value of an entity's component.+    vget :: !(Ent -> m (Maybe a))++    -- | Update the value of an entity's component.+  , vset :: !(Ent -> Update a -> m ())+  }+++------------------------------------------------------------------------------ -- | Data kind used to parameterize the ECS record. data StorageType-  = FieldOf   -- ^ Used to construct the actual entity.-  | WorldOf   -- ^ Used to construct the world's storage.+  = FieldOf   -- ^ Used to describe the actual entity.+  | WorldOf (Type -> Type)  -- ^ Used to construct the world's storage.   | SetterOf  -- ^ Used to construct a setter to update an entity.-  deriving (Eq, Ord, Show, Read, Enum, Bounded)   ------------------------------------------------------------------------------ -- | Data kind used to parameterize the fields of the ECS record. data ComponentType-  = Field   -- ^ This component can be owned by any entity.-  | Unique  -- ^ This component can be owned by only a single entity at a time.-  deriving (Eq, Ord, Show, Read, Enum, Bounded)+  = Field      -- ^ This component can be owned by any entity.+  | Unique     -- ^ This component can be owned by only a single entity at a time.+  | Virtual    -- ^ This component is owned by another system.   ------------------------------------------------------------------------------@@ -59,18 +124,19 @@ data Update a   = Keep   -- ^ Keep the current value.   | Unset  -- ^ Delete the current value if it exists.-  | Set a  -- ^ Set the current value.-  deriving (Eq, Ord, Show, Read)+  | Set !a  -- ^ Set the current value.+  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)   ------------------------------------------------------------------------------ -- | A type family to be used in your ECS recrod. type family Component (s :: StorageType)                       (c :: ComponentType)-                      (a :: *) :: * where+                      (a :: Type) :: Type where   Component 'FieldOf  c      a = Maybe a   Component 'SetterOf c      a = Update a -  Component 'WorldOf 'Field  a = IntMap a-  Component 'WorldOf 'Unique a = Maybe (Int, a)+  Component ('WorldOf m) 'Field   a = IntMap a+  Component ('WorldOf m) 'Unique  a = Maybe (Int, a)+  Component ('WorldOf m) 'Virtual a = VTable m a