apecs 0.9.6 → 0.10.0

raw patch · 21 files changed

+2014/−1017 lines, 21 filesdep +foreign-storedep +transformersdep −exceptionsdep −mtldep −unliftio-coredep ~basedep ~containersdep ~vectorsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: foreign-store, transformers

Dependencies removed: exceptions, mtl, unliftio-core

Dependency ranges changed: base, containers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• Setup.hs +1/−0
• apecs.cabal +16/−11
• bench/Main.hs +24/−21
• src/Apecs.hs +108/−73
• src/Apecs/Components.hs +91/−64
• src/Apecs/Core.hs +50/−42
• src/Apecs/Experimental/Children.hs +121/−101
• src/Apecs/Experimental/Components.hs +22/−14
• src/Apecs/Experimental/Reactive.hs +148/−108
• src/Apecs/Experimental/Reload.hs +92/−0
• src/Apecs/Experimental/Stores.hs +66/−46
• src/Apecs/Experimental/Util.hs +59/−40
• src/Apecs/Stores.hs +19/−243
• src/Apecs/Stores/Internal.hs +282/−0
• src/Apecs/System.hs +90/−66
• src/Apecs/TH.hs +157/−39
• src/Apecs/TH/Tags.hs +232/−0
• src/Apecs/Tags.hs +41/−0
• src/Apecs/Util.hs +97/−41
• test/Main.hs +285/−108

@@ -1,3 +1,16 @@+## [0.10.0]++### Changed+- (#142) `SystemT` is now a type alias for `ReaderT` instead of a newtype: the `SystemT`/`unSystem` constructor is gone. Dropped the `mtl`, `exceptions`, and `unliftio-core` dependencies.+- (#151) Allow stores to init in monads with arbitrary constraints, initWorld will request them all.+### Added+- (#141) New `makeWorldDestructible` generates a `<WorldName>Destructible` type alias covering all components that can be used with `destroy`.+- (#144) New `explMemberSet` method on the `ExplMembers` typeclass returning IntSet.+- (#144) New `makeWorldEnumerable` generator makes a `<WorldName>Enumerable` type alias over all enumerable components, plus reusable TH helpers `hasStoreInstance`, `makeInstanceFold`, `mkTupleT`, `mkEitherT`, `mkFoldT` and the `Maybify` type family.+- (#147) Component tags and associated utilities: Apecs.Tags, Apecs.TH.Tags. Paired with the previous this enables generic world inspection and manipulation in runtime.+- (#148) Apecs.Experimental.Reload module for GHCi world persistence.+- (#155) `nextEntityIO` for getting the next entity atomically in `IO`.+ ## [0.9.6] ### Changed - (#110) Relax upper bound on `mtl`: 2.3 -> 2.4

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,5 +1,5 @@ name:               apecs-version:            0.9.6+version:            0.10.0 homepage:           https://github.com/jonascarpay/apecs#readme license:            BSD3 license-file:       LICENSE@@ -18,7 +18,7 @@  source-repository head   type:     git-  location: git://github.com/jonascarpay/apecs.git+  location: https://github.com/jonascarpay/apecs  library   hs-source-dirs:   src@@ -29,23 +29,28 @@     Apecs.Experimental.Components     Apecs.Experimental.Children     Apecs.Experimental.Reactive+    Apecs.Experimental.Reload     Apecs.Experimental.Stores     Apecs.Experimental.Util     Apecs.Stores+    Apecs.Stores.Internal     Apecs.System+    Apecs.Tags     Apecs.TH+    Apecs.TH.Tags     Apecs.Util -  other-modules:    Apecs.THTuples+  other-modules:+    Apecs.THTuples+   default-language: Haskell2010   build-depends:       array             >=0.4    && <0.6     , base              >=4.9    && <5-    , containers        >=0.5    && <0.8-    , exceptions        >=0.10.0 && <0.11-    , mtl               >=2.2    && <2.4+    , containers        >=0.5    && <0.9+    , transformers      >=0.5    && <0.7     , template-haskell  >=2.12   && <3-    , unliftio-core     >=0.2.0.1 && <0.3+    , foreign-store     >=0.2    && <0.3     , vector            >=0.11   && <0.14    ghc-options:      -Wall@@ -56,11 +61,11 @@   hs-source-dirs:   test   build-depends:       apecs-    , base        >=4.9  && <5-    , containers  >=0.5  && <0.8+    , base+    , containers     , linear      >=1.20 && <2     , QuickCheck  >=2.10 && <3-    , vector      >=0.10 && <0.14+    , vector    default-language: Haskell2010   ghc-options:      -Wall@@ -71,7 +76,7 @@   main-is:          Main.hs   build-depends:       apecs-    , base       >=4.9  && <5+    , base     , criterion  >=1.3  && <2     , linear     >=1.20 && <2 

@@ -1,20 +1,21 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE Strict                #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -import           Control.Monad-import           Criterion-import qualified Criterion.Main  as C-import           Criterion.Types-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)@@ -31,13 +32,15 @@   replicateM_ 9000 $ newEntity (ECSPos 0)  posVelStep :: System PosVel ()-posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v)+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))+main =+  C.defaultMainWith+    (C.defaultConfig{timeLimit = 10})+    [ bgroup+        "pos_vel"+        [ bench "init" $ whnfIO (initPosVel >>= runSystem posVelInit)+        , bench "step" $ whnfIO (initPosVel >>= runSystem (posVelInit >> posVelStep))+        ]     ]-  ]-

@@ -2,82 +2,117 @@ This module forms the apecs Prelude. It selectively re-exports the user-facing functions from the submodules. -}-module Apecs (-  -- * Core types-    SystemT(..), System, Component(..), Entity(..), Has(..), Not(..),-    Get, Set, Destroy, Members,+module Apecs+  ( -- * Core types+    SystemT+  , System+  , Component (..)+  , Entity (..)+  , Has (..)+  , Not (..)+  , Get+  , Set+  , Destroy+  , Members -  -- * Stores-    Map, Unique, Global, Cache,-    explInit,+    -- * Stores+  , Map+  , Unique+  , Global+  , Cache+  , explInit -  -- * Systems-    get, set, ($=),-    destroy, exists,-    modify, ($~),-    cmap, cmapIf, cmapM, cmapM_,-    cfold, cfoldM, cfoldM_, collect,-  -- ** Performance-  -- $performance+    -- * Systems+  , get+  , set+  , ($=)+  , destroy+  , exists+  , modify+  , ($~)+  , cmap+  , cmapIf+  , cmapM+  , cmapM_+  , cfold+  , cfoldM+  , cfoldM_+  , collect -  -- * Other-    runSystem, runWith,-    runGC, EntityCounter, newEntity, newEntity_, global,-    makeWorld, makeWorldAndComponents,+    -- ** Performance+    -- $performance -  -- * Re-exports-    asks, ask, liftIO, lift, Proxy (..)-) where+    -- * Other+  , runSystem+  , runWith+  , runGC+  , EntityCounter+  , newEntity+  , newEntity_+  , global+  , makeWorld+  , makeWorldAndComponents -import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.Reader (ask, asks, lift)-import           Data.Proxy+    -- * Re-exports+  , asks+  , ask+  , liftIO+  , lift+  , Proxy (..)+  ) where -import           Apecs.Components-import           Apecs.Core-import           Apecs.Stores-import           Apecs.System-import           Apecs.TH-import           Apecs.Util--- $performance------ When using 'cmap' or 'cfold' over a tuple of components, keep in mind the--- ordering of the tuple can have performance implications!------ For tuples, the way the 'cmap' and 'cfold' work under the hood is by--- iterating over the component in the first position, and then for each entity--- that has that component, checking whether the entity also has the components--- in the remaining positions. Therefore, the first component will typically be--- the most determining factor for performance, and a good rule of thumb is to,--- __when iterating over a tuple, put the rarest component in first position__.------ Let's take a look at an example.--- Consider a simple 2D rendering system built on top of `cmapM_`:------ @--- 'cmapM_' '$' \\(Sprite sprite, Visible) -> do---   renderSprite sprite--- @------ While this rendering system works, it could be made more efficient by--- leveraging knowledge of how the library handles reading of tupled components.--- The usage of 'cmapM_' here (or any of the other map/fold functions) will--- iterate over all entities with a @Sprite@ component and filter out any of--- these entities that do not have a @Visible@ component. Depending on the game,--- it is reasonable to assume that there are more sprites active in the game's--- world than sprites that are visible to the game's camera.------ Swapping the component ordering in the tuple is likely to be more efficient:------ @--- 'cmapM_' '$' \\(Visible, Sprite sprite) -> do---   renderSprite sprite--- @------ Now the system iterates over just those entities that are visible to the--- game's camera and filters out any that do not have a @Sprite@ component.------ While putting the rarest component first is an excellent rule of thumb, to--- get the best possible performance, always consider how maps and folds are--- executed under the hood, and how you can order your components to optimize--- that process.+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask, asks)+import Data.Proxy++import Apecs.Components+import Apecs.Core+import Apecs.Stores+import Apecs.System+import Apecs.TH+import Apecs.Util++{- $performance++When using 'cmap' or 'cfold' over a tuple of components, keep in mind the+ordering of the tuple can have performance implications!++For tuples, the way the 'cmap' and 'cfold' work under the hood is by+iterating over the component in the first position, and then for each entity+that has that component, checking whether the entity also has the components+in the remaining positions. Therefore, the first component will typically be+the most determining factor for performance, and a good rule of thumb is to,+__when iterating over a tuple, put the rarest component in first position__.++Let's take a look at an example.+Consider a simple 2D rendering system built on top of `cmapM_`:++@+'cmapM_' '$' \\(Sprite sprite, Visible) -> do+  renderSprite sprite+@++While this rendering system works, it could be made more efficient by+leveraging knowledge of how the library handles reading of tupled components.+The usage of 'cmapM_' here (or any of the other map/fold functions) will+iterate over all entities with a @Sprite@ component and filter out any of+these entities that do not have a @Visible@ component. Depending on the game,+it is reasonable to assume that there are more sprites active in the game's+world than sprites that are visible to the game's camera.++Swapping the component ordering in the tuple is likely to be more efficient:++@+'cmapM_' '$' \\(Visible, Sprite sprite) -> do+  renderSprite sprite+@++Now the system iterates over just those entities that are visible to the+game's camera and filters out any that do not have a @Sprite@ component.++While putting the rarest component first is an excellent rule of thumb, to+get the best possible performance, always consider how maps and folds are+executed under the hood, and how you can order your components to optimize+that process.+-}

