apecs 0.9.5 → 0.9.6

raw patch · 12 files changed

+582/−21 lines, 12 filesdep +unliftio-coredep ~containersnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: unliftio-core

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• README.md +1/−0
• apecs.cabal +4/−2
• src/Apecs.hs +45/−1
• src/Apecs/Core.hs +3/−1
• src/Apecs/Experimental/Children.hs +308/−0
• src/Apecs/Experimental/Reactive.hs +65/−2
• src/Apecs/Experimental/Stores.hs +2/−1
• src/Apecs/Stores.hs +2/−1
• src/Apecs/TH.hs +10/−9
• src/Apecs/Util.hs +2/−2
• test/Main.hs +122/−2

@@ -1,3 +1,21 @@+## [0.9.6]+### Changed+- (#110) Relax upper bound on `mtl`: 2.3 -> 2.4+- (#117) Fix TH symbol leaking, fixing (#116)+- (#121) Properly export `Printer` from `Apecs.Experimental.Reactive`+- (#121) Fix haddocks for `Apecs.Experimental.Reactive`+- (#125) Force `IntMap` in `ExplDestroy` instance for `Map`+- (#128) Use `SystemT` instead of `System` in `runGC` type signature+- (#131) Enable `-XTypeOperators` to prevent GHC warnings+### Added+- (#121) `ComponentCounter`+- (#123) `SystemT` `MonadUnliftIO` instance+- (#126) Export `cmapIf` from main `Apecs` module+- (#130) Docs for performance considerations when reading composite components +- (#132) `Apecs.Experimental.Children`+### Removed+- (#112) Custom setup for C sources+ ## [0.9.5] ### Added - (#99) `collect`

@@ -14,6 +14,7 @@ ### Links - [documentation on hackage](https://hackage.haskell.org/package/apecs/docs/Apecs.html) - [tutorial](https://github.com/jonascarpay/apecs/blob/master/examples/Shmup.md) and other [examples](https://github.com/jonascarpay/apecs/tree/master/examples)+- community chat at [`#apecs` on the haskell gamedev discord](https://discord.gg/vxpWtBA) or [`#haskell-game:matrix.org`](https://matrix.to/#/#haskell-game:matrix.org)  ##### Games/articles - [Notakto](https://github.com/Ashe/Notakto/), and [associated blog post/apecs tutorial](https://aas.sh/blog/notakto-a-haskell-game-with-apecs-and-raylib/) by [@Ashe](https://github.com/Ashe)

@@ -1,5 +1,5 @@ name:               apecs-version:            0.9.5+version:            0.9.6 homepage:           https://github.com/jonascarpay/apecs#readme license:            BSD3 license-file:       LICENSE@@ -27,6 +27,7 @@     Apecs.Components     Apecs.Core     Apecs.Experimental.Components+    Apecs.Experimental.Children     Apecs.Experimental.Reactive     Apecs.Experimental.Stores     Apecs.Experimental.Util@@ -42,8 +43,9 @@     , base              >=4.9    && <5     , containers        >=0.5    && <0.8     , exceptions        >=0.10.0 && <0.11-    , mtl               >=2.2    && <2.3+    , mtl               >=2.2    && <2.4     , template-haskell  >=2.12   && <3+    , unliftio-core     >=0.2.0.1 && <0.3     , vector            >=0.11   && <0.14    ghc-options:      -Wall

@@ -15,8 +15,10 @@     get, set, ($=),     destroy, exists,     modify, ($~),-    cmap,  cmapM,  cmapM_,+    cmap, cmapIf, cmapM, cmapM_,     cfold, cfoldM, cfoldM_, collect,+  -- ** Performance+  -- $performance    -- * Other     runSystem, runWith,@@ -37,3 +39,45 @@ 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.

