diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 `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 `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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/apecs.cabal b/apecs.cabal --- a/apecs.cabal +++ b/apecs.cabal @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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)) + ] ] - ] - diff --git a/src/Apecs.hs b/src/Apecs.hs --- a/src/Apecs.hs +++ b/src/Apecs.hs @@ -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. +-} diff --git a/src/Apecs/Components.hs b/src/Apecs/Components.hs --- a/src/Apecs/Components.hs +++ b/src/Apecs/Components.hs @@ -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 #-} diff --git a/src/Apecs/Core.hs b/src/Apecs/Core.hs --- a/src/Apecs/Core.hs +++ b/src/Apecs/Core.hs @@ -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)) diff --git a/src/Apecs/Experimental/Children.hs b/src/Apecs/Experimental/Children.hs --- a/src/Apecs/Experimental/Children.hs +++ b/src/Apecs/Experimental/Children.hs @@ -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 #-} diff --git a/src/Apecs/Experimental/Components.hs b/src/Apecs/Experimental/Components.hs --- a/src/Apecs/Experimental/Components.hs +++ b/src/Apecs/Experimental/Components.hs @@ -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) diff --git a/src/Apecs/Experimental/Reactive.hs b/src/Apecs/Experimental/Reactive.hs --- a/src/Apecs/Experimental/Reactive.hs +++ b/src/Apecs/Experimental/Reactive.hs @@ -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 diff --git a/src/Apecs/Experimental/Reload.hs b/src/Apecs/Experimental/Reload.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Experimental/Reload.hs @@ -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 diff --git a/src/Apecs/Experimental/Stores.hs b/src/Apecs/Experimental/Stores.hs --- a/src/Apecs/Experimental/Stores.hs +++ b/src/Apecs/Experimental/Stores.hs @@ -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 diff --git a/src/Apecs/Experimental/Util.hs b/src/Apecs/Experimental/Util.hs --- a/src/Apecs/Experimental/Util.hs +++ b/src/Apecs/Experimental/Util.hs @@ -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 diff --git a/src/Apecs/Stores.hs b/src/Apecs/Stores.hs --- a/src/Apecs/Stores.hs +++ b/src/Apecs/Stores.hs @@ -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 ( 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 diff --git a/src/Apecs/Stores/Internal.hs b/src/Apecs/Stores/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Stores/Internal.hs @@ -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 diff --git a/src/Apecs/System.hs b/src/Apecs/System.hs --- a/src/Apecs/System.hs +++ b/src/Apecs/System.hs @@ -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) [] diff --git a/src/Apecs/TH.hs b/src/Apecs/TH.hs --- a/src/Apecs/TH.hs +++ b/src/Apecs/TH.hs @@ -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]) diff --git a/src/Apecs/TH/Tags.hs b/src/Apecs/TH/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/TH/Tags.hs @@ -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 diff --git a/src/Apecs/Tags.hs b/src/Apecs/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Tags.hs @@ -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) diff --git a/src/Apecs/Util.hs b/src/Apecs/Util.hs --- a/src/Apecs/Util.hs +++ b/src/Apecs/Util.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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