@@ -1,60 +1,64 @@-{-# OPTIONS_GHC -Wno-orphans #-}--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Apecs.Components where  import Data.Functor.Identity+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U -import           Apecs.Core+import Apecs.Core import qualified Apecs.THTuples as T  -- | Identity component. @Identity c@ is equivalent to @c@, so mostly useless.-instance Component c => Component (Identity c) where+instance (Component c) => Component (Identity c) where   type Storage (Identity c) = Identity (Storage c) -instance Has w m c => Has w m (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 m s => ExplGet m (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+  {-# INLINE explExists #-}+  explExists (Identity s) = explExists s -instance ExplSet m s => ExplSet 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-instance ExplMembers m s => ExplMembers m (Identity s) where+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 explMemberSet #-}+  explMemberSet (Identity s) = explMemberSet s+instance (ExplDestroy m s) => ExplDestroy m (Identity s) where   {-# INLINE explDestroy #-}   explDestroy (Identity s) = explDestroy s -T.makeInstances [2..8]+T.makeInstances [2 .. 8] --- | Pseudocomponent indicating the absence of @a@.---   Mainly used as e.g. @cmap $ \(a, Not b) -> c@ to iterate over entities with an @a@ but no @b@.---   Can also be used to delete components, like @cmap $ \a -> (Not :: Not a)@ to delete every @a@ component.+{- | Pseudocomponent indicating the absence of @a@.+  Mainly used as e.g. @cmap $ \(a, Not b) -> c@ to iterate over entities with an @a@ but no @b@.+  Can also be used to delete components, like @cmap $ \a -> (Not :: Not a)@ to delete every @a@ component.+-} data Not a = Not  -- | Pseudostore used to produce values of type @Not a@, inverts @explExists@, and destroys instead of @explSet@. newtype NotStore s = NotStore s -instance Component c => Component (Not c) where+instance (Component c) => Component (Not c) where   type Storage (Not c) = NotStore (Storage c)  instance (Has w m c) => Has w m (Not c) where@@ -63,21 +67,23 @@  type instance Elem (NotStore s) = Not (Elem s) -instance ExplGet m s => ExplGet m (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 m s => ExplSet m (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@.---   Will always return @True@ for @explExists@.---   Writing can both set and delete a component using @Just@ and @Nothing@ respectively.+{- | Pseudostore used to produce values of type @Maybe a@.+  Will always return @True@ for @explExists@.+  Writing can both set and delete a component using @Just@ and @Nothing@ respectively.+-} newtype MaybeStore s = MaybeStore s-instance Component c => Component (Maybe c) where++instance (Component c) => Component (Maybe c) where   type Storage (Maybe c) = MaybeStore (Storage c)  instance (Has w m c) => Has w m (Maybe c) where@@ -86,24 +92,28 @@  type instance Elem (MaybeStore s) = Maybe (Elem s) -instance ExplGet m s => ExplGet m (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+    if e then+      Just <$> explGet sa ety+    else+      return Nothing   explExists _ _ = return True  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 Nothing = explDestroy sa ety   explSet (MaybeStore sa) ety (Just x) = explSet sa ety x --- | Used for 'Either', a logical disjunction between two components.---   As expected, Either is used to model error values.--- Getting an @Either a b@ will first attempt to get a @b@ and return it as @Right b@, or if it does not exist, get an @a@ as @Left a@.--- Can also be used to set one of two things.+{- | Used for 'Either', a logical disjunction between two components.+  As expected, Either is used to model error values.+Getting an @Either a b@ will first attempt to get a @b@ and return it as @Right b@, or if it does not exist, get an @a@ as @Left a@.+Can also be used to set one of two things.+-} data EitherStore sa sb = EitherStore sa sb+ instance (Component ca, Component cb) => Component (Either ca cb) where   type Storage (Either ca cb) = EitherStore (Storage ca) (Storage cb) @@ -117,86 +127,103 @@   {-# INLINE explGet #-}   explGet (EitherStore sa sb) ety = do     e <- explExists sb ety-    if e then Right <$> explGet sb ety-         else Left <$> explGet sa 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+    if e then+      return True+    else+      explExists sa ety  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 _) ety (Left a) = explSet sa ety a -instance (ExplDestroy m sa, ExplDestroy m sb)-       => ExplDestroy m (EitherStore sa sb) 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 (ExplMembers m sa, ExplMembers m sb) => ExplMembers m (EitherStore sa sb) where+  {-# INLINE explMemberSet #-}+  explMemberSet (EitherStore sa sb) = IS.union <$> explMemberSet sa <*> explMemberSet sb+  {-# INLINE explMembers #-}+  explMembers s = U.fromList . IS.toList <$> explMemberSet s+ -- Unit instances ()-instance Monad m => Has w m () where+instance (Monad m) => Has w m () where   {-# INLINE getStore #-}   getStore = return () instance Component () where   type Storage () = () type instance Elem () = ()-instance Monad m => ExplGet m () where+instance (Monad m) => ExplGet m () where   {-# INLINE explExists #-}   explExists _ _ = return True   {-# INLINE explGet #-}   explGet _ _ = return ()-instance Monad m => ExplSet m () where+instance (Monad m) => ExplSet m () where   {-# INLINE explSet #-}   explSet _ _ _ = return ()-instance Monad m => ExplDestroy m () 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@.---   Can be used in cmap as @cmap $ \(Filter :: Filter a) -> b@.---   Since the above can be written more consicely as @cmap $ \(_ :: a) -> b@, it is rarely directly.---   More interestingly, we can define reusable filters like @movables = Filter :: Filter (Position, Velocity)@.---   Note that 'Filter c' is equivalent to 'Not (Not c)'.+{- | Pseudocomponent that functions normally for @explExists@ and @explMembers@, but always return @Filter@ for @explGet@.+  Can be used in cmap as @cmap $ \(Filter :: Filter a) -> b@.+  Since the above can be written more consicely as @cmap $ \(_ :: a) -> b@, it is rarely directly.+  More interestingly, we can define reusable filters like @movables = Filter :: Filter (Position, Velocity)@.+  Note that 'Filter c' is equivalent to 'Not (Not c)'.+-} data Filter c = Filter deriving (Eq, Show)  -- Pseudostore for 'Filter'. newtype FilterStore s = FilterStore s -instance Component c => Component (Filter c) where+instance (Component c) => Component (Filter c) where   type Storage (Filter c) = FilterStore (Storage c) -instance Has w m c => Has w m (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 m s => ExplGet m (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 m s => ExplMembers m (FilterStore s) where+instance (ExplMembers m s) => ExplMembers m (FilterStore s) where   {-# INLINE explMembers #-}   explMembers (FilterStore s) = explMembers s+  {-# INLINE explMemberSet #-}+  explMemberSet (FilterStore s) = explMemberSet s --- | Pseudostore used to produce components of type 'Entity'.--- Always returns @True@ for @explExists@, and echoes back the entity argument for @explGet@.--- Used in e.g. @cmap $ \(a, ety :: Entity) -> b@ to access the current entity.+{- | Pseudostore used to produce components of type 'Entity'.+Always returns @True@ for @explExists@, and echoes back the entity argument for @explGet@.+Used in e.g. @cmap $ \(a, ety :: Entity) -> b@ to access the current entity.+-} data EntityStore = EntityStore+ instance Component Entity where   type Storage Entity = EntityStore -instance Monad m => Has w m Entity where+instance (Monad m) => Has w m Entity where   {-# INLINE getStore #-}   getStore = return EntityStore  type instance Elem EntityStore = Entity-instance Monad m => ExplGet m EntityStore where+instance (Monad m) => ExplGet m EntityStore where   {-# INLINE explGet #-}   explGet _ ety = return $ Entity ety   {-# INLINE explExists #-}

@@ -1,83 +1,91 @@-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Apecs.Core where -import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Control.Monad.IO.Unlift-import           Control.Monad.Reader-import qualified Data.Vector.Unboxed  as U+import Control.Monad.Trans.Reader+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U --- | 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.+{- | 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.---   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, MonadUnliftIO)-type System w a = SystemT w IO a+{- | A SystemT is a newtype around `ReaderT w m a`, where `w` is the game world variable.+  Systems serve to -deriving instance Monad m => MonadReader w (SystemT w m)+  * Allow type-based lookup of a component's store through @getStore@. --- | A component is defined by specifying how it is stored.---   The constraint ensures that stores and components are mapped one-to-one.+  * Lift side effects into their host Monad.+-}+type SystemT w m = ReaderT w m++type System w = SystemT w IO++{- | 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 m c@ means that world @w@ can produce a @Storage c@.---   It is parameterized over @m@ to allow stores to be foreign.+{- | @Has w m c@ means that world @w@ can produce a @Storage c@.+  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)  -- | The type of components stored by a store, e.g. @Elem (Map c) = c@. type family Elem s --- | Indicates that the store @s@ can be initialized.---   Generally, \"base\" stores like @Map c@ can be initialized, but composite stores like @MaybeStore s@ cannot.+{- | Indicates that the store @s@ can be initialized.+  Generally, \"base\" stores like @Map c@ can be initialized, but composite stores like @MaybeStore s@ cannot.+-} class ExplInit m s where   -- | Initialize a new empty store.   explInit :: m s --- | 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 Monad m => ExplGet m s where+{- | 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 (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 -> m (Elem s)+   -- | Returns whether there is a component for the given index.   explExists :: s -> Int -> m Bool  -- | Stores that can be written.-class Monad m => ExplSet m s where+class (Monad m) => ExplSet m s where   -- | Writes a component to the store.   explSet :: s -> Int -> Elem s -> m ()  -- | Stores that components can be removed from.-class Monad m => ExplDestroy m s where+class (Monad m) => ExplDestroy m s where   -- | Destroys the component for a given index.   explDestroy :: s -> Int -> m ()  -- | Stores that we can request a list of member entities for.-class Monad m => ExplMembers m s where+class (Monad m) => ExplMembers m s where   -- | Returns an unboxed vector of member indices   explMembers :: s -> m (U.Vector Int) -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))+  -- | Returns an IntSet of member indices+  explMemberSet :: s -> m IS.IntSet+  explMemberSet s = IS.fromList . U.toList <$> explMembers s++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))

@@ -1,3 +1,14 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ {-| Stability: experimental @@ -34,28 +45,17 @@ For an introduction to using this module, see the [associated example](https://github.com/jonascarpay/apecs/tree/master/examples/Children.hs). -}--{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE InstanceSigs               #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}- module Apecs.Experimental.Children   ( -- * Component-    Child(..)+    Child (..)+     -- * Pseudocomponents-  , ChildValue(..)-  , ChildList(..)+  , ChildValue (..)+  , ChildList (..)   ) where  import Apecs.Core-import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Foldable (for_) import Data.IORef (IORef) import Data.IntMap.Strict (IntMap)@@ -69,53 +69,57 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Vector.Unboxed as U --- | The 'Child' component wraps the parent entity and the child entity's--- underlying component value.------ If you want a @Foo@ component in your game to be treated as a child--- component, specify the component type as @Child Foo@ when declaring your--- world:------ > newtype Hitbox = Hitbox AABB deriving Show--- > instance Component Hitbox where type Storage Hitbox = Map Hitbox--- >--- > -- A type alias solely for TH quoting's sake.--- > type ChildHitbox = Child Hitbox--- >--- > makeWorld "World" [''ChildHitbox]------ If your system is iterating over the 'Child' component but does not need the--- parent entity, use the 'ChildValue' pseudocomponent instead for better--- performance.------ Note that if you delete a parent entity (i.e. 'Apecs.System.destroy'--- all of the parent entity's components), consider a--- 'Apecs.System.destroy' on the parent entity's children too. See--- 'ChildList' for assistance on this. This is more from a memory--- management point of view than one of safety: nothing via standard--- usage of this library will break if a child "outlives" its--- parent. However, both trying to directly 'Apecs.System.get' some--- component value of a child's non-existent parent or trying to--- directly 'Apecs.System.get' a parent's non-existent 'ChildList' will--- result in runtime errors. Raw use of 'Apecs.System.get' is inherently--- dangerous and its risk is not specific to the behavior provided by--- this module.+{- | The 'Child' component wraps the parent entity and the child entity's+underlying component value.++If you want a @Foo@ component in your game to be treated as a child+component, specify the component type as @Child Foo@ when declaring your+world:++> newtype Hitbox = Hitbox AABB deriving Show+> instance Component Hitbox where type Storage Hitbox = Map Hitbox+>+> -- A type alias solely for TH quoting's sake.+> type ChildHitbox = Child Hitbox+>+> makeWorld "World" [''ChildHitbox]++If your system is iterating over the 'Child' component but does not need the+parent entity, use the 'ChildValue' pseudocomponent instead for better+performance.++Note that if you delete a parent entity (i.e. 'Apecs.System.destroy'+all of the parent entity's components), consider a+'Apecs.System.destroy' on the parent entity's children too. See+'ChildList' for assistance on this. This is more from a memory+management point of view than one of safety: nothing via standard+usage of this library will break if a child "outlives" its+parent. However, both trying to directly 'Apecs.System.get' some+component value of a child's non-existent parent or trying to+directly 'Apecs.System.get' a parent's non-existent 'ChildList' will+result in runtime errors. Raw use of 'Apecs.System.get' is inherently+dangerous and its risk is not specific to the behavior provided by+this module.+-} data Child c = Child !Entity !c deriving (Eq, Show)-instance Component c => Component (Child c) where++instance (Component c) => Component (Child c) where   type Storage (Child c) = Children (Storage c) --- | 'Children' augments another store with support for one-to-many parent-child--- relationships.------ This wrapper is not exported. If the user wants a @Foo@ component to be--- treated as a child component, they declare their component when building--- their world as type @Child Foo@. This will cause the @Children@ store wrapper--- to be used via the @Storage@/@Elem@ type relation.+{- | 'Children' augments another store with support for one-to-many parent-child+relationships.++This wrapper is not exported. If the user wants a @Foo@ component to be+treated as a child component, they declare their component when building+their world as type @Child Foo@. This will cause the @Children@ store wrapper+to be used via the @Storage@/@Elem@ type relation.+-} data Children s = Children   { childrenParentToChildren :: !(IORef (IntMap IntSet))   , childrenChildToParent :: !(IORef (IntMap Int))   , childrenDelegate :: !s   }+ type instance Elem (Children s) = Child (Elem s)  instance (MonadIO m, ExplInit m s) => ExplInit m (Children s) where@@ -126,16 +130,20 @@     liftIO $ do       childrenParentToChildren <- IORef.newIORef M.empty       childrenChildToParent <- IORef.newIORef M.empty-      pure Children-        { childrenParentToChildren-        , childrenChildToParent-        , childrenDelegate-        }+      pure+        Children+          { childrenParentToChildren+          , childrenChildToParent+          , childrenDelegate+          }  instance (MonadIO m, ExplMembers m s) => ExplMembers m (Children s) where   {-# INLINE explMembers #-}   explMembers :: Children s -> m (U.Vector Int)   explMembers (Children _ _ s) = explMembers s+  {-# INLINE explMemberSet #-}+  explMemberSet :: Children s -> m IntSet+  explMemberSet (Children _ _ s) = explMemberSet s  instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where   {-# INLINE explGet #-}@@ -164,17 +172,18 @@       -- before converting to standard pair, so there's no need to evaluate       -- @childToParentMap'@ here before writing it to the @IORef@.       IORef.writeIORef childToParent childToParentMap'-      IORef.modifyIORef' parentToChildren-        $ M.insertWith S.union parent (S.singleton child)-        . case mPrevParent of+      IORef.modifyIORef' parentToChildren $+        M.insertWith S.union parent (S.singleton child)+          . case mPrevParent of             -- If the child was previously mapped to a different parent, be sure             -- to clean up the old mapping from parent to child.-            Just prevParent | prevParent /= parent ->-              M.update (deleteParentToChild child) prevParent+            Just prevParent+              | prevParent /= parent ->+                  M.update (deleteParentToChild child) prevParent             _ -> id     where-    insertChildToParent :: M.Key -> Int -> Int -> Int-    insertChildToParent _k newParent _prevParent = newParent+      insertChildToParent :: M.Key -> Int -> Int -> Int+      insertChildToParent _k newParent _prevParent = newParent  instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Children s) where   {-# INLINE explDestroy #-}@@ -193,19 +202,21 @@           -- before converting to standard pair, so there's no need to evaluate           -- @childToParentMap'@ here before writing it to the @IORef@.           IORef.writeIORef childToParent childToParentMap'-          IORef.modifyIORef' parentToChildren-            $ M.update (deleteParentToChild child) parent+          IORef.modifyIORef' parentToChildren $+            M.update (deleteParentToChild child) parent     where-    deleteChildToParent :: M.Key -> Int -> Maybe Int-    deleteChildToParent _k _v = Nothing+      deleteChildToParent :: M.Key -> Int -> Maybe Int+      deleteChildToParent _k _v = Nothing --- | Accessor pseudocomponent that produces just the underlying component value--- as opposed to 'Child' which also produces the parent entity.------ For best performance, you should prefer 'ChildValue' over 'Child' if your--- system is iterating over children and does not need the parent entities.+{- | Accessor pseudocomponent that produces just the underlying component value+as opposed to 'Child' which also produces the parent entity.++For best performance, you should prefer 'ChildValue' over 'Child' if your+system is iterating over children and does not need the parent entities.+-} newtype ChildValue c = ChildValue c deriving (Eq, Show)-instance Component c => Component (ChildValue c) where++instance (Component c) => Component (ChildValue c) where   type Storage (ChildValue c) = ChildValueStore (Storage c)  newtype ChildValueStore s = ChildValueStore (Children s)@@ -216,12 +227,15 @@   getStore :: SystemT w m (Storage (ChildValue c))   getStore = ChildValueStore <$> getStore -instance ExplMembers m s => ExplMembers m (ChildValueStore s) where+instance (ExplMembers m s) => ExplMembers m (ChildValueStore s) where   {-# INLINE explMembers #-}   explMembers :: ChildValueStore s -> m (U.Vector Int)   explMembers (ChildValueStore (Children _ _ s)) = explMembers s+  {-# INLINE explMemberSet #-}+  explMemberSet :: ChildValueStore s -> m IntSet+  explMemberSet (ChildValueStore (Children _ _ s)) = explMemberSet s -instance ExplGet m s => ExplGet m (ChildValueStore s) where+instance (ExplGet m s) => ExplGet m (ChildValueStore s) where   {-# INLINE explExists #-}   explExists :: ChildValueStore s -> Int -> m Bool   explExists (ChildValueStore (Children _ _ s)) = explExists s@@ -231,24 +245,26 @@   explGet (ChildValueStore (Children _ _ s)) child =     ChildValue <$> explGet s child --- | Pseudocomponent that produces all child entities for a parent.------ A useful property of this pseudocomponent is that it may be destroyed, which--- does a cascading 'Apecs.System.destroy' on all of the parent's children:------ > -- Remove all of player 1 entity's hitboxes:--- > destroy player1 $ Proxy @(ChildList Hitbox)------ The cascading 'Apecs.System.destroy' behavior is provided for convenience,--- but note that if you assigned additional components to the child entities,--- those components will not be destroyed. In this case, you should destroy--- all components on the children explicitly, e.g.:------ > ChildList children :: ChildList Hitbox <- get player1--- > for_ children $ \child -> do--- >   destroy child $ Proxy @ComponentsToDestroy+{- | Pseudocomponent that produces all child entities for a parent.++A useful property of this pseudocomponent is that it may be destroyed, which+does a cascading 'Apecs.System.destroy' on all of the parent's children:++> -- Remove all of player 1 entity's hitboxes:+> destroy player1 $ Proxy @(ChildList Hitbox)++The cascading 'Apecs.System.destroy' behavior is provided for convenience,+but note that if you assigned additional components to the child entities,+those components will not be destroyed. In this case, you should destroy+all components on the children explicitly, e.g.:++> ChildList children :: ChildList Hitbox <- get player1+> for_ children $ \child -> do+>   destroy child $ Proxy @ComponentsToDestroy+-} newtype ChildList c = ChildList (NonEmpty Entity) deriving (Eq, Show)-instance Component c => Component (ChildList c) where++instance (Component c) => Component (ChildList c) where   type Storage (ChildList c) = ChildListStore (Storage c)  newtype ChildListStore s = ChildListStore (Children s)@@ -259,11 +275,15 @@   getStore :: SystemT w m (Storage (ChildList c))   getStore = ChildListStore <$> getStore -instance MonadIO m => ExplMembers m (ChildListStore s) where+instance (MonadIO m) => ExplMembers m (ChildListStore s) where   {-# INLINE explMembers #-}   explMembers :: ChildListStore s -> m (U.Vector Int)   explMembers (ChildListStore (Children parentToChildren _ _)) = do     liftIO $ U.fromList . M.keys <$> IORef.readIORef parentToChildren+  {-# INLINE explMemberSet #-}+  explMemberSet :: ChildListStore s -> m IntSet+  explMemberSet (ChildListStore (Children parentToChildren _ _)) =+    liftIO $ M.keysSet <$> IORef.readIORef parentToChildren  instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where   {-# INLINE explExists #-}@@ -278,10 +298,10 @@       Nothing -> error $ parentNotFound (typeRep @(Elem s)) parent       Just children -> pure $ ChildList children     where-    toNE :: Maybe IntSet -> Maybe (NonEmpty Entity)-    toNE mChildEnts-      | Just childEnts <- mChildEnts = NE.nonEmpty (Entity <$> S.elems childEnts)-      | otherwise = Nothing+      toNE :: Maybe IntSet -> Maybe (NonEmpty Entity)+      toNE mChildEnts+        | Just childEnts <- mChildEnts = NE.nonEmpty (Entity <$> S.elems childEnts)+        | otherwise = Nothing  instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (ChildListStore s) where   {-# INLINE explDestroy #-}

@@ -1,49 +1,54 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilies #-}  {-| Stability : experimental  This module is experimental, and its API might change between point releases. Use at your own risk.---}+-+-} module Apecs.Experimental.Components   ( Redirect (..)   , Head (..)   ) where +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U  import Apecs.Core --- | Pseudocomponent that when written to, actually writes @c@ to its entity argument.---   Can be used to write to other entities in a 'cmap'.+{- | Pseudocomponent that when written to, actually writes @c@ to its entity argument.+  Can be used to write to other entities in a 'cmap'.+-} data Redirect c = Redirect Entity c deriving (Eq, Show)-instance Component c => Component (Redirect c) where++instance (Component c) => Component (Redirect c) where   type Storage (Redirect c) = RedirectStore (Storage c)  newtype RedirectStore s = RedirectStore s type instance Elem (RedirectStore s) = Redirect (Elem s) -instance Has w m c => Has w m (Redirect c) where+instance (Has w m c) => Has w m (Redirect c) where   getStore = RedirectStore <$> getStore  instance (ExplSet m s) => ExplSet m (RedirectStore s) where   explSet (RedirectStore s) _ (Redirect (Entity ety) c) = explSet s ety c ---- | Pseudocomponent that can be read like any other component, but will only---   yield a single member when iterated over. Intended to be used as---   @cmap $ Head (...) -> ...@+{- | Pseudocomponent that can be read like any other component, but will only+  yield a single member when iterated over. Intended to be used as+  @cmap $ Head (...) -> ...@+-} newtype Head c = Head c deriving (Eq, Show)-instance Component c => Component (Head c) where++instance (Component c) => Component (Head c) where   type Storage (Head c) = HeadStore (Storage c)  newtype HeadStore s = HeadStore s type instance Elem (HeadStore s) = Head (Elem s) -instance Has w m c => Has w m (Head c) where+instance (Has w m c) => Has w m (Head c) where   getStore = HeadStore <$> getStore  instance (ExplGet m s) => ExplGet m (HeadStore s) where@@ -52,3 +57,6 @@  instance (ExplMembers m s) => ExplMembers m (HeadStore s) where   explMembers (HeadStore s) = U.take 1 <$> explMembers s+  explMemberSet (HeadStore s) = do+    members <- explMembers s+    pure $ if U.null members then mempty else IS.singleton (U.head members)

@@ -1,3 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ {-| Stability : experimental @@ -14,44 +22,43 @@ component. Among other things, the max count can be useful in deciding on @Cache@ sizing and the current count can be useful for debugging entity lifecycles. To retrieve the counts, use @withReactive readComponentCount@.- -}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}- module Apecs.Experimental.Reactive-  ( Reacts (..), Reactive, withReactive+  ( Reacts (..)+  , Reactive+  , withReactive   , Printer-  , EnumMap, enumLookup-  , OrdMap, ordLookup-  , IxMap, ixLookup-  , ComponentCounter, readComponentCount, ComponentCount(..)+  , EnumMap+  , enumLookup+  , OrdMap+  , ordLookup+  , IxMap+  , ixLookup+  , ComponentCounter+  , readComponentCount+  , ComponentCount (..)   ) where -import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Reader-import qualified Data.Array.IO        as A-import qualified Data.IntMap.Strict   as IM-import qualified Data.IntSet          as S-import           Data.IORef-import           Data.Ix-import qualified Data.Map.Strict      as M+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (lift)+import qualified Data.Array.IO as A+import Data.IORef+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as S+import Data.Ix+import qualified Data.Map.Strict as M -import           Apecs.Components-import           Apecs.Core+import Apecs.Components+import Apecs.Core --- | Class required by @Reactive@.---   Given some @r@ and update information about some component, will run a side-effect in monad @m@.---   Note that there are also instances for @(,)@.-class Monad m => Reacts m r where+{- | Class required by @Reactive@.+  Given some @r@ and update information about some component, will run a side-effect in monad @m@.+  Note that there are also instances for @(,)@.+-}+class (Monad m) => Reacts m r where   rempty :: m r-  react  :: Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()+  react :: Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()  -- | Wrapper for reactivity around some store s. data Reactive r s = Reactive r s@@ -59,76 +66,94 @@ type instance Elem (Reactive r s) = Elem s  -- | Performs an action with a reactive state token.-withReactive :: forall w m r s a.-             ( Component (Elem r)-             , Has w m (Elem r)-             , Storage (Elem r) ~ Reactive r s-             ) => (r -> m a) -> SystemT w m a+withReactive+  :: forall w m r s a+   . ( Component (Elem r)+     , Has w m (Elem r)+     , Storage (Elem r) ~ Reactive r s+     )+  => (r -> m a) -> SystemT w m a withReactive f = do   Reactive r (_ :: s) <- getStore-  lift$ f r+  lift $ f r  instance (Reacts m r, ExplInit m s) => ExplInit m (Reactive r s) where   explInit = liftM2 Reactive rempty explInit -instance (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ Elem r)-  => ExplSet m (Reactive r s) where+instance+  (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ Elem r)+  => ExplSet m (Reactive r s)+  where   {-# INLINE explSet #-}   explSet (Reactive r s) ety c = do     old <- explGet (MaybeStore s) ety     react (Entity ety) old (Just c) 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+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 -instance ExplGet m s => ExplGet m (Reactive r s) where+instance (ExplGet m s) => ExplGet m (Reactive r s) where   {-# INLINE explExists #-}   explExists (Reactive _ s) = explExists s-  {-# INLINE explGet    #-}-  explGet    (Reactive _ s) = explGet    s+  {-# INLINE explGet #-}+  explGet (Reactive _ s) = explGet s -instance ExplMembers m s => ExplMembers m (Reactive r s) where+instance (ExplMembers m s) => ExplMembers m (Reactive r s) where   {-# INLINE explMembers #-}   explMembers (Reactive _ s) = explMembers s+  {-# INLINE explMemberSet #-}+  explMemberSet (Reactive _ s) = explMemberSet s  -- | Prints a message to stdout every time a component is updated. data Printer c = Printer+ type instance Elem (Printer c) = c  instance (MonadIO m, Show c) => Reacts m (Printer c) where   {-# INLINE rempty #-}   rempty = return Printer   {-# INLINE react #-}-  react (Entity ety) (Just c) Nothing _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": destroyed component " ++ show c-  react (Entity ety) Nothing (Just c) _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": created component " ++ show c-  react (Entity ety) (Just old) (Just new) _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": update component " ++ show old ++ " to " ++ show new+  react (Entity ety) (Just c) Nothing _ =+    liftIO $+      putStrLn $+        "Entity " ++ show ety ++ ": destroyed component " ++ show c+  react (Entity ety) Nothing (Just c) _ =+    liftIO $+      putStrLn $+        "Entity " ++ show ety ++ ": created component " ++ show c+  react (Entity ety) (Just old) (Just new) _ =+    liftIO $+      putStrLn $+        "Entity " ++ show ety ++ ": update component " ++ show old ++ " to " ++ show new   react _ _ _ _ = return () --- | Allows you to look up entities by component value.---   Use e.g. @withReactive $ enumLookup True@ to retrieve a list of entities that have a @True@ component.---   Based on an @IntMap IntSet@ internally.+{- | Allows you to look up entities by component value.+  Use e.g. @withReactive $ enumLookup True@ to retrieve a list of entities that have a @True@ component.+  Based on an @IntMap IntSet@ internally.+-} newtype EnumMap c = EnumMap (IORef (IM.IntMap S.IntSet))  type instance Elem (EnumMap c) = c instance (MonadIO m, Enum c) => Reacts m (EnumMap c) where   {-# INLINE rempty #-}-  rempty = liftIO$ EnumMap <$> newIORef mempty+  rempty = liftIO $ EnumMap <$> newIORef mempty   {-# INLINE react #-}   react _ Nothing Nothing _ = return ()-  react (Entity ety) (Just c) Nothing (EnumMap ref) = liftIO$-    modifyIORef' ref (IM.adjust (S.delete ety) (fromEnum c))-  react (Entity ety) Nothing (Just c) (EnumMap ref) = liftIO$-    modifyIORef' ref (IM.insertWith mappend (fromEnum c) (S.singleton ety))-  react (Entity ety) (Just old) (Just new) (EnumMap ref) = liftIO$ do+  react (Entity ety) (Just c) Nothing (EnumMap ref) =+    liftIO $+      modifyIORef' ref (IM.adjust (S.delete ety) (fromEnum c))+  react (Entity ety) Nothing (Just c) (EnumMap ref) =+    liftIO $+      modifyIORef' ref (IM.insertWith mappend (fromEnum c) (S.singleton ety))+  react (Entity ety) (Just old) (Just new) (EnumMap ref) = liftIO $ do     modifyIORef' ref (IM.adjust (S.delete ety) (fromEnum old))     modifyIORef' ref (IM.insertWith mappend (fromEnum new) (S.singleton ety)) @@ -138,21 +163,24 @@   emap <- liftIO $ readIORef ref   return $ maybe [] (fmap Entity . S.toList) (IM.lookup (fromEnum c) emap) --- | Allows you to look up entities by component value.---   Based on a @Map c IntSet@ internally+{- | Allows you to look up entities by component value.+  Based on a @Map c IntSet@ internally+-} newtype OrdMap c = OrdMap (IORef (M.Map c S.IntSet))  type instance Elem (OrdMap c) = c instance (MonadIO m, Ord c) => Reacts m (OrdMap c) where   {-# INLINE rempty #-}-  rempty = liftIO$ OrdMap <$> newIORef mempty+  rempty = liftIO $ OrdMap <$> newIORef mempty   {-# INLINE react #-}   react _ Nothing Nothing _ = return ()-  react (Entity ety) (Just c) Nothing (OrdMap ref) = liftIO$-    modifyIORef' ref (M.adjust (S.delete ety) c)-  react (Entity ety) Nothing (Just c) (OrdMap ref) = liftIO$-    modifyIORef' ref (M.insertWith mappend c (S.singleton ety))-  react (Entity ety) (Just old) (Just new) (OrdMap ref) = liftIO$ do+  react (Entity ety) (Just c) Nothing (OrdMap ref) =+    liftIO $+      modifyIORef' ref (M.adjust (S.delete ety) c)+  react (Entity ety) Nothing (Just c) (OrdMap ref) =+    liftIO $+      modifyIORef' ref (M.insertWith mappend c (S.singleton ety))+  react (Entity ety) (Just old) (Just new) (OrdMap ref) = liftIO $ do     modifyIORef' ref (M.adjust (S.delete ety) old)     modifyIORef' ref (M.insertWith mappend new (S.singleton ety)) @@ -162,25 +190,28 @@   emap <- liftIO $ readIORef ref   return $ maybe [] (fmap Entity . S.toList) (M.lookup c emap) --- | Allows you to look up entities by component value.---   Based on an @IOArray c IntSet@ internally+{- | Allows you to look up entities by component value.+  Based on an @IOArray c IntSet@ internally+-} newtype IxMap c = IxMap (A.IOArray c S.IntSet)  {-# INLINE modifyArray #-}-modifyArray :: Ix i => A.IOArray i a -> i -> (a -> a) -> IO ()+modifyArray :: (Ix i) => A.IOArray i a -> i -> (a -> a) -> IO () modifyArray ref ix f = A.readArray ref ix >>= A.writeArray ref ix . f  type instance Elem (IxMap c) = c instance (MonadIO m, Ix c, Bounded c) => Reacts m (IxMap c) where   {-# INLINE rempty #-}-  rempty = liftIO$ IxMap <$> A.newArray (minBound, maxBound) mempty+  rempty = liftIO $ IxMap <$> A.newArray (minBound, maxBound) mempty   {-# INLINE react #-}   react _ Nothing Nothing _ = return ()-  react (Entity ety) (Just c) Nothing (IxMap ref) = liftIO$-    modifyArray ref c (S.delete ety)-  react (Entity ety) Nothing (Just c) (IxMap ref) = liftIO$-    modifyArray ref c (S.insert ety)-  react (Entity ety) (Just old) (Just new) (IxMap ref) = liftIO$ do+  react (Entity ety) (Just c) Nothing (IxMap ref) =+    liftIO $+      modifyArray ref c (S.delete ety)+  react (Entity ety) Nothing (Just c) (IxMap ref) =+    liftIO $+      modifyArray ref c (S.insert ety)+  react (Entity ety) (Just old) (Just new) (IxMap ref) = liftIO $ do     modifyArray ref old (S.delete ety)     modifyArray ref new (S.insert ety) @@ -189,57 +220,66 @@ ixLookup c = \(IxMap ref) -> do   liftIO $ fmap Entity . S.toList <$> A.readArray ref c --- | Tracks current and max counts of entities with a particular 'Component'.------ Note that if this is used in conjunction with a @Global@ store, produced--- counts will always be 0.+{- | Tracks current and max counts of entities with a particular 'Component'.++Note that if this is used in conjunction with a @Global@ store, produced+counts will always be 0.+-} newtype ComponentCounter c = ComponentCounter (IORef (ComponentCount c))  type instance Elem (ComponentCounter c) = c --- | A snapshot of the current and max counts of entities with a particular--- 'Component'.------ Produced via 'readComponentCount'.+{- | A snapshot of the current and max counts of entities with a particular+'Component'.++Produced via 'readComponentCount'.+-} data ComponentCount c = ComponentCount   { componentCountCurrent :: !Int-    -- ^ Represents how many entities existed with the 'Component' assigned at-    -- the time the snapshot was produced.+  {- ^ Represents how many entities existed with the 'Component' assigned at+  the time the snapshot was produced.+  -}   , componentCountMax :: !Int-    -- ^ Represents the max number of entities with the 'Component' assigned-    -- that coexisted, as observed at any point between system initialization-    -- and the time the snapshot was produced.-  } deriving (Eq, Show)+  {- ^ Represents the max number of entities with the 'Component' assigned+  that coexisted, as observed at any point between system initialization+  and the time the snapshot was produced.+  -}+  }+  deriving (Eq, Show) -instance MonadIO m => Reacts m (ComponentCounter c) where+instance (MonadIO m) => Reacts m (ComponentCounter c) where   {-# INLINE rempty #-}-  rempty = liftIO $ ComponentCounter <$> newIORef ComponentCount-    { componentCountCurrent = 0-    , componentCountMax = 0-    }+  rempty =+    liftIO $+      ComponentCounter+        <$> newIORef+          ComponentCount+            { componentCountCurrent = 0+            , componentCountMax = 0+            }    {-# INLINE react #-}   react _ent mOld mNew (ComponentCounter ref) =     case (mOld, mNew) of-      (Nothing, Just {}) -> go 1-      (Just {}, Nothing) -> go (-1)+      (Nothing, Just{}) -> go 1+      (Just{}, Nothing) -> go (-1)       _ignored -> pure ()     where-    go :: Int -> m ()-    go i =-      liftIO $ atomicModifyIORef' ref $ \cc ->-        let cur = componentCountCurrent cc + i-         in ( cc-                { componentCountCurrent = cur-                , componentCountMax = max cur $ componentCountMax cc-                }-            , ()-            )+      go :: Int -> m ()+      go i =+        liftIO $ atomicModifyIORef' ref $ \cc ->+          let cur = componentCountCurrent cc + i+          in ( cc+                 { componentCountCurrent = cur+                 , componentCountMax = max cur $ componentCountMax cc+                 }+             , ()+             )  {-# INLINE readComponentCount #-} readComponentCount   :: forall c m-   . MonadIO m+   . (MonadIO m)   => ComponentCounter c   -> m (ComponentCount c) readComponentCount (ComponentCounter ref) = liftIO $ readIORef ref

@@ -0,0 +1,92 @@+{-# LANGUAGE LambdaCase #-}++{-|+Stability: experimental++This module is experimental, and its API might change between point releases. Use at your own risk.++Utilities for persisting an apecs world across GHCi reloads using @foreign-store@.+This is intended for development workflows only — do not use in production.++__Important__: if you change your world's type (e.g. add or remove components),+you must call 'resetWorld' or restart GHCi. The foreign store is not type-safe+across type changes.++Typical usage:++@+mainDev :: IO ()+mainDev = runReloadable initWorld someSystem+@+-}+module Apecs.Experimental.Reload+  ( runReloadable+  , runReloadableAt+  , defaultStoreIndex+  , getOrInitWorld+  , storeWorld+  , resetWorld+  , Store+  ) where++import Data.Word (Word32)+import Foreign.Store (Store (..), lookupStore, readStore, writeStore)++import Apecs.Core (SystemT)+import Apecs.System (runSystem)++{- | Retrieve or initialize a world, then run a system in it.++@+main = runReloadable initWorld $ do+  newEntity (Position 0, Velocity 1)+  cmap $ \\(Position p, Velocity v) -> Position (p + v)+@+-}+{-# INLINE runReloadable #-}+runReloadable :: IO w -> SystemT w IO a -> IO a+runReloadable = runReloadableAt defaultStoreIndex++{- | Retrieve or initialize a world at a specified index, then run a system in it.++@+main = runReloadableAt 0 initWorld $ do+  newEntity (Position 0, Velocity 1)+  cmap $ \\(Position p, Velocity v) -> Position (p + v)+@+-}+runReloadableAt :: Word32 -> IO w -> SystemT w IO a -> IO a+runReloadableAt idx mkWorld sys =+  getOrInitWorld idx mkWorld >>= runSystem sys++{- | Default foreign store index (0). Sufficient when only one world+is used in a GHCi session. Use a different index if you need+multiple independent worlds.+-}+defaultStoreIndex :: Word32+defaultStoreIndex = 0++{- | Look up a world in the foreign store at the given index.+If one exists, return it. Otherwise, run the initialization+action, persist the result, and return it.+-}+getOrInitWorld :: Word32 -> IO w -> IO w+getOrInitWorld idx mkWorld =+  lookupStore idx >>= \case+    Nothing -> resetWorld idx mkWorld+    Just store -> readStore store++{- | Discard any persisted world at the given index, initialize+a fresh one, persist it, and return it.+-}+resetWorld :: Word32 -> IO w -> IO w+resetWorld idx mkWorld = do+  w <- mkWorld+  writeStore (Store idx) w+  return w++{- | Persist a world value at the given foreign store index,+overwriting any previous value.+-}+storeWorld :: Word32 -> w -> IO ()+storeWorld = writeStore . Store

@@ -1,37 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ {-| Stability: experimental  This module is experimental, and its API might change between point releases. Use at your own risk. -}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}- module Apecs.Experimental.Stores-  ( Pushdown(..), Stack(..)+  ( Pushdown (..)+  , Stack (..)   ) where -import Control.Monad.Reader+import Control.Monad.Trans.Reader import Data.Proxy import Data.Semigroup  import Apecs.Components (MaybeStore (..)) import Apecs.Core --- | Overrides a store to have history/pushdown semantics.---   Setting this store adds a new value on top of the stack.---   Destroying pops the stack.---   You can view the entire stack using the 'Stack' wrapper.+{- | Overrides a store to have history/pushdown semantics.+  Setting this store adds a new value on top of the stack.+  Destroying pops the stack.+  You can view the entire stack using the 'Stack' wrapper.+-} newtype Pushdown s c = Pushdown (s (Stack c))+ newtype Stack c = Stack {getStack :: [c]} deriving (Eq, Show, Functor, Applicative, Monad, Foldable, Monoid, Semigroup)  type instance Elem (Pushdown s c) = c@@ -40,30 +42,34 @@   explInit = Pushdown <$> explInit  pattern StackList :: c -> [c] -> Maybe (Stack c)-pattern StackList x xs = Just (Stack (x:xs))+pattern StackList x xs = Just (Stack (x : xs))  instance   ( Monad m   , ExplGet m (s (Stack c))   , Elem (s (Stack c)) ~ Stack c-  ) => ExplGet m (Pushdown s c) where-    explExists (Pushdown s) ety = f <$> explGet (MaybeStore s) ety-      where-        f (StackList _ _) = True-        f _               = False-    explGet (Pushdown s) ety = head . getStack <$> explGet s ety+  )+  => ExplGet m (Pushdown s c)+  where+  explExists (Pushdown s) ety = f <$> explGet (MaybeStore s) ety+    where+      f (StackList _ _) = True+      f _ = False+  explGet (Pushdown s) ety = head . getStack <$> explGet s ety  instance   ( Monad m   , ExplGet m (s (Stack c))   , ExplSet m (s (Stack c))   , Elem (s (Stack c)) ~ Stack c-  ) => ExplSet m (Pushdown s c) where-    explSet (Pushdown s) ety c = do-      ms <- explGet (MaybeStore s) ety-      let tail (StackList _ cs) = cs-          tail _                = []-      explSet s ety (Stack (c:tail ms))+  )+  => ExplSet m (Pushdown s c)+  where+  explSet (Pushdown s) ety c = do+    ms <- explGet (MaybeStore s) ety+    let tail (StackList _ cs) = cs+        tail _ = []+    explSet s ety (Stack (c : tail ms))  instance   ( Monad m@@ -71,19 +77,24 @@   , ExplSet m (s (Stack c))   , ExplDestroy m (s (Stack c))   , Elem (s (Stack c)) ~ Stack c-  ) => ExplDestroy m (Pushdown s c) where-    explDestroy (Pushdown s) ety = do-      mscs <- explGet (MaybeStore s) ety-      case mscs of-        StackList _ cs' -> explSet s ety (Stack cs')-        _               -> explDestroy s ety+  )+  => ExplDestroy m (Pushdown s c)+  where+  explDestroy (Pushdown s) ety = do+    mscs <- explGet (MaybeStore s) ety+    case mscs of+      StackList _ cs' -> explSet s ety (Stack cs')+      _ -> explDestroy s ety  instance   ( Monad m   , ExplMembers m (s (Stack c))   , Elem (s (Stack c)) ~ Stack c-  ) => ExplMembers m (Pushdown s c) where-    explMembers (Pushdown s) = explMembers s+  )+  => ExplMembers m (Pushdown s c)+  where+  explMembers (Pushdown s) = explMembers s+  explMemberSet (Pushdown s) = explMemberSet s  instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where   type Storage (Stack c) = StackStore (Storage c)@@ -97,26 +108,35 @@ instance   ( Elem (s (Stack c)) ~ Stack c   , ExplGet m (s (Stack c))-  ) => ExplGet m (StackStore (Pushdown s c)) where+  )+  => ExplGet m (StackStore (Pushdown s c))+  where   explExists (StackStore s) = explExists s   explGet (StackStore (Pushdown s)) = explGet s  instance   ( Elem (s (Stack c)) ~ Stack c-  , ExplSet     m (s (Stack c))+  , ExplSet m (s (Stack c))   , ExplDestroy m (s (Stack c))-  ) => ExplSet m (StackStore (Pushdown s c)) where+  )+  => 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 st = explSet s ety st  instance   ( Elem (s (Stack c)) ~ Stack c   , ExplDestroy m (s (Stack c))-  ) => ExplDestroy m (StackStore (Pushdown s c)) where+  )+  => ExplDestroy m (StackStore (Pushdown s c))+  where   explDestroy (StackStore (Pushdown s)) = explDestroy s  instance   ( Elem (s (Stack c)) ~ Stack c   , ExplMembers m (s (Stack c))-  ) => ExplMembers m (StackStore (Pushdown s c)) where+  )+  => ExplMembers m (StackStore (Pushdown s c))+  where   explMembers (StackStore (Pushdown s)) = explMembers s+  explMemberSet (StackStore (Pushdown s)) = explMemberSet s