@@ -8,11 +8,13 @@ {-# 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 @@ -28,7 +30,7 @@ --   * 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)+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  deriving instance Monad m => MonadReader w (SystemT w m)

@@ -0,0 +1,308 @@+{-|+Stability: experimental++This module is experimental, and its API might change between point releases.+Use at your own risk.++The default relation between an entity and a component value is one to zero+or one. The entity may or may not have a value for the component, but if the+component value exists, it belongs to an entity. This module enables setting+multiple "child" component values rooted under the same "parent" entity,+providing a one to many relation: the parent entity has zero or more child+values of the component type. Concretely, these component values are of type+'Child' @c@, belong to their own separate entities, and are explicitly linked+to the parent entity.++Ad-hoc child relationships may be established without using this module by+including a parent 'Entity' in your component's type, but this is limiting in+regards to traversing the relationship. Systems concerned with the relationship+may only start from the child entities' component(s) and then fetch the parent+entity's component(s). By expressing the relationship using this module, you get+support for iteration over the parent-child relationship in whichever way is+more convenient for your systems, i.e. you can map over child entities using the+'Child' component then fetch the child entity's parent component(s) as needed,+or you can map over the parent entities' 'ChildList' component then fetch the+child entities' component(s) as needed.++Some example use cases for this module:++- Parent entity has a position defined in world space and child entities have+data relative to the parent's position e.g. hitboxes, sprite animations, etc.+- Parent entity is a leader and child entities are squad members e.g. a+necromancer can summon skeletons++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(..)+    -- * Pseudocomponents+  , ChildValue(..)+  , ChildList(..)+  ) where++import Apecs.Core+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Foldable (for_)+import Data.IORef (IORef)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.List.NonEmpty (NonEmpty)+import Type.Reflection (TypeRep, Typeable, typeRep)++import qualified Data.IORef as IORef+import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S+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.+data Child c = Child !Entity !c deriving (Eq, Show)+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.+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+  {-# INLINE explInit #-}+  explInit :: m (Children s)+  explInit = do+    childrenDelegate <- explInit+    liftIO $ do+      childrenParentToChildren <- IORef.newIORef M.empty+      childrenChildToParent <- IORef.newIORef M.empty+      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++instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where+  {-# INLINE explGet #-}+  explGet :: Children s -> Int -> m (Child (Elem s))+  explGet (Children _ childToParent s) child = do+    liftIO (M.lookup child <$> IORef.readIORef childToParent) >>= \case+      Nothing -> error $ parentNotFound (typeRep @(Elem s)) child+      Just parent -> do+        component <- explGet s child+        pure $ Child (Entity parent) component++  {-# INLINE explExists #-}+  explExists :: Children s -> Int -> m Bool+  explExists (Children _ _ s) = explExists s++instance (MonadIO m, ExplSet m s) => ExplSet m (Children s) where+  {-# INLINE explSet #-}+  explSet :: Children s -> Int -> Child (Elem s) -> m ()+  explSet (Children parentToChildren childToParent s) child (Child (Entity parent) x) = do+    explSet s child x+    liftIO $ do+      (mPrevParent, childToParentMap') <-+        M.insertLookupWithKey insertChildToParent child parent+          <$> IORef.readIORef childToParent+      -- @insertLookupWithKey@ uses a @StrictPair@ internally for its result+      -- 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+            -- 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+            _ -> id+    where+    insertChildToParent :: M.Key -> Int -> Int -> Int+    insertChildToParent _k newParent _prevParent = newParent++instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Children s) where+  {-# INLINE explDestroy #-}+  explDestroy :: Children s -> Int -> m ()+  explDestroy (Children parentToChildren childToParent s) child = do+    explDestroy s child+    liftIO $ do+      childToParentMap <- IORef.readIORef childToParent+      case M.updateLookupWithKey deleteChildToParent child childToParentMap of+        (Nothing, _) -> do+          -- If the parent entity can't be found, assume the child was+          -- previously destroyed.+          pure ()+        (Just parent, childToParentMap') -> do+          -- @updateLookupWithKey@ uses a @StrictPair@ internally for its result+          -- 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+    where+    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.+newtype ChildValue c = ChildValue c deriving (Eq, Show)+instance Component c => Component (ChildValue c) where+  type Storage (ChildValue c) = ChildValueStore (Storage c)++newtype ChildValueStore s = ChildValueStore (Children s)+type instance Elem (ChildValueStore s) = ChildValue (Elem s)++instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildValue c) where+  {-# INLINE getStore #-}+  getStore :: SystemT w m (Storage (ChildValue c))+  getStore = ChildValueStore <$> getStore++instance ExplMembers m s => ExplMembers m (ChildValueStore s) where+  {-# INLINE explMembers #-}+  explMembers :: ChildValueStore s -> m (U.Vector Int)+  explMembers (ChildValueStore (Children _ _ s)) = explMembers s++instance ExplGet m s => ExplGet m (ChildValueStore s) where+  {-# INLINE explExists #-}+  explExists :: ChildValueStore s -> Int -> m Bool+  explExists (ChildValueStore (Children _ _ s)) = explExists s++  {-# INLINE explGet #-}+  explGet :: ChildValueStore s -> Int -> m (ChildValue (Elem s))+  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+newtype ChildList c = ChildList (NonEmpty Entity) deriving (Eq, Show)+instance Component c => Component (ChildList c) where+  type Storage (ChildList c) = ChildListStore (Storage c)++newtype ChildListStore s = ChildListStore (Children s)+type instance Elem (ChildListStore s) = ChildList (Elem s)++instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildList c) where+  {-# INLINE getStore #-}+  getStore :: SystemT w m (Storage (ChildList c))+  getStore = ChildListStore <$> getStore++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++instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where+  {-# INLINE explExists #-}+  explExists :: ChildListStore s -> Int -> m Bool+  explExists (ChildListStore (Children parentToChildren _ _)) parent = do+    liftIO $ M.member parent <$> IORef.readIORef parentToChildren++  {-# INLINE explGet #-}+  explGet :: ChildListStore s -> Int -> m (ChildList (Elem s))+  explGet (ChildListStore (Children parentToChildren _ _)) parent = do+    liftIO (toNE . M.lookup parent <$> IORef.readIORef parentToChildren) >>= \case+      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++instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (ChildListStore s) where+  {-# INLINE explDestroy #-}+  explDestroy :: ChildListStore s -> Int -> m ()+  explDestroy (ChildListStore children@(Children parentToChildren _ _)) parent = do+    liftIO (M.lookup parent <$> IORef.readIORef parentToChildren) >>= \case+      Nothing -> pure ()+      Just childSet -> do+        for_ (S.elems childSet) $ \child -> do+          explDestroy children child++deleteParentToChild :: Int -> IntSet -> Maybe IntSet+deleteParentToChild child v+  | v' <- S.delete child v, not $ S.null v' = Just v'+  | otherwise = Nothing++parentNotFound :: TypeRep a -> Int -> String+parentNotFound tyRep ety =+  unwords+    [ "Reading non-existent parent entity for child component of type"+    , show tyRep+    , "for child entity"+    , show ety+    ]

@@ -8,8 +8,13 @@ @Show c => Reactive (Printer c) (Map c)@ will print a message every time a @c@ value is set.  @Enum c => Reactive (EnumMap c) (Map c)@ allows you to look up entities by component value.-Use e.g. @rget >>= mapLookup True@ to retrieve a list of entities that have a @True@ component.+Use e.g. @withReactive $ enumLookup True@ to retrieve a list of entities that have a @True@ component. +@Reactive (ComponentCounter c) (Map c)@ tracks the current and max counts of entities with a particular+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     #-}@@ -17,12 +22,15 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}  module Apecs.Experimental.Reactive   ( Reacts (..), Reactive, withReactive+  , Printer   , EnumMap, enumLookup   , OrdMap, ordLookup   , IxMap, ixLookup+  , ComponentCounter, readComponentCount, ComponentCount(..)   ) where  import           Control.Monad@@ -106,7 +114,7 @@   react _ _ _ _ = return ()  -- | Allows you to look up entities by component value.---   Use e.g. @withReactive $ mapLookup True@ to retrieve a list of entities that have a @True@ component.+--   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)) @@ -180,3 +188,58 @@ ixLookup :: (MonadIO m, Ix c) => c -> IxMap c -> m [Entity] 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.+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'.+data ComponentCount c = ComponentCount+  { componentCountCurrent :: !Int+    -- ^ 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)++instance MonadIO m => Reacts m (ComponentCounter c) where+  {-# INLINE rempty #-}+  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)+      _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+                }+            , ()+            )++{-# INLINE readComponentCount #-}+readComponentCount+  :: forall c m+   . MonadIO m+  => ComponentCounter c+  -> m (ComponentCount c)+readComponentCount (ComponentCounter ref) = liftIO $ readIORef ref

@@ -1,5 +1,5 @@ {-|-Stability: experimtal+Stability: experimental  This module is experimental, and its API might change between point releases. Use at your own risk. -}@@ -13,6 +13,7 @@ {-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-} {-# LANGUAGE UndecidableInstances       #-}  module Apecs.Experimental.Stores

@@ -8,6 +8,7 @@ {-# LANGUAGE Strict                #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}  module Apecs.Stores   ( Map, Cache, Unique,@@ -60,7 +61,7 @@ instance MonadIO m => ExplDestroy m (Map c) where   {-# INLINE explDestroy #-}   explDestroy (Map ref) ety = liftIO$-    readIORef ref >>= writeIORef ref . M.delete ety+    modifyIORef' ref (M.delete ety)  instance MonadIO m => ExplMembers m (Map c) where   {-# INLINE explMembers #-}

@@ -10,11 +10,12 @@   ) where  import           Control.Monad+import           Control.Monad.Reader (asks) import           Language.Haskell.TH  import           Apecs.Core import           Apecs.Stores-import           Apecs.Util          (EntityCounter)+import           Apecs.Util           (EntityCounter)  genName :: String -> Q Name genName s = mkName . show <$> newName s@@ -28,25 +29,25 @@     return (ConT t, rec)    let wld = mkName worldName-      has = mkName "Has"-      sys = mkName "SystemT"+      has = ''Has+      sys = 'SystemT       m = VarT $ mkName "m"       wldDecl = DataD [] wld [] Nothing [RecC wld records] [] -      makeRecord (t,n) = (n, Bang NoSourceUnpackedness SourceStrict, ConT (mkName "Storage") `AppT` t)+      makeRecord (t,n) = (n, Bang NoSourceUnpackedness SourceStrict, ConT ''Storage `AppT` t)       records = makeRecord <$> cTypesNames        makeInstance (t,n) =-        InstanceD Nothing [ConT (mkName "Monad") `AppT` m] (ConT has `AppT` ConT wld `AppT` m `AppT` t)-          [ FunD (mkName "getStore") [Clause []-              (NormalB$ ConE sys `AppE` (VarE (mkName "asks") `AppE` VarE n))+        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))             [] ]           ]        initWorldName = mkName $ "init" ++ worldName-      initSig = SigD initWorldName (AppT (ConT (mkName "IO")) (ConT wld))+      initSig = SigD initWorldName (AppT (ConT ''IO) (ConT wld))       initDecl = FunD initWorldName [Clause []-        (NormalB$ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "explInit")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records)+        (NormalB$ iterate (\wE -> AppE (AppE (VarE '(<*>)) wE) (VarE 'explInit)) (AppE (VarE 'return) (ConE wld)) !! length records)         [] ]        hasDecl = makeInstance <$> cTypesNames