@@ -2,62 +2,81 @@ Stability : experimental  This module is experimental, and its API might change between point releases. Use at your own risk.---}+-+-} module Apecs.Experimental.Util   ( -- * Spatial hashing     -- $hash-  quantize, flatten, inbounds, region, flatten',+    quantize+  , flatten+  , inbounds+  , region+  , flatten'   ) where -import Control.Applicative  (liftA2)+{- $hash+The following are helper functions for spatial hashing.+Your spatial hash is defined by two vectors; --- $hash--- The following are helper functions for spatial hashing.--- Your spatial hash is defined by two vectors;------   - The cell size vector contains real components and dictates---     how large each cell in your table is in world space units.---     It is used by @quantize@ to translate a world space coordinate into a table space index vector---   - The table size vector contains integral components and dictates how---     many cells your field consists of in each direction.---     It is used by @flatten@ to translate a table-space index vector into a flat integer+  - The cell size vector contains real components and dictates+    how large each cell in your table is in world space units.+    It is used by @quantize@ to translate a world space coordinate into a table space index vector+  - The table size vector contains integral components and dictates how+    many cells your field consists of in each direction.+    It is used by @flatten@ to translate a table-space index vector into a flat integer+-} --- | Quantize turns a world-space coordinate into a table-space coordinate by dividing---   by the given cell size and rounding towards negative infinity.+{- | Quantize turns a world-space coordinate into a table-space coordinate by dividing+  by the given cell size and rounding towards negative infinity.+-} {-# INLINE quantize #-}-quantize :: (Fractional (v a), Integral b, RealFrac a, Functor v)-         => v a -- ^ Quantization cell size-         -> v a -- ^ Vector to be quantized-         -> v b-quantize cell vec = floor <$> vec/cell+quantize+  :: (Fractional (v a), Integral b, RealFrac a, Functor v)+  => v a+  -- ^ Quantization cell size+  -> v a+  -- ^ Vector to be quantized+  -> v b+quantize cell vec = floor <$> vec / cell --- | Turns a table-space vector into an integral index, given some table size vector.---   Yields Nothing for out-of-bounds queries+{- | Turns a table-space vector into an integral index, given some table size vector.+  Yields Nothing for out-of-bounds queries+-} {-# INLINE flatten #-}-flatten :: (Applicative v, Integral a, Foldable v)-        => v a -- Field size vector-        -> v a -> Maybe a+flatten+  :: (Applicative v, Integral a, Foldable v)+  => v a -- Field size vector+  -> v a+  -> Maybe a flatten size vec = if inbounds size vec then Just (flatten' size vec) else Nothing  -- | Tests whether a vector is in the region given by 0 and the size vector (inclusive) {-# INLINE inbounds #-}-inbounds :: (Num a, Ord a, Applicative v, Foldable v)-         => v a -- Field size vector-         -> v a -> Bool-inbounds size vec = and (liftA2 (\v s -> v >= 0 && v <= s) vec size)+inbounds+  :: (Num a, Ord a, Applicative v, Foldable v)+  => v a -- Field size vector+  -> v a+  -> Bool+inbounds size vec = and ((\v s -> v >= 0 && v <= s) <$> vec <*> size) --- | For two table-space vectors indicating a region's bounds, gives a list of the vectors contained between them.---   This is useful for querying a spatial hash.+{- | For two table-space vectors indicating a region's bounds, gives a list of the vectors contained between them.+  This is useful for querying a spatial hash.+-} {-# INLINE region #-}-region :: (Enum a, Applicative v, Traversable v)-       => v a -- ^ Lower bound for the region-       -> v a -- ^ Higher bound for the region-       -> [v a]-region a b = sequence $ liftA2 enumFromTo a b+region+  :: (Enum a, Applicative v, Traversable v)+  => v a+  -- ^ Lower bound for the region+  -> v a+  -- ^ Higher bound for the region+  -> [v a]+region a b = sequence $ enumFromTo <$> a <*> b  -- | flatten, but yields garbage for out-of-bounds vectors. {-# INLINE flatten' #-}-flatten' :: (Applicative v, Integral a, Foldable v)-            => v a -- Field size vector-            -> v a -> a-flatten' size vec = foldr (\(n,x) acc -> n*acc + x) 0 (liftA2 (,) size vec)+flatten'+  :: (Applicative v, Integral a, Foldable v)+  => v a -- Field size vector+  -> v a+  -> a+flatten' size vec = foldr (\(n, x) acc -> n * acc + x) 0 $ (,) <$> size <*> vec

@@ -1,248 +1,24 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE Strict                #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Apecs.Stores-  ( Map, Cache, Unique,-    Global,-    Cachable,-    ReadOnly, setReadOnly, destroyReadOnly-    -- Register, regLookup+  ( Map+  , Cache+  , Unique+  , Global+  , Cachable+  , ReadOnly+  , setReadOnly+  , destroyReadOnly   ) where -import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Reader-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-import qualified Data.Vector.Unboxed         as U-import qualified Data.Vector.Unboxed.Mutable as UM-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))--type instance Elem (Map c) = c-instance MonadIO m => ExplInit m (Map c) where-  explInit = liftIO$ Map <$> newIORef 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-    Just c -> c-    notFound -> error $ unwords-      [ "Reading non-existent Map component"-      , show (typeRep notFound)-      , "for entity"-      , show ety-      ]-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}--instance MonadIO m => ExplSet m (Map c) where-  {-# INLINE explSet #-}-  explSet (Map ref) ety x = liftIO$-    modifyIORef' ref (M.insert ety x)--instance MonadIO m => ExplDestroy m (Map c) where-  {-# INLINE explDestroy #-}-  explDestroy (Map ref) ety = liftIO$-    modifyIORef' ref (M.delete ety)--instance MonadIO m => ExplMembers m (Map c) where-  {-# INLINE explMembers #-}-  explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref---- | A Unique contains zero or one component.---   Writing to it overwrites both the previous component and its owner.---   Its main purpose is to be a 'Map' optimized for when only ever one component inhabits it.-newtype Unique c = Unique (IORef (Maybe (Int, c)))-type instance Elem (Unique c) = c-instance MonadIO m => ExplInit m (Unique c) where-  explInit = liftIO$ Unique <$> newIORef Nothing--instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where-  {-# INLINE explGet #-}-  explGet (Unique ref) _ = liftIO$ flip fmap (readIORef ref) $ \case-    Just (_, c)  -> c-    notFound -> error $ unwords-      [ "Reading non-existent Unique component"-      , show (typeRep notFound)-      ]--  {-# INLINE explExists #-}-  explExists (Unique ref) ety = liftIO$ maybe False ((==ety) . fst) <$> readIORef ref--instance MonadIO m => ExplSet m (Unique c) where-  {-# INLINE explSet #-}-  explSet (Unique ref) ety c = liftIO$ writeIORef ref (Just (ety, c))--instance MonadIO m => ExplDestroy m (Unique c) where-  {-# INLINE explDestroy #-}-  explDestroy (Unique ref) ety = liftIO$ readIORef ref >>=-    mapM_ (flip when (writeIORef ref Nothing) . (==ety) . fst)--instance MonadIO m => ExplMembers m (Unique c) where-  {-# INLINE explMembers #-}-  explMembers (Unique ref) = liftIO$ flip fmap (readIORef 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.---   Querying a 'Global' at /any/ Entity yields this one component, effectively sharing the component between /all/ entities.------   A Global component can be read with @'get' 0@ or @'get' 1@ or even @'get' undefined@.---   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)-type instance Elem (Global c) = c-instance (Monoid c, MonadIO m) => ExplInit m (Global c) where-  {-# INLINE explInit #-}-  explInit = liftIO$ Global <$> newIORef mempty--instance MonadIO m => ExplGet m (Global c) where-  {-# INLINE explGet #-}-  explGet (Global ref) _ = liftIO$ readIORef ref-  {-# INLINE explExists #-}-  explExists _ _ = return True--instance MonadIO m => ExplSet m (Global c) where-  {-# INLINE explSet #-}-  explSet (Global ref) _ c = liftIO$ writeIORef ref 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.-class Cachable s-instance Cachable (Map s)-instance (KnownNat n, Cachable s) => Cachable (Cache n s)---- | A cache around another store.---   Caches store their members in a fixed-size vector, so read/write operations become O(1).---   Caches can provide huge performance boosts, especially when working with large numbers of components.------   The cache size is given as a type-level argument.------   Note that iterating over a cache is linear in cache size, so sparsely populated caches might /decrease/ performance.---   In general, the exact size of the cache does not matter as long as it reasonably approximates the number of components present.------   The cache uses entity (-2) internally to represent missing entities.---   If you manually manipulate Entity values, be careful that you do not use (-2)------   The actual cache is not necessarily the given argument, but the next biggest power of two.---   This is allows most operations to be expressed as bit masks, for a large potential performance boost.-data Cache (n :: Nat) s =-  Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s--cacheMiss :: t-cacheMiss = error "Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"--type instance Elem (Cache n s) = Elem s--instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where-  {-# INLINE explInit #-}-  explInit = do-    let n = fromIntegral$ natVal (Proxy @n) :: Int-        size = head . dropWhile (<n) $ iterate (`shiftL` 1) 1-        mask = size - 1-    tags <- liftIO$ UM.replicate size (-2)-    cache <- liftIO$ VM.replicate size cacheMiss-    child <- explInit-    return (Cache mask tags cache child)--instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where-  {-# INLINE explGet #-}-  explGet (Cache mask tags cache s) ety = do-    let index = ety .&. mask-    tag <- liftIO$ UM.unsafeRead tags index-    if tag == ety-       then liftIO$ VM.unsafeRead cache index-       else explGet s ety--  {-# INLINE explExists #-}-  explExists (Cache mask tags _ s) ety = do-    tag <- liftIO$ UM.unsafeRead tags (ety .&. mask)-    if tag == ety then return True else explExists s ety--instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where-  {-# INLINE explSet #-}-  explSet (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-    liftIO$ UM.unsafeWrite tags  index ety-    liftIO$ VM.unsafeWrite cache index x--instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where-  {-# INLINE explDestroy #-}-  explDestroy (Cache mask tags cache s) ety = do-    let index = ety .&. mask-    tag <- liftIO$ UM.unsafeRead tags (ety .&. mask)-    when (tag == ety) $ liftIO $ do-      UM.unsafeWrite tags  index (-2)-      VM.unsafeWrite cache index cacheMiss-    explDestroy s ety--instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where-  {-# INLINE explMembers #-}-  explMembers (Cache mask tags _ s) = do-    cached <- liftIO$ U.filter (/= (-2)) <$> U.freeze tags-    let etyFilter ety = (/= ety) <$> UM.unsafeRead tags (ety .&. mask)-    stored <- explMembers s >>= liftIO . U.filterM etyFilter-    return $! cached U.++ stored---- | Wrapper that makes a store read-only by hiding its 'ExplSet' and 'ExplDestroy' instances.---   This is primarily used to protect the 'EntityCounter' from accidental overwrites.---   Use 'setReadOnly' and 'destroyReadOnly' to override.-newtype ReadOnly s = ReadOnly s-type instance Elem (ReadOnly s) = Elem s--instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where-  explInit = ReadOnly <$> explInit--instance ExplGet m s => ExplGet m (ReadOnly s) where-  explExists (ReadOnly s) = explExists s-  explGet    (ReadOnly s) = explGet s-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}--instance ExplMembers m s => ExplMembers m (ReadOnly s) where-  {-# INLINE explMembers #-}-  explMembers (ReadOnly s) = explMembers s--setReadOnly :: forall w m s c.-  ( Has w m c-  , Storage c ~ ReadOnly s-  , Elem s ~ c-  , ExplSet m s-  ) => Entity -> c -> SystemT w m ()-setReadOnly (Entity ety) c = do-  ReadOnly s <- getStore-  lift $ explSet s ety c--destroyReadOnly :: forall w m s c.-  ( Has w m c-  , Storage c ~ ReadOnly s-  , Elem s ~ c-  , ExplDestroy m s-  ) => Entity -> Proxy c -> SystemT w m ()-destroyReadOnly (Entity ety) _ = do-  ReadOnly s :: Storage c <- getStore-  lift $ explDestroy s ety+import Apecs.Stores.Internal

@@ -0,0 +1,282 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Apecs.Stores.Internal+  ( Map (..)+  , Cache (..)+  , Unique (..)+  , Global (..)+  , Cachable+  , ReadOnly (..)+  , setReadOnly+  , destroyReadOnly+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (lift)+import Data.Bits (shiftL, (.&.))+import Data.IORef+import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as IS+import Data.Proxy+import Data.Typeable (Typeable, typeRep)+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM+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))++type instance Elem (Map c) = c+instance (MonadIO m) => ExplInit m (Map c) where+  explInit = liftIO $ Map <$> newIORef 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+    Just c -> c+    notFound ->+      error $+        unwords+          [ "Reading non-existent Map component"+          , show (typeRep notFound)+          , "for entity"+          , show ety+          ]+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}++instance (MonadIO m) => ExplSet m (Map c) where+  {-# INLINE explSet #-}+  explSet (Map ref) ety x =+    liftIO $+      modifyIORef' ref (M.insert ety x)++instance (MonadIO m) => ExplDestroy m (Map c) where+  {-# INLINE explDestroy #-}+  explDestroy (Map ref) ety =+    liftIO $+      modifyIORef' ref (M.delete ety)++instance (MonadIO m) => ExplMembers m (Map c) where+  {-# INLINE explMembers #-}+  explMembers (Map ref) = liftIO $ U.fromList . M.keys <$> readIORef ref+  {-# INLINE explMemberSet #-}+  explMemberSet (Map ref) = liftIO $ M.keysSet <$> readIORef ref++{- | A Unique contains zero or one component.+  Writing to it overwrites both the previous component and its owner.+  Its main purpose is to be a 'Map' optimized for when only ever one component inhabits it.+-}+newtype Unique c = Unique (IORef (Maybe (Int, c)))++type instance Elem (Unique c) = c+instance (MonadIO m) => ExplInit m (Unique c) where+  explInit = liftIO $ Unique <$> newIORef Nothing++instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where+  {-# INLINE explGet #-}+  explGet (Unique ref) _ = liftIO $ flip fmap (readIORef ref) $ \case+    Just (_, c) -> c+    notFound ->+      error $+        unwords+          [ "Reading non-existent Unique component"+          , show (typeRep notFound)+          ]++  {-# INLINE explExists #-}+  explExists (Unique ref) ety = liftIO $ maybe False ((== ety) . fst) <$> readIORef ref++instance (MonadIO m) => ExplSet m (Unique c) where+  {-# INLINE explSet #-}+  explSet (Unique ref) ety c = liftIO $ writeIORef ref (Just (ety, c))++instance (MonadIO m) => ExplDestroy m (Unique c) where+  {-# INLINE explDestroy #-}+  explDestroy (Unique ref) ety =+    liftIO $+      readIORef ref+        >>= mapM_ (flip when (writeIORef ref Nothing) . (== ety) . fst)++instance (MonadIO m) => ExplMembers m (Unique c) where+  {-# INLINE explMembers #-}+  explMembers (Unique ref) = liftIO $ flip fmap (readIORef ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> U.singleton ety+  {-# INLINE explMemberSet #-}+  explMemberSet (Unique ref) = liftIO $ flip fmap (readIORef ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> IS.singleton ety++{- | A 'Global' contains exactly one component.+  The initial value is 'mempty' from the component's 'Monoid' instance.+  Querying a 'Global' at /any/ Entity yields this one component, effectively sharing the component between /all/ entities.++  A Global component can be read with @'get' 0@ or @'get' 1@ or even @'get' undefined@.+  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)++type instance Elem (Global c) = c+instance (Monoid c, MonadIO m) => ExplInit m (Global c) where+  {-# INLINE explInit #-}+  explInit = liftIO $ Global <$> newIORef mempty++instance (MonadIO m) => ExplGet m (Global c) where+  {-# INLINE explGet #-}+  explGet (Global ref) _ = liftIO $ readIORef ref+  {-# INLINE explExists #-}+  explExists _ _ = return True++instance (MonadIO m) => ExplSet m (Global c) where+  {-# INLINE explSet #-}+  explSet (Global ref) _ c = liftIO $ writeIORef ref 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.+-}+class Cachable s++instance Cachable (Map s)+instance (KnownNat n, Cachable s) => Cachable (Cache n s)++{- | A cache around another store.+  Caches store their members in a fixed-size vector, so read/write operations become O(1).+  Caches can provide huge performance boosts, especially when working with large numbers of components.++  The cache size is given as a type-level argument.++  Note that iterating over a cache is linear in cache size, so sparsely populated caches might /decrease/ performance.+  In general, the exact size of the cache does not matter as long as it reasonably approximates the number of components present.++  The cache uses entity (-2) internally to represent missing entities.+  If you manually manipulate Entity values, be careful that you do not use (-2)++  The actual cache is not necessarily the given argument, but the next biggest power of two.+  This is allows most operations to be expressed as bit masks, for a large potential performance boost.+-}+data Cache (n :: Nat) s+  = Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s++cacheMiss :: t+cacheMiss = error "Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"++type instance Elem (Cache n s) = Elem s++instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where+  {-# INLINE explInit #-}+  explInit = do+    let+      n = fromIntegral $ natVal (Proxy @n) :: Int+      size = head . dropWhile (< n) $ iterate (`shiftL` 1) 1+      mask = size - 1+    tags <- liftIO $ UM.replicate size (-2)+    cache <- liftIO $ VM.replicate size cacheMiss+    child <- explInit+    return (Cache mask tags cache child)++instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where+  {-# INLINE explGet #-}+  explGet (Cache mask tags cache s) ety = do+    let index = ety .&. mask+    tag <- liftIO $ UM.unsafeRead tags index+    if tag == ety then+      liftIO $ VM.unsafeRead cache index+    else+      explGet s ety++  {-# INLINE explExists #-}+  explExists (Cache mask tags _ s) ety = do+    tag <- liftIO $ UM.unsafeRead tags (ety .&. mask)+    if tag == ety then return True else explExists s ety++instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where+  {-# INLINE explSet #-}+  explSet (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+    liftIO $ UM.unsafeWrite tags index ety+    liftIO $ VM.unsafeWrite cache index x++instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where+  {-# INLINE explDestroy #-}+  explDestroy (Cache mask tags cache s) ety = do+    let index = ety .&. mask+    tag <- liftIO $ UM.unsafeRead tags (ety .&. mask)+    when (tag == ety) $ liftIO $ do+      UM.unsafeWrite tags index (-2)+      VM.unsafeWrite cache index cacheMiss+    explDestroy s ety++instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where+  {-# INLINE explMembers #-}+  explMembers (Cache mask tags _ s) = do+    cached <- liftIO $ U.filter (/= (-2)) <$> U.freeze tags+    let etyFilter ety = (/= ety) <$> UM.unsafeRead tags (ety .&. mask)+    stored <- explMembers s >>= liftIO . U.filterM etyFilter+    return $! cached U.++ stored++{- | Wrapper that makes a store read-only by hiding its 'ExplSet' and 'ExplDestroy' instances.+  Use 'setReadOnly' and 'destroyReadOnly' to override.+-}+newtype ReadOnly s = ReadOnly s++type instance Elem (ReadOnly s) = Elem s++instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where+  explInit = ReadOnly <$> explInit++instance (ExplGet m s) => ExplGet m (ReadOnly s) where+  explExists (ReadOnly s) = explExists s+  explGet (ReadOnly s) = explGet s+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}++instance (ExplMembers m s) => ExplMembers m (ReadOnly s) where+  {-# INLINE explMembers #-}+  explMembers (ReadOnly s) = explMembers s+  {-# INLINE explMemberSet #-}+  explMemberSet (ReadOnly s) = explMemberSet s++setReadOnly+  :: forall w m s c+   . ( Has w m c+     , Storage c ~ ReadOnly s+     , Elem s ~ c+     , ExplSet m s+     )+  => Entity -> c -> SystemT w m ()+setReadOnly (Entity ety) c = do+  ReadOnly s <- getStore+  lift $ explSet s ety c++destroyReadOnly+  :: forall w m s c+   . ( Has w m c+     , Storage c ~ ReadOnly s+     , Elem s ~ c+     , ExplDestroy m s+     )+  => Entity -> Proxy c -> SystemT w m ()+destroyReadOnly (Entity ety) _ = do+  ReadOnly s :: Storage c <- getStore+  lift $ explDestroy s ety

@@ -1,15 +1,16 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE Strict                #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}  module Apecs.System where -import           Control.Monad-import           Control.Monad.Reader-import           Data.Proxy-import qualified Data.Vector.Unboxed  as U+import Control.Monad+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader+import Data.Proxy+import qualified Data.Vector.Unboxed as U  import Apecs.Components () import Apecs.Core@@ -17,7 +18,7 @@ -- | Run a system in a game world {-# INLINE runSystem #-} runSystem :: SystemT w m a -> w -> m a-runSystem sys = runReaderT (unSystem sys)+runSystem = runReaderT  -- | Run a system in a game world {-# INLINE runWith #-}@@ -26,35 +27,36 @@  -- | Read a Component {-# INLINE get #-}-get :: forall w m c. Get w m c => Entity -> SystemT w m c+get :: forall w m c. (Get w m c) => Entity -> SystemT w m c get (Entity ety) = do   s :: Storage c <- getStore-  lift$ explGet s ety+  lift $ explGet s ety  -- | Writes a Component to a given Entity. Will overwrite existing Components. {-# INLINE set #-}-set, ($=) :: forall w m c. Set w m c => Entity -> c -> SystemT w m ()+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+  lift $ explSet s ety x  -- | @set@ operator ($=) = set+ infixr 2 $=  -- | Returns whether the given entity has component @c@ {-# INLINE exists #-}-exists :: forall w m c. Get w m c => Entity -> Proxy c -> SystemT w m 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-  lift$ explExists s ety+  lift $ explExists s ety  -- | Destroys component @c@ for the given entity. {-# INLINE destroy #-}-destroy :: forall w m c. Destroy w m c => Entity -> Proxy c -> SystemT w m ()+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+  lift $ explDestroy s ety  -- | Applies a function, if possible. {-# INLINE modify #-}@@ -62,7 +64,7 @@ modify (Entity ety) f = do   sx :: Storage cx <- getStore   sy :: Storage cy <- getStore-  lift$ do+  lift $ do     possible <- explExists sx ety     when possible $ do       x <- explGet sx ety@@ -70,29 +72,35 @@  -- | @modify@ operator ($~) = modify+ infixr 2 $~  -- | Maps a function over all entities with a @cx@, and writes their @cy@. {-# INLINE cmap #-}-cmap :: forall w m cx cy. (Get w m cx, Members w m cx, Set w m cy)-     => (cx -> cy) -> SystemT w m ()+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-  lift$ do+  lift $ do     sl <- explMembers sx-    U.forM_ sl $ \ e -> do+    U.forM_ sl $ \e -> do       r <- explGet sx e       explSet sy e (f r) --- | Conditional @cmap@, that first tests whether the argument satisfies some property.---   The entity needs to have both a cx and cp component.+{- | Conditional @cmap@, that first tests whether the argument satisfies some property.+  The entity needs to have both a cx and cp component.+-} {-# INLINE cmapIf #-}-cmapIf :: forall w m cp cx cy.-  ( Get w m cx-  , Get w m cp-  , Members w m cx-  , Set w m cy )+cmapIf+  :: forall w m cp cx cy+   . ( Get w m cx+     , Get w m cp+     , Members w m cx+     , Set w m cy+     )   => (cp -> Bool)   -> (cx -> cy)   -> SystemT w m ()@@ -100,9 +108,9 @@   sp :: Storage cp <- getStore   sx :: Storage cx <- getStore   sy :: Storage cy <- getStore-  lift$ do-    sl <- explMembers (sx,sp)-    U.forM_ sl $ \ e -> do+  lift $ do+    sl <- explMembers (sx, sp)+    U.forM_ sl $ \e -> do       p <- explGet sp e       when (cond p) $ do         x <- explGet sx e@@ -110,64 +118,80 @@  -- | Monadically iterates over all entites with a @cx@, and writes their @cy@. {-# INLINE cmapM #-}-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+  :: 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 <- lift$ explMembers sx-  U.forM_ sl $ \ e -> do-    x <- lift$ explGet sx e+  sl <- lift $ explMembers sx+  U.forM_ sl $ \e -> do+    x <- lift $ explGet sx e     y <- sys x-    lift$ explSet sy e y+    lift $ explSet sy e y  -- | Monadically iterates over all entites with a @cx@ {-# INLINE cmapM_ #-}-cmapM_ :: forall w m c. (Get w m c, Members w m c)-       => (c -> SystemT w m ()) -> SystemT w m ()+cmapM_+  :: forall w m c+   . (Get w m c, Members w m c)+  => (c -> SystemT w m ()) -> SystemT w m () cmapM_ sys = do   s :: Storage c <- getStore-  sl <- lift$ explMembers s-  U.forM_ sl $ \ ety -> do-    x <- lift$ explGet s ety+  sl <- lift $ explMembers s+  U.forM_ sl $ \ety -> do+    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.+{- | 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 m c a. (Members w m c, Get w m c)-      => (a -> c -> a) -> a -> SystemT w m 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 <- lift$ explMembers s-  lift$ 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.+{- | Monadically fold over the game world.+  Strict in the accumulator.+-} {-# INLINE cfoldM #-}-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+  :: 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 <- lift$ explMembers s+  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.+{- | Monadically fold over the game world.+  Strict in the accumulator.+-} {-# INLINE cfoldM_ #-}-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_+  :: 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 <- lift$ explMembers s+  sl <- lift $ explMembers s   U.foldM'_ (\a e -> lift (explGet s e) >>= sys a) a0 sl --- | Collect matching components into a list by using the specified test/process function.---   You can use this to preprocess data before returning.---   And you can do a test here that depends on data from multiple components.---   Pass "Just" to simply collect all the items.+{- | Collect matching components into a list by using the specified test/process function.+  You can use this to preprocess data before returning.+  And you can do a test here that depends on data from multiple components.+  Pass "Just" to simply collect all the items.+-} {-# INLINE collect #-}-collect :: forall components w m a. (Get w m components, Members w m components)-        => (components -> Maybe a)-        -> SystemT w m [a]+collect+  :: forall components w m a+   . (Get w m components, Members w m components)+  => (components -> Maybe a)+  -> SystemT w m [a] collect f = cfold (\acc -> maybe acc (: acc) . f) []

@@ -1,59 +1,177 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE TypeFamilies #-}  module Apecs.TH   ( makeWorld   , makeWorldNoEC   , makeWorldAndComponents+  , makeWorldDestructible+  , makeWorldEnumerable   , makeMapComponents   , makeMapComponentsFor+  , hasStoreInstance+  , makeInstanceFold+  , mkFoldT+  , mkTupleT+  , mkEitherT   ) where -import           Control.Monad-import           Control.Monad.Reader (asks)-import           Language.Haskell.TH+import Control.Monad (filterM)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Reader (asks)+import qualified Data.Kind as TL+import Data.Traversable (for)+import Language.Haskell.TH -import           Apecs.Core-import           Apecs.Stores-import           Apecs.Util           (EntityCounter)+import Apecs.Core+import Apecs.Stores+import Apecs.Util (EntityCounter) -genName :: String -> Q Name-genName s = mkName . show <$> newName s+type family WorldInitConstraints cs (m :: TL.Type -> TL.Type) :: TL.Constraint where+  WorldInitConstraints () m = ()+  WorldInitConstraints (c, cs) m = (ExplInit m (Storage c), WorldInitConstraints cs m) --- | Same as 'makeWorld', but does not include an 'EntityCounter'---   You don't typically want to use this, but it's exposed in case you know what you're doing.+{- | Same as 'makeWorld', but does not include an 'EntityCounter'+  You don't typically want to use this, but it's exposed in case you know what you're doing.+-} makeWorldNoEC :: String -> [Name] -> Q [Dec] makeWorldNoEC worldName cTypes = do-  cTypesNames <- forM cTypes $ \t -> do-    rec <- genName "rec"-    return (ConT t, rec)+  let+    world = mkName worldName+    initWorldName = mkName $ "init" ++ worldName+  -- Data type decl+  data_decl <- do+    let fields =+          [ bangType+              (bang noSourceUnpackedness sourceStrict)+              [t|Storage $(conT ty)|]+          | ty <- cTypes+          ]+    dataD (pure []) world [] Nothing [normalC world fields] []+  -- World initialization+  init_world <- do+    m <- newName "m"+    let+      mkNestedTupleT [] = ConT ''()+      mkNestedTupleT (x : xs) = AppT (AppT (TupleT 2) (ConT x)) (mkNestedTupleT xs)+      compTupleTy = mkNestedTupleT cTypes+    let constraints =+          [ AppT (ConT ''MonadIO) (VarT m)+          , AppT (AppT (ConT ''WorldInitConstraints) compTupleTy) (VarT m)+          ]+    sig <- sigD initWorldName $ forallT [] (pure constraints) [t|$(varT m) $(conT world)|]+    decl <-+      funD+        initWorldName+        [ clause+            []+            ( normalB $+                foldl+                  (\e _ -> [|$e <*> explInit|])+                  [|pure $(conE world)|]+                  cTypes+            )+            []+        ]+    pure [sig, decl]+  -- Has instances+  instances <- for (enumerate cTypes) $ \(i, t) -> do+    x <- newName "x"+    let pat =+          conP+            world+            [ if j == i then varP x else wildP+            | (j, _) <- enumerate cTypes+            ]+    [d|+      instance (Monad m) => Has $(conT world) m $(conT t) where+        getStore = let field $pat = $(varE x) in asks field+      |] -  let wld = mkName worldName-      has = ''Has-      sys = 'SystemT-      m = VarT $ mkName "m"-      wldDecl = DataD [] wld [] Nothing [RecC wld records] []+  pure $ data_decl : concat (init_world : instances)+  where+    enumerate :: [a] -> [(Int, a)]+    enumerate = zip [0 ..] -      makeRecord (t,n) = (n, Bang NoSourceUnpackedness SourceStrict, ConT ''Storage `AppT` t)-      records = makeRecord <$> cTypesNames+makeWorldDestructible :: String -> [Name] -> Q [Dec]+makeWorldDestructible worldName cTypes = do+  -- World-wide collections for particular types+  let skip = ["Global", "ReadOnly"]+  let m = ConT ''IO+  destructible <- filterM (hasStoreInstance skip ''ExplDestroy m) cTypes+  fmap pure $ makeInstanceFold mkTupleT (worldName ++ "Destructible") destructible -      makeInstance (t,n) =-        InstanceD Nothing [ConT ''Monad `AppT` m] (ConT has `AppT` ConT wld `AppT` m `AppT` t)-          [ FunD 'getStore [Clause []-              (NormalB$ ConE sys `AppE` (VarE 'asks `AppE` VarE n))-            [] ]-          ]+makeWorldEnumerable :: String -> [Name] -> Q [Dec]+makeWorldEnumerable worldName cTypes = do+  -- World-wide collections for particular types+  let skip = ["Global", "ReadOnly"]+  let m = ConT ''IO+  enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes+  fmap pure $ makeInstanceFold mkEitherT (worldName ++ "Enumerable") enumerable -      initWorldName = mkName $ "init" ++ worldName-      initSig = SigD initWorldName (AppT (ConT ''IO) (ConT wld))-      initDecl = FunD initWorldName [Clause []-        (NormalB$ iterate (\wE -> AppE (AppE (VarE '(<*>)) wE) (VarE 'explInit)) (AppE (VarE 'return) (ConE wld)) !! length records)-        [] ]+mkTupleT :: [Type] -> Type+mkTupleT [] = ConT ''()+mkTupleT [t] = t+mkTupleT ts+  | len <= 8 = foldl AppT (TupleT len) ts+  | otherwise = foldl AppT (TupleT 8) (take 7 ts ++ [mkTupleT (drop 7 ts)])+  where+    len = length ts -      hasDecl = makeInstance <$> cTypesNames+mkEitherT :: [Type] -> Type+mkEitherT = mkFoldT ''Either ''() -  return $ wldDecl : initSig : initDecl : hasDecl+mkFoldT :: Name -> Name -> [Type] -> Type+mkFoldT _con nil [] = ConT nil+mkFoldT _con _nil [t] = t+mkFoldT con nil (t : ts) = AppT (AppT (ConT con) t) (mkFoldT con nil ts) +makeInstanceFold :: ([Type] -> Type) -> String -> [Name] -> Q Dec+makeInstanceFold foldT synName cTypes =+  tySynD (mkName synName) [] . pure $+    foldT $+      map ConT cTypes++{- | Resolve storage type and check for an instance like @ExplThis m (Map Position)@++Can be used to pre-filter component lists for 'makeInstanceFold'.+-}+hasStoreInstance+  :: [String]+  -- ^ Skip those stores+  -> Name+  -- ^ Class name (ExplThis)+  -> Type+  -- ^ @m@ var like @ConT ''IO@+  -> Name+  -- ^ component type name+  -> Q Bool+hasStoreInstance skip cls mType cType = do+  storageT <- resolveStorageType cType+  case storageT of+    Just (AppT (ConT store) _stored)+      | nameBase store `elem` skip -> pure False+    Just resolved -> isInstance cls [mType, resolved]+    Nothing -> pure False++{- | Resolve the @Storage@ type family for a component type.++On GHC < 9.2, @isInstance@ does not reduce type family applications,+so we need to resolve @Storage ty@ before passing it to @isInstance@.+-}+resolveStorageType :: Name -> Q (Maybe Type)+resolveStorageType ty = do+  insts <- reifyInstances ''Storage [ConT ty]+  pure $ case insts of+#if MIN_VERSION_template_haskell(2,15,0)+    [TySynInstD (TySynEqn _ _ rhs)] -> Just rhs+#else+    [TySynInstD _ (TySynEqn _ rhs)] -> Just rhs+#endif+    _ -> Nothing+ -- | Creates 'Component' instances with 'Map' stores makeMapComponents :: [Name] -> Q [Dec] makeMapComponents = mapM makeMapComponent@@ -64,9 +182,10 @@ -- | Allows customization of the store to be used. For example, the base 'Map' or an STM Map. makeMapComponentFor :: Name -> Name -> Q Dec makeMapComponentFor store comp = do-  let ct = pure $ ConT comp-      st = pure $ ConT store-  head <$> [d| instance Component $ct where type Storage $ct = $st $ct |]+  let+    ct = pure $ ConT comp+    st = pure $ ConT store+  head <$> [d|instance Component $ct where type Storage $ct = $st $ct|]  makeMapComponentsFor :: Name -> [Name] -> Q [Dec] makeMapComponentsFor store = mapM (makeMapComponentFor store)@@ -78,7 +197,7 @@   cdecls <- makeMapComponents cTypes   return $ wdecls ++ cdecls -{-|+{- |  The typical way to create a @world@ record, associated 'Has' instances, and initialization function. @@ -94,7 +213,6 @@ > > initMyWorld :: IO MyWorld > initMyWorld = MyWorld <$> initStore <*> initStore <*> ... <*> initStore- -} makeWorld :: String -> [Name] -> Q [Dec] makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])

@@ -0,0 +1,232 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies    #-}++module Apecs.TH.Tags+  ( makeTaggedComponents+  , makeComponentTags+  , makeComponentSum+  , makeTagLookup+  , makeTagFromSum+  , makeGetTags+  , makeCountComponents+  , makeHasTagsInstance+  ) where++import           Control.Monad        (filterM)+import           Control.Monad.Trans.Class (lift)+import qualified Data.Vector.Unboxed  as U+import           Language.Haskell.TH++import Apecs.Core+import Apecs.Tags+import Apecs.TH (hasStoreInstance)++makeTaggedComponents :: String -> [Name] -> Q [Dec]+makeTaggedComponents worldName cTypes = do+  tags <- makeComponentTags tagType tagPrefix cTypes+  sums <- makeComponentSum sumType sumPrefix cTypes+  lookupFun <- makeTagLookup (Just ''Maybe) lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes+  getFun <- makeTagLookup Nothing getFunName worldName tagType tagPrefix sumType sumPrefix cTypes+  toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes++  let skip = ["Global", "ReadOnly"]+  let m = ConT ''IO+  existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes++  getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing+  hasTagsInst <- makeHasTagsInstance worldName tagType getTagsFunName existing++  enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes+  countComps <- makeCountComponents countCompsFunName worldName tagType tagPrefix enumerable++  pure $ concat+    [ tags+    , sums+    , lookupFun+    , getFun+    , toTag+    , getTags+    , hasTagsInst+    , countComps+    ]+  where+    tagType = worldName ++ "Tag"+    tagPrefix = "T"+    sumType = worldName ++ "Sum"+    sumPrefix = "S"+    lookupFunName = "lookup" ++ worldName ++ "Tag"+    getFunName = "get" ++ worldName ++ "Tag"+    tagFromSumFunName = "tag" ++ sumType+    getTagsFunName = "get" ++ worldName ++ "Tags"+    countCompsFunName = "count" ++ worldName ++ "Components"++-- | Creates an Enum of component tags+makeComponentTags :: String -> String -> [Name] -> Q [Dec]+makeComponentTags typeName consPrefix cTypes = pure [decl]+  where+    decl = DataD [] (mkName typeName) [] Nothing cons derivs+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes+    derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ]++-- | Creates a sum type of components+makeComponentSum :: String -> String -> [Name] -> Q [Dec]+makeComponentSum typeName consPrefix cTypes = pure [decl]+  where+    decl = DataD [] (mkName typeName) [] Nothing cons derivs+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes+    derivs = [ DerivClause Nothing [ConT ''Show] ]++makeTagLookup :: Maybe Name -> String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec]+makeTagLookup lookupWrapper funName worldName tagType tagPrefix sumType sumPrefix cTypes = do+  m <- newName "m"+  sig <- forallCompClsSig fName ''Get worldN m cTypes+    [t|+      Entity ->+      $(conT (mkName tagType)) ->+      SystemT $(conT worldN) $(varT m) $(wrapResult $ conT (mkName sumType))+    |]+  e <- newName "e"+  matches <- mapM (makeMatch e) cTypes+  t <- newName "t"+  let body = caseE (varE t) (map pure matches)+  decl <- funD fName [clause [varP e, varP t] (normalB body) []]+  pure [sig, decl]+  where+    (wrapResult, wrapCons) =+      case lookupWrapper of+        Nothing -> (id, id)+        Just funType ->+          ( appT (conT funType)+          , \sumConstr -> [| fmap $sumConstr |]+          )++    makeMatch e cType = match (conP tagCon []) (normalB matchBody) []+      where+        matchBody = [| $(wrapCons $ conE sumCon) <$> get $(varE e) |]+        tagCon = mkName (tagPrefix ++ nameBase cType)+        sumCon = mkName (sumPrefix ++ nameBase cType)+    fName = mkName funName+    worldN = mkName worldName++makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec]+makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do+  s <- newName "s"++  sig <- sigD fName [t| $(conT sumN) -> $(conT tagN) |]++  matches <- mapM makeMatch cTypes+  let body = caseE (varE s) (map pure matches)+  decl <- funD fName [clause [varP s] (normalB body) []]+  pure [sig, decl]+  where+    makeMatch cType = match (conP sumCon [wildP]) (normalB (conE tagCon)) []+      where+        tagCon = mkName (tagPrefix ++ nameBase cType)+        sumCon = mkName (sumPrefix ++ nameBase cType)+    fName = mkName funName+    tagN  = mkName tagType+    sumN  = mkName sumType++-- | For each component type, get store and use explExists on the given entity+makeGetTags :: String -> String -> String -> String -> [Name] -> Q [Dec]+makeGetTags funName worldName tagType tagPrefix cTypes = do+  m <- newName "m"+  sig <- forallCompClsSig fName ''Get worldN m cTypes+    [t|+      Entity ->+      SystemT $(conT worldN) $(varT m) [$(conT $ mkName tagType)]+    |]+  e <- newName "e"+  stmts <- mapM (makeStmt m e) cTypes+  decl <- funD fName [clause [varP e] (bodyS stmts) []]+  pure [sig, decl]+  where+    fName = mkName funName+    worldN = mkName worldName+    makeStmt m e cType = bindS (varP tagName) body+      where+        tagName = mkName ("tag_" ++ nameBase cType)+        tagCon = mkName (tagPrefix ++ nameBase cType)+        body = [|+          do+            s <- getStore :: SystemT $(conT worldN) $(varT m) (Storage $(conT cType))+            has <- lift $ explExists s (unEntity $(varE e))+            pure [$(conE tagCon) | has]+          |]+    bodyS stmts = normalB . doE $ map pure stmts ++ [resultE]+      where+        tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes+        resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames++-- | Generates a standalone @type instance WTag World = WorldTag@ and a+--   @HasTags World m@ instance delegating @entityTags@ to the generated+--   @getWorldTags@ function.+makeHasTagsInstance :: String -> String -> String -> [Name] -> Q [Dec]+makeHasTagsInstance worldName tagType getTagsFunName cTypes = do+  m <- newName "m"+  instDec <- instanceD+    ((:) <$> [t| Monad $(varT m) |] <*> worldConstraints ''Get worldN m cTypes)+    [t| HasTags $(conT worldN) $(varT m) |]+    [ valD+          (varP 'entityTags)+          (normalB . varE $ mkName getTagsFunName)+          []+      ]++  let tySynDec =+#if MIN_VERSION_template_haskell(2,15,0)+        TySynInstD $ TySynEqn Nothing (ConT ''WTag `AppT` ConT worldN) (ConT tagN)+#else+        TySynInstD ''WTag $ TySynEqn [ConT worldN] (ConT tagN)+#endif+  pure [tySynDec, instDec]+  where+    worldN = mkName worldName+    tagN = mkName tagType++-- | For each component type with ExplMembers, count the number of entities that have that component.+makeCountComponents :: String -> String -> String -> String -> [Name] -> Q [Dec]+makeCountComponents funName worldName tagType tagPrefix cTypes = do+  m <- newName "m"+  sig <- forallCompClsSig fName ''Members worldN m cTypes+    [t| SystemT $(conT worldN) $(varT m) [($(conT tagN), Int)] |]+  stmts <- mapM (makeStmt m) cTypes+  decl <- funD fName [clause [] (bodyS stmts) []]+  pure [sig, decl]+  where+    fName = mkName funName+    tagN = mkName tagType+    worldN = mkName worldName+    makeStmt m cType = bindS (varP countName) body+      where+        countName = mkName ("count_" ++ nameBase cType)+        tagCon = mkName (tagPrefix ++ nameBase cType)+        body = [|+          do+            s <- getStore :: SystemT $(conT (mkName worldName)) $(varT m) (Storage $(conT cType))+            members <- lift $ explMembers s+            pure ($(conE tagCon), U.length members)+          |]+    bodyS stmts = normalB . doE $ map pure stmts ++ [resultE]+      where+        countNames = map (varE . mkName . ("count_" ++) . nameBase) cTypes+        resultE = noBindS . appE (varE 'pure) $ listE countNames++-- | Build a @f :: forall m. (Cls World m C1, ...) => body@ type signature+forallCompClsSig :: Name -> Name -> Name -> Name -> [Name] -> Q Type -> Q Dec+forallCompClsSig fName cls worldN m cTypes mkBody =+  sigD fName $ forallT [mkPlainTV m] (worldConstraints cls worldN m cTypes) mkBody++worldConstraints :: Name -> Name -> Name -> [Name] -> Q Cxt+worldConstraints cls worldN m = traverse $ \c ->+  [t| $(conT cls) $(conT worldN) $(varT m) $(conT c) |]++#if MIN_VERSION_template_haskell(2,17,0)+mkPlainTV :: Name -> TyVarBndr Specificity+mkPlainTV n = PlainTV n SpecifiedSpec+#else+mkPlainTV :: Name -> TyVarBndr+mkPlainTV = PlainTV+#endif

@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Apecs.Tags where++import Apecs.Core (Entity (..), SystemT)+import qualified Data.IntSet as IS+import qualified Data.Map.Strict as M+import qualified Data.Set as S++{- | The type of tags for a world, e.g. @WTag MyWorld = MyWorldTag@.+  Standalone so that multiple @HasTags w m@ instances share one equation.+-}+type family WTag w++{- | @HasTags w m@ means that world @w@ has a tag system generated by @makeTaggedComponents@.+  Provides a way to query component tags for entities, dispatching on the world type @w@.+-}+class (Monad m) => HasTags w m where+  entityTags :: Entity -> SystemT w m [WTag w]++{- | Count entities grouped by their distinct component combination.++Takes the world's entity member set and uses 'entityTags' from the+'HasTags' class to query each entity's tags. Returns a map from tag sets+to entity counts.+-}+countCombinations+  :: (HasTags w m, Enum (WTag w), Ord (WTag w))+  => IS.IntSet+  -- ^ Entity IDs to census+  -> SystemT w m (M.Map (S.Set (WTag w)) Int)+countCombinations entities = do+  tagSets <- mapM poll (IS.toList entities)+  let counts = M.fromListWith (+) [(ts, 1 :: Int) | ts <- tagSets]+  pure $ M.mapKeysMonotonic (S.fromList . map toEnum . IS.toList) counts+  where+    poll eid = do+      tags <- entityTags (Entity eid)+      pure $! IS.fromList (map fromEnum tags)

@@ -1,68 +1,124 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- For Data.Semigroup compatibility--{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE Strict                     #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}+-- For Data.Semigroup compatibility+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Apecs.Util (-  -- * Utility-  runGC, global,+module Apecs.Util+  ( -- * Utility+    runGC+  , global -  -- * EntityCounter-  EntityCounter(..), nextEntity, newEntity, newEntity_,-) where+    -- * EntityCounter+  , EntityCounter (..)+  , nextEntity+  , newEntity+  , newEntity_+  , nextEntityIO+  , Maybify+  ) where -import           Control.Applicative  (liftA2)-import           Control.Monad.IO.Class-import           Control.Monad.Reader-import           Data.Monoid-import           Data.Semigroup-import           System.Mem           (performMajorGC)+import Control.Applicative (liftA2)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (lift)+import Data.IORef+import qualified Data.IntSet as IS+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.Semigroup+import qualified Data.Set as S+import System.Mem (performMajorGC) -import           Apecs.Core-import           Apecs.Stores-import           Apecs.System+import Apecs.Core+import Apecs.Stores+import qualified Apecs.Stores.Internal as Stores+import Apecs.System  -- | Convenience entity, for use in places where the entity value does not matter, i.e. a global store. global :: Entity global = Entity (-1) --- | Component used by newEntity to track the number of issued entities.---   Automatically added to any world created with @makeWorld@+{- | Component used by newEntity to track the number of issued entities.+  Automatically added to any world created with @makeWorld@+-} newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Semigroup, Monoid, Eq, Show)  instance Component EntityCounter where   type Storage EntityCounter = ReadOnly (Global EntityCounter) --- | Bumps the EntityCounter and yields its value+{- | Atomically bumps the EntityCounter and yields its value.+  Relatively slower than nextEntity, but unsafeIOToSTM-safe.+-}+{-# INLINE nextEntityIO #-}+nextEntityIO :: (Has w IO EntityCounter) => SystemT w IO Entity+nextEntityIO = do+  Stores.ReadOnly (Stores.Global ecRef) <- getStore+  liftIO $ atomicModifyIORef' ecRef $ \(EntityCounter (Sum c)) ->+    ( EntityCounter (Sum $ c + 1)+    , Entity c+    )++{- | Bumps the EntityCounter and yields its value.++Not thread-safe.+-} {-# INLINE nextEntity #-} nextEntity :: (MonadIO m, Get w m EntityCounter) => SystemT w m Entity-nextEntity = do EntityCounter n <- get global-                setReadOnly global (EntityCounter $ n+1)-                return (Entity . getSum $ n)+nextEntity = do+  EntityCounter n <- get global+  setReadOnly global (EntityCounter $ n + 1)+  return (Entity . getSum $ n) --- | Writes the given components to a new entity, and yields that entity.--- The return value is often ignored.+{- | Writes the given components to a new entity, and yields that entity.+The return value is often ignored.+-} {-# INLINE newEntity #-}-newEntity :: (MonadIO m, Set w m c, Get w m EntityCounter)-          => c -> SystemT w m Entity-newEntity c = do ety <- nextEntity-                 set ety c-                 return ety+newEntity+  :: (MonadIO m, Set w m c, Get w m EntityCounter)+  => c -> SystemT w m Entity+newEntity c = do+  ety <- nextEntity+  set ety c+  return ety --- | Writes the given components to a new entity without yelding the result.--- Used mostly for convenience.+{- | Writes the given components to a new entity without yelding the result.+Used mostly for convenience.+-} {-# INLINE newEntity_ #-}-newEntity_ :: (MonadIO m, Set world m component, Get world m EntityCounter)-           => component -> SystemT world m ()+newEntity_+  :: (MonadIO m, Set world m component, Get world m EntityCounter)+  => component -> SystemT world m () newEntity_ component = do   entity <- nextEntity   set entity component  -- | Explicitly invoke the garbage collector-runGC :: MonadIO m => SystemT w m ()+runGC :: (MonadIO m) => SystemT w m () runGC = liftIO performMajorGC++{- | Wrap tuple elements in Maybe.++This allows to safely `get` component packs generated by @makeInstanceFold mkTupleT@.+-}+type family Maybify t where+  Maybify (Maybe a) = Maybe a+  Maybify () = ()+  Maybify (a, b) =+    (Maybify a, Maybify b)+  Maybify (a, b, c) =+    (Maybify a, Maybify b, Maybify c)+  Maybify (a, b, c, d) =+    (Maybify a, Maybify b, Maybify c, Maybify d)+  Maybify (a, b, c, d, e) =+    (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e)+  Maybify (a, b, c, d, e, f) =+    (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f)+  Maybify (a, b, c, d, e, f, g) =+    (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f, Maybify g)+  Maybify (a, b, c, d, e, f, g, h) =+    (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f, Maybify g, Maybify h)+  Maybify a = Maybe a

@@ -1,37 +1,38 @@-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}--{-# OPTIONS_GHC -w #-}--import qualified Control.Exception           as E-import           Control.Monad-import qualified Data.Foldable               as F-import qualified Data.IntSet                 as S-import           Data.IORef-import           Data.List                   ((\\), delete, nub, sort)-import qualified Data.Vector.Unboxed         as U-import           Test.QuickCheck-import           Test.QuickCheck.Monadic-import           Text.Printf                 (printf)+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans -Wno-unused-top-binds #-} -import           Apecs-import           Apecs.Core-import           Apecs.Experimental.Children-import           Apecs.Experimental.Reactive-import           Apecs.Experimental.Stores-import           Apecs.Stores-import           Apecs.Util+import qualified Control.Exception as E+import Control.Monad+import qualified Data.Foldable as F+import qualified Data.IntSet as S+import Data.List (delete, nub, sort, (\\))+import qualified Data.Map.Strict as M+import qualified Data.Set as Set+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Text.Printf (printf) -type Vec = (Double, Double)+import Apecs+import Apecs.Core+import Apecs.Experimental.Children+import Apecs.Experimental.Reactive+import Apecs.Experimental.Stores+import Apecs.TH+import Apecs.TH.Tags+import Apecs.Tags+import Apecs.Util  -- Preamble instance Arbitrary Entity where@@ -40,18 +41,23 @@ assertSys :: IO w -> System w Bool -> Property assertSys initW sys = monadicIO $ run (initW >>= runSystem sys) >>= assert -genericSetGet :: forall w c.-  ( ExplGet IO (Storage c)-  , ExplSet IO (Storage c)-  , ExplDestroy IO (Storage c)-  , Has w IO c-  , Eq c-  , Arbitrary c )+genericSetGet+  :: forall w c+   . ( ExplGet IO (Storage c)+     , ExplSet IO (Storage c)+     , ExplDestroy IO (Storage c)+     , Has w IO c+     , Eq c+     , Arbitrary c+     )   => IO w   -> c-  -> [(Entity, c)] -> [Entity]-  -> Entity -> c-  -> [(Entity, c)] -> [Entity]+  -> [(Entity, c)]+  -> [Entity]+  -> Entity+  -> c+  -> [(Entity, c)]+  -> [Entity]   -> Property genericSetGet initSys _ sets1 dels1 ety c sets2 dels2 = do   assertSys initSys $ do@@ -60,24 +66,30 @@     forM_ dels1 $ flip destroy (Proxy @c)     set ety c     forM_ (filter ((/= ety) . fst) sets2) $ uncurry set-    forM_ (filter (/= ety)         dels2) $ flip destroy (Proxy @c)+    forM_ (filter (/= ety) dels2) $ flip destroy (Proxy @c)     c' <- get ety     return (c == c') -genericSetSet :: forall w c.-  ( ExplGet IO (Storage c)-  , ExplSet IO (Storage c)-  , ExplDestroy IO (Storage c)-  , Has w IO c-  , Eq c-  , Arbitrary c )+genericSetSet+  :: forall w c+   . ( ExplGet IO (Storage c)+     , ExplSet IO (Storage c)+     , ExplDestroy IO (Storage c)+     , Has w IO c+     , Eq c+     , Arbitrary c+     )   => IO w   -> c-  -> [(Entity, c)] -> [Entity]-  -> Entity -> c-  -> [(Entity, c)] -> [Entity]+  -> [(Entity, c)]+  -> [Entity]+  -> Entity   -> c-  -> [(Entity, c)] -> [Entity]+  -> [(Entity, c)]+  -> [Entity]+  -> c+  -> [(Entity, c)]+  -> [Entity]   -> Property genericSetSet initSys _ sets1 dels1 ety c1 sets2 dels2 c2 sets3 dels3 = do   assertSys initSys $ do@@ -86,10 +98,10 @@     forM_ dels1 $ flip destroy (Proxy @c)     set ety c1     forM_ (filter ((/= ety) . fst) sets2) $ uncurry set-    forM_ (filter (/= ety)         dels2) $ flip destroy (Proxy @c)+    forM_ (filter (/= ety) dels2) $ flip destroy (Proxy @c)     set ety c2     forM_ (filter ((/= ety) . fst) sets3) $ uncurry set-    forM_ (filter (/= ety)         dels3) $ flip destroy (Proxy @c)+    forM_ (filter (/= ety) dels3) $ flip destroy (Proxy @c)     c' <- get ety     return (c2 == c') @@ -97,10 +109,16 @@ newtype MapInt = MapInt Int deriving (Eq, Show, Arbitrary) instance Component MapInt where type Storage MapInt = Map MapInt makeWorld "Simple" [''MapInt]+makeWorldDestructible "Simple" [''MapInt]  prop_setGetMap = genericSetGet initSimple (undefined :: MapInt) prop_setSetMap = genericSetSet initSimple (undefined :: MapInt) +prop_destroyAll ety = assertSys initSimple $ do+  set ety (MapInt 1)+  destroy ety (Proxy @SimpleDestructible)+  not <$> exists ety (Proxy @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)@@ -111,9 +129,9 @@  prop_cacheUnique :: [CacheInt] -> [Entity] -> [(Entity, CacheInt)] -> Property prop_cacheUnique eInit eDel eSet = assertSys initCached $ do-  mapM newEntity eInit-  mapM (flip set (Not @CacheInt)) eDel-  mapM (uncurry set) eSet+  mapM_ newEntity eInit+  mapM_ (flip set (Not @CacheInt)) eDel+  mapM_ (uncurry set) eSet   es <- cfold (\a (_ :: CacheInt, Entity e) -> e : a) []   pure $ es == nub es @@ -127,9 +145,145 @@  makeWorld "Tuples" [''T1, ''T2, ''T3] -prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))-prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))+newtype G1 = G1 () deriving (Eq, Show, Arbitrary, Semigroup, Monoid)+instance Component G1 where type Storage G1 = Global G1 +-- Tests Enumerable class+makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]+makeWorldEnumerable "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]+makeWorldDestructible "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]+makeTaggedComponents "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]++-- Generate a (T1, T2, T3) tuple in a contrived way+-- (that allows processing component lists when placed in external file)+pure <$> makeInstanceFold mkTupleT "WorldEnumerableShowable" [''T1, ''T2, ''T3]++worldEntityIds :: System WorldEnumerable S.IntSet+worldEntityIds = do+  s :: Storage WorldEnumerableEnumerable <- getStore+  explMemberSet s++prop_enumerable :: [Entity] -> [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property+prop_enumerable dels t12s t3s = assertSys initWorldEnumerable $ do+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2+  forM_ t3s $ \(e, t3) -> set e t3++  let expectedBefore = S.fromList (map (unEntity . fst) t12s ++ map (unEntity . fst) t3s)+  actualBefore <- worldEntityIds++  everything <- forM (S.toList actualBefore) (get . Entity)+  let it = show @[Maybify WorldEnumerableShowable] everything+  guard (length it > 0)++  forM_ dels $ \e -> destroy e (Proxy @WorldEnumerableDestructible)++  let expectedAfter = expectedBefore `S.difference` S.fromList (map unEntity dels)+  actualAfter <- worldEntityIds+  return (expectedBefore == actualBefore && expectedAfter == actualAfter)++prop_tags_lookup :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property+prop_tags_lookup t12s t3s = assertSys initWorldEnumerable $ do+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2+  forM_ t3s $ \(e, t3) -> set e t3++  entities <- worldEntityIds++  eav <- fmap M.fromList . forM (map Entity $ S.toList entities) $ \e -> do+    tagged <- forM [minBound .. maxBound] $ \t -> fmap (t,) <$> lookupWorldEnumerableTag e t+    pure (e, M.fromList [(t, v) | Just (t, v) <- tagged])++  let it = show (eav :: M.Map Entity (M.Map WorldEnumerableTag WorldEnumerableSum))+  guard (length it > 0)++  pure True++prop_tags_get :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property+prop_tags_get t12s t3s = assertSys initWorldEnumerable $ do+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2+  forM_ t3s $ \(e, t3) -> set e t3++  entities <- worldEntityIds++  eav <- fmap M.fromList . forM (map Entity $ S.toList entities) $ \e -> do+    tags <- entityTags e+    tagged <- forM tags $ \t -> (t,) <$> getWorldEnumerableTag e t+    pure (e, M.fromList tagged)++  let it = show (eav :: M.Map Entity (M.Map WorldEnumerableTag WorldEnumerableSum))+  guard (length it > 0)++  pure True++prop_tags_list :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property+prop_tags_list t12s t3s = assertSys initWorldEnumerable $ do+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2+  forM_ t3s $ \(e, t3) -> set e t3++  -- arbitrary will produce overlapping entity sets for t12s and t3s+  -- the correct set of components for each entity is known at runtime+  let has_t12s = S.fromList (map (unEntity . fst) t12s)+  let has_t3s = S.fromList (map (unEntity . fst) t3s)++  forM_ (S.toList $ has_t12s <> has_t3s) $ \ety -> do+    let t12 = [[TT1, TT2] | ety `S.member` has_t12s]+    let t3 = [[TT3] | ety `S.member` has_t3s]+    let expected =+          -- XXX: matching the order is important.+          -- getWorldEnumerableTags will iterate in the "constructor order"+          -- derived from the filtered component type list.+          concat (t12 ++ t3)+    tags <- entityTags $ Entity ety+    unless (tags == expected) $ do+      error $ show (tags, expected)++  pure True++prop_count_components :: [(Entity, T1)] -> [(Entity, T2)] -> [(Entity, T3)] -> Property+prop_count_components t1s t2s t3s = assertSys initWorldEnumerable $ do+  forM_ t1s $ uncurry set+  forM_ t2s $ uncurry set+  forM_ t3s $ uncurry set++  counts <- countWorldEnumerableComponents+  let countMap = M.fromList counts++  let expectedT1 = length $ nub $ map fst t1s+  let expectedT2 = length $ nub $ map fst t2s+  let expectedT3 = length $ nub $ map fst t3s++  -- G1 is Global and should not appear in counts+  return $+    M.lookup TT1 countMap == Just expectedT1+      && M.lookup TT2 countMap == Just expectedT2+      && M.lookup TT3 countMap == Just expectedT3+      && M.lookup TG1 countMap == Nothing++prop_count_combinations :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property+prop_count_combinations t12s t3s = assertSys initWorldEnumerable $ do+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2+  forM_ t3s $ \(e, t3) -> set e t3++  entities <- worldEntityIds+  combos <- countCombinations entities++  let+    has_t12s = S.fromList (map (unEntity . fst) t12s)+    has_t3s = S.fromList (map (unEntity . fst) t3s)+    tags ety =+        (if ety `S.member` has_t12s then [TT1, TT2] else [])+          ++ (if ety `S.member` has_t3s then [TT3] else [])+  let expected =+        M.fromListWith+          (+)+          [ (Set.fromList (tags ety), 1 :: Int)+          | ety <- S.toList (has_t12s <> has_t3s)+          ]++  return $ combos == expected++prop_setGetTuple = genericSetGet initTuples (undefined :: (T1, T2, T3))+prop_setSetTuple = genericSetSet initTuples (undefined :: (T1, T2, T3))+ -- Tests Reactive store properties newtype TestEnum = TestEnum Bool deriving (Eq, Show, Bounded, Enum, Arbitrary) instance Component TestEnum where type Storage TestEnum = Reactive (EnumMap TestEnum) (Map TestEnum)@@ -140,20 +294,21 @@ prop_setSetReactive = genericSetSet initReactiveWld (undefined :: TestEnum) prop_lookupValid :: [(Entity, TestEnum)] -> [Entity] -> Property prop_lookupValid writes deletes = assertSys initReactiveWld $ do-  forM_ writes  $ uncurry set+  forM_ writes $ uncurry set   forM_ deletes $ flip destroy (Proxy @TestEnum)    let getAll = cfold (flip (:)) [] :: SystemT ReactiveWld IO [(TestEnum, Entity)]-  et <- fmap snd . filter ((== TestEnum True ) . fst) <$> getAll+  et <- fmap snd . filter ((== TestEnum True) . fst) <$> getAll   ef <- fmap snd . filter ((== TestEnum False) . fst) <$> getAll    rt <- withReactive $ enumLookup (TestEnum True)   rf <- withReactive $ enumLookup (TestEnum False) -  return (  sort rt == sort et-         && sort rf == sort ef-         && all (`notElem` ef) et-         )+  return+    ( sort rt == sort et+        && sort rf == sort ef+        && all (`notElem` ef) et+    )  -- Tests Reactive component counting newtype TestCount = TestCount Bool deriving (Eq, Show, Bounded, Enum, Arbitrary)@@ -165,19 +320,21 @@ prop_setSetReactiveCount = genericSetSet initReactiveCountWld (undefined :: TestCount) prop_reactiveCounts :: [(Entity, TestCount)] -> [Entity] -> Property prop_reactiveCounts writes deletes = assertSys initReactiveCountWld $ do-  forM_ writes  $ uncurry set+  forM_ writes $ uncurry set   forM_ deletes $ flip destroy (Proxy @TestCount)    count <- withReactive $ readComponentCount @TestCount -  return $ count == ComponentCount-    { componentCountCurrent = length existingEnts-    , componentCountMax = length writeEnts-    }+  return $+    count+      == ComponentCount+        { componentCountCurrent = length existingEnts+        , componentCountMax = length writeEnts+        }   where-  existingEnts = writeEnts \\ deleteEnts-  writeEnts = nub $ sort $ fst <$> writes-  deleteEnts = nub $ sort deletes+    existingEnts = writeEnts \\ deleteEnts+    writeEnts = nub $ sort $ fst <$> writes+    deleteEnts = nub $ sort deletes  -- Tests Pushdown newtype StackInt = StackInt Int deriving (Eq, Show, Arbitrary)@@ -193,8 +350,10 @@  prop_setGetChild = genericSetGet initChildTest (undefined :: (T1, Child T2)) prop_setSetChild = genericSetSet initChildTest (undefined :: (T1, Child T2))--- | This instance is only for the generic tests. It hard-codes each generated--- @Child T2@ component value with the global entity as the parent.++{- | This instance is only for the generic tests. It hard-codes each generated+@Child T2@ component value with the global entity as the parent.+-} instance Arbitrary (Child T2) where   arbitrary = Child <$> pure global <*> arbitrary @@ -214,48 +373,59 @@     forM_ children $ \child -> do       Child p t2 :: Child T2 <- get child       unless (p == parent) $ do-        liftIO $ E.throwIO $ ChildrenEx $-          printf "Child entity %d's parent of %d does not match set parent of %d"-            (unEntity child)-            (unEntity p)-            (unEntity parent)+        liftIO $+          E.throwIO $+            ChildrenEx $+              printf+                "Child entity %d's parent of %d does not match set parent of %d"+                (unEntity child)+                (unEntity p)+                (unEntity parent)       unless (t2 `elem` t2s) $ do-        liftIO $ E.throwIO $ ChildrenEx $-          printf-            "Child entity %d's component value of %s is not present in the input %s"-            (unEntity child)-            (show t2)-            (show t2s)+        liftIO $+          E.throwIO $+            ChildrenEx $+              printf+                "Child entity %d's component value of %s is not present in the input %s"+                (unEntity child)+                (show t2)+                (show t2s)     -- Fetch the child entity list from the parent entity and check its validity.     ChildList children' :: ChildList T2 <- get parent     unless (sort children == sort (F.toList children')) $ do-      liftIO $ E.throwIO $ ChildrenEx $-        printf-          "Mismatch between fetched child list (%s) and created child entities (%s)"-          (show $ sort $ F.toList children')-          (show $ sort children)+      liftIO $+        E.throwIO $+          ChildrenEx $+            printf+              "Mismatch between fetched child list (%s) and created child entities (%s)"+              (show $ sort $ F.toList children')+              (show $ sort children)     -- Reparent the first child entity in this group to be under the global entity.     let child1 = head children     modify child1 $ \(ChildValue t2) -> Child @T2 global t2     -- Check that the first child entity's parent was actually updated.-    Child child1Parent child1T2 :: Child T2 <- get child1+    Child child1Parent _child1T2 :: Child T2 <- get child1     unless (child1Parent == global) $ do-      liftIO $ E.throwIO $ ChildrenEx $-        printf-          "Reparented child entity %d should have been under global entity but is under %d"-          (unEntity child1)-          (unEntity child1Parent)+      liftIO $+        E.throwIO $+          ChildrenEx $+            printf+              "Reparented child entity %d should have been under global entity but is under %d"+              (unEntity child1)+              (unEntity child1Parent)     -- Check that the original parent no longer sees the reparented child as     -- its own child.     get parent >>= \case       Nothing -> pure () -- Parent only had 1 child, and this child just reparented.       Just (ChildList children'' :: ChildList T2) -> do         unless (sort (delete child1 children) == sort (F.toList children'')) $ do-          liftIO $ E.throwIO $ ChildrenEx $-            printf-              "Mismatch between fetched child list (%s) and modified child entities (%s)"-              (show $ sort $ F.toList children'')-              (show $ sort children)+          liftIO $+            E.throwIO $+              ChildrenEx $+                printf+                  "Mismatch between fetched child list (%s) and modified child entities (%s)"+                  (show $ sort $ F.toList children'')+                  (show $ sort children)    -- Check that the global entity's children have component values aligning   -- with the first T2 value in each group of the input list, as the first@@ -265,19 +435,26 @@   forM_ (zip (sort $ F.toList children) $ fmap (head . getNonEmpty . snd) writes) $ \(child, expT2) -> do     ChildValue t2 :: ChildValue T2 <- get child     unless (t2 == expT2) $ do-      liftIO $ E.throwIO $ ChildrenEx $-        "Child component value mismatch within those entities reparented under the global entity"+      liftIO $+        E.throwIO $+          ChildrenEx $+            "Child component value mismatch within those entities reparented under the global entity"    -- Check that a cascading destroy works.   destroy global $ Proxy @(ChildList T2)   get global >>= \case     Nothing -> pure () -- Expected case - there's no child list as they were all just destroyed.     Just (ChildList children' :: ChildList T2) -> do-      liftIO $ E.throwIO $ ChildrenEx $-        printf "Left over child entities (%s) after cascade destroy on the global entity"-          (show $ F.toList children')+      liftIO $+        E.throwIO $+          ChildrenEx $+            printf+              "Left over child entities (%s) after cascade destroy on the global entity"+              (show $ F.toList children')    return True  return []++main :: IO Bool main = $quickCheckAll