@@ -64,5 +64,5 @@   set entity component  -- | Explicitly invoke the garbage collector-runGC :: System w ()-runGC = lift performMajorGC+runGC :: MonadIO m => SystemT w m ()+runGC = liftIO performMajorGC

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeApplications           #-}@@ -11,17 +12,20 @@  {-# 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                   (sort)+import           Data.List                   ((\\), delete, nub, sort) import qualified Data.Vector.Unboxed         as U import           Test.QuickCheck import           Test.QuickCheck.Monadic-import           Data.List (nub)+import           Text.Printf                 (printf)  import           Apecs import           Apecs.Core+import           Apecs.Experimental.Children import           Apecs.Experimental.Reactive import           Apecs.Experimental.Stores import           Apecs.Stores@@ -151,6 +155,30 @@          && all (`notElem` ef) et          ) +-- Tests Reactive component counting+newtype TestCount = TestCount Bool deriving (Eq, Show, Bounded, Enum, Arbitrary)+instance Component TestCount where type Storage TestCount = Reactive (ComponentCounter TestCount) (Map TestCount)++makeWorld "ReactiveCountWld" [''TestCount]++prop_setGetReactiveCount = genericSetGet initReactiveCountWld (undefined :: TestCount)+prop_setSetReactiveCount = genericSetSet initReactiveCountWld (undefined :: TestCount)+prop_reactiveCounts :: [(Entity, TestCount)] -> [Entity] -> Property+prop_reactiveCounts writes deletes = assertSys initReactiveCountWld $ do+  forM_ writes  $ uncurry set+  forM_ deletes $ flip destroy (Proxy @TestCount)++  count <- withReactive $ readComponentCount @TestCount++  return $ count == ComponentCount+    { componentCountCurrent = length existingEnts+    , componentCountMax = length writeEnts+    }+  where+  existingEnts = writeEnts \\ deleteEnts+  writeEnts = nub $ sort $ fst <$> writes+  deleteEnts = nub $ sort deletes+ -- Tests Pushdown newtype StackInt = StackInt Int deriving (Eq, Show, Arbitrary) instance Component StackInt where type Storage StackInt = Pushdown Map StackInt@@ -158,6 +186,98 @@ makeWorld "StackWld" [''StackInt]  prop_setGetStack = genericSetSet initStackWld (undefined :: StackInt)++-- Tests Child+type ChildT2 = Child T2+makeWorld "ChildTest" [''T1, ''ChildT2]++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.+instance Arbitrary (Child T2) where+  arbitrary = Child <$> pure global <*> arbitrary++data ChildrenEx = ChildrenEx String deriving (Show)+instance E.Exception ChildrenEx+prop_children :: NonEmptyList (T1, NonEmptyList T2) -> Property+prop_children (NonEmpty writes) = assertSys initChildTest $ do+  forM_ writes $ \(t1, NonEmpty t2s) -> do+    -- Create a parent entity with the T1 component value.+    parent <- newEntity t1+    -- Create child entities with the T2 component values.+    children <- fmap mconcat $ forM t2s $ \t2 -> do+      child <- newEntity $ Child parent t2+      pure [child]+    -- For each child entity, check that we can fetch it, its parent is+    -- correct, and its component value is good.+    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)+      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)+    -- 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)+    -- 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+    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)+    -- 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)++  -- 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+  -- child of each group was previously reparented to be under the global+  -- entity.+  ChildList children :: ChildList T2 <- get global+  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"++  -- 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')++  return True  return [] main = $quickCheckAll