├── CONTRIBUTORS ├── Setup.hs ├── test ├── Main.hs └── InspectionSpec.hs ├── .gitignore ├── stack.yaml ├── .travis ├── install-ghr.sh ├── install-stack.sh └── attach-binary.sh ├── stack.yaml.lock ├── README.markdown ├── .travis.yml ├── LICENSE ├── src ├── Main.hs └── Data │ ├── Ecstasy │ ├── Types.hs │ ├── Internal │ │ └── Deriving.hs │ └── Internal.hs │ └── Ecstasy.hs ├── ChangeLog.md └── ecstasy.cabal /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Rys Ostrovid 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | TAGS 3 | .stack-work 4 | .stack-profile 5 | dist/ 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | 5 | extra-deps: 6 | - inspection-testing-0.3 7 | resolver: lts-11.9 8 | -------------------------------------------------------------------------------- /.travis/install-ghr.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | else 8 | if [ "$TRAVIS_OS_NAME" = "linux" ] 9 | then 10 | ARCH="linux" 11 | else 12 | ARCH="darwin" 13 | fi 14 | echo "Installing ghr" 15 | URL="https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_${ARCH}_386.zip" 16 | curl -L ${URL} > ghr.zip 17 | mkdir -p "$HOME/bin" 18 | export PATH="$HOME/bin:$PATH" 19 | unzip ghr.zip -d "$HOME/bin" 20 | rm ghr.zip 21 | fi 22 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: inspection-testing-0.3@sha256:8f95d11b1ced58f0599da431682d2f2492067fa04b517da7d01696fde63b8b1a,5482 9 | pantry-tree: 10 | size: 1001 11 | sha256: 1a797fdd9a96a7ef4d880ca2fe1fbdaec5ece4fad39cb9c9f6e1e8bb59518959 12 | original: 13 | hackage: inspection-testing-0.3 14 | snapshots: 15 | - completed: 16 | size: 507596 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/9.yaml 18 | sha256: 42f472dbf06482da1b3319241f3e3b3593a45bd7d4f537d2789f21386b9b2ad3 19 | original: lts-11.9 20 | -------------------------------------------------------------------------------- /.travis/install-stack.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Adapted from https://github.com/commercialhaskell/stack 4 | 5 | set -eux 6 | 7 | travis_retry() { 8 | cmd=$* 9 | $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd) 10 | } 11 | 12 | fetch_stack_osx() { 13 | curl -skL https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin; 14 | } 15 | 16 | fetch_stack_linux() { 17 | curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'; 18 | } 19 | 20 | # We need stack to generate cabal files with precise bounds, even for cabal 21 | # builds. 22 | mkdir -p ~/.local/bin; 23 | if [ "$(uname)" = "Darwin" ]; then 24 | travis_retry fetch_stack_osx 25 | else 26 | travis_retry fetch_stack_linux 27 | fi 28 | 29 | travis_retry stack --no-terminal setup; 30 | -------------------------------------------------------------------------------- /.travis/attach-binary.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | elif test ! "$GITHUB_TOKEN" 8 | then 9 | echo 'The GITHUB_TOKEN environment variable is not set!' 10 | exit 1 11 | else 12 | echo "Building binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 13 | stack build --ghc-options -O2 --pedantic 14 | echo "Attaching binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 15 | OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)" 16 | REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)" 17 | BIN="$(stack path --local-install-root)/bin/$REPO" 18 | BUNDLE_NAME="$REPO-$TRAVIS_TAG-$TRAVIS_OS_NAME.tar.gz" 19 | cp "$BIN" "./$REPO" 20 | chmod +x "./$REPO" 21 | tar -czf "$BUNDLE_NAME" "$REPO" 22 | echo "SHA256:" 23 | shasum -a 256 "$BUNDLE_NAME" 24 | ghr -t "$GITHUB_TOKEN" -u "$OWNER" -r "$REPO" --replace "$(git describe --tags)" "$BUNDLE_NAME" 25 | fi 26 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Ecstasy 2 | 3 | [![Build Status](https://travis-ci.org/isovector/ecstasy.svg?branch=master)](https://travis-ci.org/isovector/ecstasy) | [Hackage][hackage] 4 | 5 | [hackage]: https://hackage.haskell.org/package/ecstasy 6 | 7 | ## Dedication 8 | 9 | > When I see things like this, there’s nothing better than the underlying 10 | > feeling that I’m a part of something good, some incredible positive vibration 11 | > that we’re somehow all spinning around on. There’s nothing better than to 12 | > think about all those people who are worried about me, and to understand 13 | > they’re concerned, fundamentally, out of love. There’s nothing better than to 14 | > know that there’s people who care that much. But, most of all, there’s nothing 15 | > to better than to know that those people are wrong. Am I out of control? Fuck 16 | > no, I’m a goddamn Jedi. That’s as in control as it gets. 17 | > 18 | > Ben Kenobi, Erowid 19 | 20 | 21 | ## Overview 22 | 23 | Ecstasy is an *entity-component system* for Haskell. It's inspired by 24 | [apecs][apecs], but makes the design decision to focus on being idiomatic rather 25 | than being fast. Maybe. I haven't actually benchmarked it. 26 | 27 | [apecs]: https://github.com/jonascarpay/apecs 28 | 29 | We achieve being idiomatic by using GHC.Generics and tricky type families to 30 | derive performant data stores given only a record of the desired components. 31 | 32 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Adapted from https://github.com/commercialhaskell/stack 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.ghc 8 | - $HOME/.cabal 9 | - $HOME/.stack 10 | - .stack-work 11 | 12 | matrix: 13 | include: 14 | # ghc 8.0.1 15 | - env: STACK='stack --resolver=lts-7.4' CACHE_NAME=8.0.1 16 | addons: {apt: {packages: [libgmp-dev]}} 17 | # ghc 8.0.2 18 | - env: STACK='stack --resolver=lts-8.24' CACHE_NAME=8.0.2 19 | addons: {apt: {packages: [libgmp-dev]}} 20 | # ghc 8.2.2 21 | - env: STACK='stack --resolver=lts-11.5' CACHE_NAME=8.2.2 22 | addons: {apt: {packages: [libgmp-dev]}} 23 | 24 | # Use the resolver in stack.yaml 25 | - env: STACK=stack CACHE_NAME=stack-linux 26 | addons: {apt: {packages: [libgmp-dev]}} 27 | 28 | - env: STACK=stack CACHE_NAME=stack-osx 29 | os: osx 30 | addons: {apt: {packages: [libgmp-dev]}} 31 | 32 | 33 | install: 34 | - unset CC 35 | - export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:$PATH 36 | - ./.travis/install-ghr.sh 37 | - ./.travis/install-stack.sh 38 | 39 | script: 40 | - echo "$(stack ghc -- --version) [$(stack ghc -- --print-project-git-commit-id 2> /dev/null || echo '?')]" 41 | - GHC_OPTIONS="-Werror" 42 | - | 43 | set -ex 44 | # Run tests 45 | $STACK --no-terminal test --ghc-options="$GHC_OPTIONS" 46 | set +ex 47 | 48 | after_success: 49 | - | 50 | # Build and ship binary 51 | ./.travis/attach-binary.sh 52 | 53 | 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Sandy Maguire 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sandy Maguire nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /test/InspectionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | #if MIN_VERSION_base(4,9,1) 7 | {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} 8 | #endif 9 | 10 | 11 | module InspectionSpec where 12 | 13 | import Control.Monad.Codensity 14 | import GHC.Generics 15 | import Data.Ecstasy 16 | import Test.Hspec 17 | 18 | #if MIN_VERSION_base(4,9,1) 19 | import Language.Haskell.TH 20 | import Test.Inspection 21 | #endif 22 | 23 | spec :: Spec 24 | spec = pure () 25 | 26 | 27 | data World s = World 28 | { field :: Component s 'Field Int 29 | , unique :: Component s 'Unique Bool 30 | , virtual :: Component s 'Virtual String 31 | } 32 | deriving (Generic) 33 | 34 | getField :: Monad m => QueryT World m Int 35 | getField = query field 36 | 37 | getUnique :: Monad m => QueryT World m Bool 38 | getUnique = query unique 39 | 40 | getVirtual :: Monad m => QueryT World m String 41 | getVirtual = query virtual 42 | 43 | setter :: World 'SetterOf 44 | setter = unchanged 45 | 46 | world :: World ('WorldOf IO) 47 | world = defStorage 48 | 49 | 50 | #if MIN_VERSION_base(4,9,1) 51 | inspect $ hasNoGenerics 'getField 52 | inspect $ hasNoType 'getField ''Codensity 53 | 54 | inspect $ hasNoGenerics 'getUnique 55 | inspect $ hasNoType 'getUnique ''Codensity 56 | 57 | inspect $ hasNoGenerics 'getVirtual 58 | inspect $ hasNoType 'getVirtual ''Codensity 59 | 60 | inspect $ hasNoGenerics 'setter 61 | inspect $ hasNoType 'setter ''Codensity 62 | 63 | inspect $ hasNoGenerics 'world 64 | inspect $ hasNoType 'world ''Codensity 65 | #endif 66 | 67 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Main where 8 | 9 | import Data.Char (toUpper) 10 | import Data.Ecstasy 11 | import Control.Monad (void) 12 | import Control.Monad.IO.Class (liftIO) 13 | 14 | main :: IO () 15 | main = do 16 | e <- runSystemT ( 17 | defStorage 18 | { say = VTable vgetSay vsetSay 19 | , sAY = VTable vgetSAY vsetSAY 20 | } ) $ do 21 | void $ createEntity $ newEntity 22 | { pos = Just 0 23 | , vel = Just 1 24 | , ack = Just True 25 | , say = Just "hello" 26 | } 27 | 28 | void $ createEntity $ newEntity 29 | { pos = Just 0 30 | , ack = Just False 31 | , sAY = Just "world" 32 | } 33 | 34 | let 35 | step = do 36 | pos' <- query pos 37 | vel' <- query vel 38 | pure $ unchanged 39 | { pos = Set $ pos' + vel' 40 | } 41 | emap allEnts step 42 | emap allEnts step 43 | 44 | efor allEnts $ do 45 | i <- queryEnt 46 | with ack 47 | pure $ show i 48 | 49 | print e 50 | -- print $ pos e 51 | -- print $ vel e 52 | -- print $ ack e 53 | 54 | 55 | data Entity f = Entity 56 | { pos :: Component f 'Field Int 57 | , vel :: Component f 'Field Int 58 | , ack :: Component f 'Unique Bool 59 | , say :: Component f 'Virtual String 60 | , sAY :: Component f 'Virtual String 61 | } deriving (Generic) 62 | 63 | vgetSay _ = pure Nothing 64 | vsetSay _ (Set msg) = putStrLn msg 65 | vsetSay _ _ = pure () 66 | 67 | vgetSAY _ = pure Nothing 68 | vsetSAY _ (Set msg) = putStrLn $ fmap toUpper msg 69 | vsetSAY _ _ = pure () 70 | 71 | 72 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for ecstasy 2 | 3 | ## 0.3.0.0 -- unreleased 4 | 5 | * Replace 'State s' with 'ReaderT (IORef s) IO', resulting in significantly less 6 | allocations. 7 | * Perform static analysis of 'QueryT's to avoid evaluating them on irrelevant 8 | entities. 9 | 10 | ## 0.2.1.0 -- 2018-05-15 11 | 12 | * Added the 'surgery' function to introduce temporary effects. 13 | * Significant performance improvements due to constructing monadic generic 14 | functions via 'Codensity'. 15 | 16 | ## 0.2.0.1 -- 2018-05-10 17 | 18 | * Also export 'StorageType'. 19 | 20 | ## 0.2.0.0 -- 2018-05-10 21 | 22 | * Renamed 'get*' to 'query*'. 23 | * Renamed 'newEntity' to 'createEntity'. 24 | * Renamed 'defEntity' to 'newEntity'. 25 | * Renamed 'defEntity'' to 'unchanged'. 26 | * Renamed 'defWorld' to 'defStorage'. 27 | * Significant performance improvements. 28 | * Added a 'Virtual' component type, allowing for easy integration with systems 29 | that own their own data. Getting and setting on 'Virtual' components 30 | dispatch as actions in the underlying monad stack. 31 | * Added proper type wrappers around 'SystemT' and 'QueryT' so they don't eat up 32 | valuable mtl instances. 33 | * Removed the 'Ent' parameter from the 'efor' callback, since this can now be 34 | gotten in any 'QueryT' context via 'queryEnt'. 35 | * Parameterized 'emap' and 'efor' by an 'EntityTarget', which allows for calling 36 | these functions over specific groups of entities. 37 | * Added 'eover': a combination of 'emap' and 'efor'. 38 | 39 | ## 0.1.1.0 -- 2018-02-18 40 | 41 | * Added 'deleteEntity' (function) and 'delEntity' (QueryT setter). 42 | 43 | ## 0.1.0.1 -- 2018-02-14 44 | 45 | * Added 'yieldSystemT' for resuming a 'SystemT' computation later. 46 | * Bumped the upper bound on 'base' to 5 (thanks to nek0). 47 | 48 | ## 0.1.0.0 -- 2017-12-27 49 | 50 | * First version. Released on an unsuspecting world. 51 | 52 | -------------------------------------------------------------------------------- /ecstasy.cabal: -------------------------------------------------------------------------------- 1 | -- Initial ecstasy.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: ecstasy 5 | version: 0.3.0.0 6 | synopsis: 7 | A GHC.Generics based entity component system. 8 | 9 | description: 10 | Ecstasy is an entity-component system for Haskell. It's inspired by 11 | , but makes the design 12 | decision to focus on being idiomatic rather than being fast. Maybe. I haven't 13 | actually benchmarked it. 14 | . 15 | We achieve being idiomatic by using 'GHC.Generics' and tricky type families 16 | to derive performant data stores given only a record of the desired 17 | components. 18 | 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Sandy Maguire 22 | maintainer: sandy@sandymaguire.me 23 | homepage: http://github.com/isovector/ecstasy/ 24 | bug-reports: http://github.com/isovector/ecstasy/issues 25 | -- copyright: 26 | category: Game 27 | build-type: Simple 28 | extra-source-files: ChangeLog.md 29 | cabal-version: >=1.10 30 | tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/isovector/ecstasy.git 35 | 36 | library 37 | exposed-modules: Data.Ecstasy 38 | , Data.Ecstasy.Types 39 | , Data.Ecstasy.Internal 40 | , Data.Ecstasy.Internal.Deriving 41 | -- other-extensions: 42 | build-depends: base >=4.9 && <5, containers, mtl, transformers, kan-extensions, microlens 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | 46 | Test-Suite tests 47 | type: exitcode-stdio-1.0 48 | default-language: Haskell2010 49 | other-modules: InspectionSpec 50 | hs-Source-Dirs: test 51 | main-is: Main.hs 52 | build-depends: base >=4.9 && <5, containers, mtl, transformers, hspec, ecstasy, kan-extensions 53 | if impl(ghc > 8.0.1) 54 | build-depends: inspection-testing >= 0.3 && <0.4 55 | , template-haskell 56 | -------------------------------------------------------------------------------- /src/Data/Ecstasy/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeFamilyDependencies #-} 14 | {-# LANGUAGE TypeInType #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# OPTIONS_GHC -funbox-strict-fields #-} 17 | 18 | module Data.Ecstasy.Types where 19 | 20 | import Control.Applicative (Alternative) 21 | import Control.Monad (MonadPlus) 22 | import Control.Monad.Fail (MonadFail) 23 | import Control.Monad.IO.Class (MonadIO) 24 | import Control.Monad.Reader.Class (MonadReader (..)) 25 | import Control.Monad.State.Class (MonadState (..)) 26 | import Control.Monad.Trans.Class (MonadTrans (..)) 27 | import Control.Monad.Trans.Maybe (MaybeT (..)) 28 | import Control.Monad.Trans.Reader (ReaderT (..)) 29 | import Control.Monad.Writer.Class (MonadWriter) 30 | import Data.Data 31 | import Data.IORef (IORef) 32 | import Data.IntMap.Strict (IntMap) 33 | import Data.Kind 34 | import GHC.Generics (Generic) 35 | import Lens.Micro 36 | 37 | 38 | ------------------------------------------------------------------------------ 39 | -- | The key for an entity. 40 | newtype Ent = Ent { unEnt :: Int } 41 | deriving (Eq, Ord, Data, Typeable) 42 | 43 | instance Show Ent where 44 | show (Ent e) = "Ent " ++ show e 45 | 46 | 47 | ------------------------------------------------------------------------------ 48 | -- | The internal state of the 'SystemT' monad. 49 | data SystemState w m = SystemState 50 | { _ssNextId :: {-# UNPACK #-} !Int 51 | , _ssWorld :: w ('WorldOf m) 52 | , _ssHooks :: {-# UNPACK #-} !(Hooks w m) 53 | } deriving (Generic) 54 | 55 | ssNextId :: Lens' (SystemState w m) Int 56 | ssNextId f (SystemState a b c) = (\a' -> SystemState a' b c) <$> f a 57 | 58 | ssWorld :: Lens' (SystemState w m) (w ('WorldOf m)) 59 | ssWorld f (SystemState a b c) = (\b' -> SystemState a b' c) <$> f b 60 | 61 | ssHooks :: Lens' (SystemState w m) (Hooks w m) 62 | ssHooks f (SystemState a b c) = (\c' -> SystemState a b c') <$> f c 63 | 64 | 65 | ------------------------------------------------------------------------------ 66 | -- | A datastructure holding hooks into ecstasy's entity management. 67 | data Hooks w m = Hooks 68 | { hookNewEnt :: Ent -> SystemT w m () 69 | , hookDelEnt :: Ent -> SystemT w m () 70 | } deriving (Generic) 71 | 72 | defHooks :: Monad m => Hooks w m 73 | defHooks = Hooks (const $ pure ()) (const $ pure ()) 74 | 75 | 76 | ------------------------------------------------------------------------------ 77 | -- | A monad transformer over an ECS given a world 'w'. 78 | newtype SystemT w m a = SystemT 79 | { runSystemT' :: ReaderT (IORef (SystemState w m)) m a 80 | } 81 | deriving ( Functor 82 | , Applicative 83 | , Monad 84 | , MonadState s 85 | , MonadWriter ww 86 | , MonadIO 87 | ) 88 | 89 | instance MonadTrans (SystemT w) where 90 | lift = SystemT . lift 91 | 92 | instance MonadReader r m => MonadReader r (SystemT w m) where 93 | ask = SystemT $ lift ask 94 | local z s = SystemT . ReaderT $ \r -> 95 | local z $ runReaderT (runSystemT' s) r 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | -- | A computation to run over a particular entity. 100 | newtype QueryT w m a = QueryT 101 | { runQueryT' :: ReaderT (Ent, SystemState w m) (MaybeT m) a 102 | } 103 | deriving ( Functor 104 | , Applicative 105 | , Monad 106 | , MonadState s 107 | , MonadWriter ww 108 | , MonadIO 109 | , Alternative 110 | , MonadPlus 111 | , MonadFail 112 | ) 113 | 114 | instance MonadTrans (QueryT w) where 115 | lift = QueryT . lift . lift 116 | 117 | instance MonadReader r m => MonadReader r (QueryT w m) where 118 | ask = QueryT $ lift ask 119 | local f = QueryT . runQueryT' . local f 120 | 121 | 122 | ------------------------------------------------------------------------------ 123 | -- | A collection of methods necessary to dispatch reads and writes to 124 | -- a 'Virtual' component. 125 | data VTable m a = VTable 126 | { -- | Get the value of an entity's component. 127 | vget :: !(Ent -> m (Maybe a)) 128 | 129 | -- | Update the value of an entity's component. 130 | , vset :: !(Ent -> Update a -> m ()) 131 | } 132 | 133 | 134 | ------------------------------------------------------------------------------ 135 | -- | Data kind used to parameterize the ECS record. 136 | data StorageType 137 | = FieldOf -- ^ Used to describe the actual entity. 138 | | WorldOf (Type -> Type) -- ^ Used to construct the world's storage. 139 | | SetterOf -- ^ Used to construct a setter to update an entity. 140 | 141 | 142 | ------------------------------------------------------------------------------ 143 | -- | Data kind used to parameterize the fields of the ECS record. 144 | data ComponentType 145 | = Field -- ^ This component can be owned by any entity. 146 | | Unique -- ^ This component can be owned by only a single entity at a time. 147 | | Virtual -- ^ This component is owned by another system. 148 | 149 | 150 | ------------------------------------------------------------------------------ 151 | -- | Describes how we can change an 'a'. 152 | data Update a 153 | = Keep -- ^ Keep the current value. 154 | | Unset -- ^ Delete the current value if it exists. 155 | | Set !a -- ^ Set the current value. 156 | | Modify !(a -> a) 157 | 158 | 159 | ------------------------------------------------------------------------------ 160 | -- | A type family to be used in your ECS recrod. 161 | type family Component (s :: StorageType) 162 | (c :: ComponentType) 163 | (a :: Type) :: Type where 164 | Component 'FieldOf c a = Maybe a 165 | Component 'SetterOf c a = Update a 166 | 167 | Component ('WorldOf m) 'Field a = IntMap a 168 | Component ('WorldOf m) 'Unique a = Maybe (Int, a) 169 | Component ('WorldOf m) 'Virtual a = VTable m a 170 | 171 | 172 | ------------------------------------------------------------------------------ 173 | -- | The inverse of 'Component ('WorldOf m)' -- used to prove 'IsInjective' 174 | type family Inverse (m :: Type -> Type) 175 | (r :: Type) :: ComponentType where 176 | Inverse m (IntMap a) = 'Field 177 | Inverse m (Maybe (Int, a)) = 'Unique 178 | Inverse m (VTable m a) = 'Virtual 179 | 180 | ------------------------------------------------------------------------------ 181 | -- | A proof that 'c' is injective. 182 | class (c ~ Inverse m (Component ('WorldOf m) c a)) 183 | => IsInjective m (c :: ComponentType) a 184 | instance (c ~ Inverse m (Component ('WorldOf m) c a)) 185 | => IsInjective m (c :: ComponentType) a 186 | 187 | -------------------------------------------------------------------------------- /src/Data/Ecstasy.hs: -------------------------------------------------------------------------------- 1 | -- | Ecstasy is a library architected around the 2 | -- , the 3 | -- gist of which is to define a "template" type that can be reused for several 4 | -- purposes. Users of ecstasy should define a record type of 'Component's 5 | -- parameterized over a variable of kind 'StorageType': 6 | -- 7 | -- @ 8 | -- data World s = Entity 9 | -- { position :: 'Component' s ''Field' (V2 Double) 10 | -- , graphics :: 'Component' s ''Field' Graphics 11 | -- , isPlayer :: 'Component' s ''Unique' () 12 | -- } 13 | -- deriving ('Generic') 14 | -- @ 15 | -- 16 | -- Ensure that this type have an instance of 'Generic'. 17 | -- 18 | -- For usability, it might be desirable to also define the following type 19 | -- synonym: 20 | -- 21 | -- @ 22 | -- type Entity = World ''FieldOf' 23 | -- @ 24 | -- 25 | -- which is the only form of the @World@ that most users of ecstasy will 26 | -- need to interact with. 27 | -- 28 | -- Throughout this document there are references to the @HasWorld@ and 29 | -- @HasWorld'@ classes, which are implementation details and provided 30 | -- automatically by the library. 31 | module Data.Ecstasy 32 | ( 33 | -- * Defining components 34 | -- $components 35 | ComponentType (..) 36 | , Component 37 | 38 | -- * Storage 39 | -- $world 40 | , defStorage 41 | , StorageType (..) 42 | 43 | -- * The SystemT monad 44 | -- $systemt 45 | , SystemT () 46 | , runSystemT 47 | , yieldSystemT 48 | , SystemState 49 | 50 | -- * Working with SystemT 51 | , createEntity 52 | , newEntity 53 | , getEntity 54 | , setEntity 55 | , deleteEntity 56 | 57 | -- * SystemT traversals 58 | -- $traversals 59 | , emap 60 | , efor 61 | , eover 62 | , unchanged 63 | , delEntity 64 | 65 | -- * Entity targets 66 | , EntTarget 67 | , allEnts 68 | , uniqueEnt 69 | , someEnts 70 | , anEnt 71 | , entsWith 72 | 73 | -- * The QueryT monad 74 | -- $queryt 75 | , QueryT () 76 | , runQueryT 77 | 78 | -- * Queries 79 | -- $querying 80 | , query 81 | , subquery 82 | , with 83 | , without 84 | , queryEnt 85 | , queryUnique 86 | , querySelf 87 | , queryMaybe 88 | , queryFlag 89 | , queryDef 90 | , queryTarget 91 | 92 | -- * Updates 93 | , Update (..) 94 | , maybeToUpdate 95 | 96 | -- * Introducing effects 97 | , surgery 98 | 99 | -- * Miscellany 100 | , Ent () 101 | , VTable (..) 102 | 103 | -- * Re-exports 104 | , Generic () 105 | ) where 106 | 107 | import Data.Ecstasy.Internal hiding (HasWorld, HasWorld') 108 | import Data.Ecstasy.Types 109 | import GHC.Generics 110 | 111 | 112 | 113 | -- $components 114 | -- Components are pieces of data that may or may not exist on a particular 115 | -- entity. In fact, an 'Ent' is nothing more than an identifier, against which 116 | -- components are linked. 117 | -- 118 | -- Components classified by their 'ComponentType', which describes the 119 | -- semantics behind a component. 120 | -- 121 | -- [@Field@] A 'Field' is a "normal" component and corresponds exactly to 122 | -- a 'Maybe' value. 123 | -- 124 | -- [@Unique@] A 'Unique' component may only exist on a single entity at a given 125 | -- time. They are often used to annotate "notable" entites, such as whom the 126 | -- camera should be following. 127 | -- 128 | -- [@Virtual@] A 'Virtual' component is defined in terms of monadic 'vget' and 129 | -- 'vset' actions, rather than having dedicated storage in the ECS. Virtual 130 | -- components are often used to connect to external systems, eg. to a 3rd party 131 | -- physics engine which wants to own its own data. For more information on 132 | -- using virtual components, see <#world defStorage>. 133 | -- 134 | -- 135 | 136 | 137 | 138 | -- $world 139 | -- #world# 'defStorage' provides a suitable container for storing entity data, to 140 | -- be used with 'runSystemT' and friends. If you are not using any 'Virtual' 141 | -- components, it can be used directly. 142 | -- 143 | -- However, when using 'Virtual' components, the 'VTable' for each must be set 144 | -- on 'defStorage' before being given as a parameter to 'runSystemT'. For 145 | -- example, we can write a virtual 'String' component that writes its updates 146 | -- to stdout: 147 | -- 148 | -- @ 149 | -- data World s = Entity 150 | -- { stdout :: 'Component' s ''Virtual' String 151 | -- } 152 | -- deriving ('Generic') 153 | -- 154 | -- main :: IO () 155 | -- main = do 156 | -- let storage = 'defStorage' 157 | -- { stdout = 'VTable' 158 | -- { 'vget' = \\_ -> pure Nothing 159 | -- , 'vset' = \\_ m -> for_ m putStrLn 160 | -- } 161 | -- } 162 | -- 'runSystemT' storage $ do 163 | -- void $ 'createEntity' 'newEntity' 164 | -- { stdout = Just "hello world" 165 | -- } 166 | -- @ 167 | -- 168 | -- In this example, if you were to use 'defStorage' rather than @storage@ as the 169 | -- argument to 'runSystemT', you would receive the following error: 170 | -- 171 | -- @unset VTable for Virtual component \'stdout\'@ 172 | 173 | 174 | 175 | -- $systemt 176 | -- The 'SystemT' transformer provides capabilities for creating, modifying, 177 | -- reading and deleting entities, as well as performing <#traversals query 178 | -- traversals> over them. It is the main monad of ecstasy. 179 | 180 | 181 | 182 | -- $queryt 183 | -- The 'QueryT' transformer provides an environment for <#traversals querying> 184 | -- components of an entity. Due to its 'Control.Monad.MonadPlus' instance, 185 | -- failing queries will prevent further computations in the monad from running. 186 | 187 | 188 | 189 | -- $traversals 190 | -- #traversals# 'SystemT' provides functionality for traversing over entities 191 | -- that match a 'EntTarget' and a <#querying query>. The functions 'emap' and 192 | -- 'eover' return a @world 'SetterOf@, corresponding to partial update of the 193 | -- targeted entity. 194 | -- 195 | -- A @world 'SetterOf@ is the world record where all of its selectors have the 196 | -- type @'Update' a@. For example, given a world: 197 | -- 198 | -- @ 199 | -- data World s = Entity 200 | -- { position :: 'Component' s ''Field' (V2 Double) 201 | -- , graphics :: 'Component' s ''Field' Graphics 202 | -- , isPlayer :: 'Component' s ''Unique' () 203 | -- } 204 | -- @ 205 | -- 206 | -- then @World 'SetterOf@ is equivalent to the following definition: 207 | -- 208 | -- @ 209 | -- data World 'SetterOf = Entity 210 | -- { position :: 'Update' (V2 Double) 211 | -- , graphics :: 'Update' Graphics 212 | -- , isPlayer :: 'Update' () 213 | -- } 214 | -- @ 215 | -- 216 | -- 'unchanged' provides a @world 'SetterOf@ which will update no components, 217 | -- and can have partial modifications added to it. 218 | -- 219 | -- 'delEntity' provides a @world 'SetterOf@ which will delete all components 220 | -- associated with the targeted entity. 221 | 222 | 223 | 224 | -- $querying 225 | -- #querying# The 'QueryT' monad provides functionality for performing 226 | -- computations over an 'Ent''s components. The basic primitive is 'query', 227 | -- which will pull the value of a component, and fail the query if it isn't 228 | -- set. 229 | -- 230 | -- For example, given the following world: 231 | -- 232 | -- @ 233 | -- data World s = Entity 234 | -- { position :: 'Component' s ''Field' (V2 Double) 235 | -- , velocity :: 'Component' s ''Field' (V2 Double) 236 | -- } 237 | -- deriving ('Generic') 238 | -- @ 239 | -- 240 | -- we could model a discrete time simulation via: 241 | -- 242 | -- @ 243 | -- stepTime :: 'System' World () 244 | -- stepTime = do 245 | -- 'emap' 'allEnts' $ do 246 | -- pos <- 'query' position 247 | -- vel <- 'query' velocity 248 | -- pure $ 'unchanged' 249 | -- { position = 'Set' $ pos + vel 250 | -- } 251 | -- @ 252 | -- 253 | -- which will add an entity's velocity to its position, so long as it has both 254 | -- components to begin with. 255 | 256 | 257 | -------------------------------------------------------------------------------- /src/Data/Ecstasy/Internal/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE NoMonomorphismRestriction #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Data.Ecstasy.Internal.Deriving where 15 | 16 | import Control.Monad.Codensity 17 | import Control.Monad.Trans.Class (MonadTrans (..)) 18 | import Data.Ecstasy.Types (Update (..), VTable (..), Ent (..), Hooks, defHooks, Component, ComponentType(..), StorageType(..)) 19 | import Data.IntMap (IntMap) 20 | import qualified Data.IntMap as I 21 | import Data.Proxy (Proxy (..)) 22 | import GHC.Generics 23 | import GHC.TypeLits 24 | 25 | 26 | ------------------------------------------------------------------------------ 27 | -- | Utility class for implementing 'Data.Ecstasy.Internal.hoistStorage'. 28 | class GHoistWorld (t :: (* -> *) -> * -> *) (m :: * -> *) a b where 29 | gHoistWorld :: a x -> b x 30 | 31 | instance {-# OVERLAPPING #-} (MonadTrans t, Functor (t m), Monad m) 32 | => GHoistWorld t m (K1 i (VTable m a)) (K1 i' (VTable (t m) a)) where 33 | gHoistWorld (K1 (VTable g s)) = K1 $ VTable (fmap lift g) (fmap (fmap lift) s) 34 | {-# INLINE gHoistWorld #-} 35 | 36 | instance {-# OVERLAPPABLE #-} GHoistWorld t m (K1 i a) (K1 i' a) where 37 | gHoistWorld (K1 a) = K1 a 38 | {-# INLINE gHoistWorld #-} 39 | 40 | instance (Functor (t m), GHoistWorld t m f f') 41 | => GHoistWorld t m (M1 i c f) (M1 i' c' f') where 42 | gHoistWorld (M1 a) = M1 $ gHoistWorld @t @m a 43 | {-# INLINE gHoistWorld #-} 44 | 45 | instance (Applicative (t m), GHoistWorld t m a c, GHoistWorld t m b d) 46 | => GHoistWorld t m (a :*: b) (c :*: d) where 47 | gHoistWorld (a :*: b) = gHoistWorld @t @m a :*: gHoistWorld @t @m b 48 | {-# INLINE gHoistWorld #-} 49 | 50 | 51 | ------------------------------------------------------------------------------ 52 | -- | Utility class for implementing 'Data.Ecstasy.Internal.graftStorage'. 53 | class GGraft a b where 54 | gGraft :: a x -> b x -> a x 55 | 56 | instance {-# OVERLAPPING #-} GGraft (K1 i (VTable m a)) 57 | (K1 i' (VTable (t m) a)) where 58 | gGraft a _ = a 59 | {-# INLINE gGraft #-} 60 | 61 | instance GGraft (K1 i a) (K1 i' a) where 62 | gGraft _ (K1 a) = K1 a 63 | {-# INLINE gGraft #-} 64 | 65 | instance (GGraft f f') => GGraft (M1 i c f) (M1 i' c' f') where 66 | gGraft (M1 a) (M1 e) = M1 $ gGraft a e 67 | {-# INLINE gGraft #-} 68 | 69 | instance (GGraft a c, GGraft b d) => GGraft (a :*: b) (c :*: d) where 70 | gGraft (a :*: b) (c :*: d) = gGraft a c :*: gGraft b d 71 | {-# INLINE gGraft #-} 72 | 73 | 74 | 75 | ------------------------------------------------------------------------------ 76 | -- | Utility class for implementing 'Data.Ecstasy.Internal.convertSetter'. 77 | class GConvertSetter a b where 78 | gConvertSetter :: a x -> b x 79 | 80 | instance GConvertSetter (K1 i a) (K1 i' (Maybe a)) where 81 | gConvertSetter (K1 a) = K1 $ Just a 82 | {-# INLINE gConvertSetter #-} 83 | 84 | instance GConvertSetter (K1 i a) (K1 i' (Update a)) where 85 | gConvertSetter (K1 a) = K1 $ Set a 86 | {-# INLINE gConvertSetter #-} 87 | 88 | instance GConvertSetter (K1 i (Maybe a)) (K1 i' (Update a)) where 89 | gConvertSetter (K1 (Just a)) = K1 $ Set a 90 | gConvertSetter (K1 Nothing) = K1 Unset 91 | {-# INLINE gConvertSetter #-} 92 | 93 | instance GConvertSetter f f' 94 | => GConvertSetter (M1 i c f) (M1 i' c' f') where 95 | gConvertSetter (M1 a) = M1 $ gConvertSetter a 96 | {-# INLINE gConvertSetter #-} 97 | 98 | instance (GConvertSetter a c, GConvertSetter b d) 99 | => GConvertSetter (a :*: b) (c :*: d) where 100 | gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b 101 | {-# INLINE gConvertSetter #-} 102 | 103 | 104 | ------------------------------------------------------------------------------ 105 | -- | Utility class for implementing 'Data.Ecstasy.Internal.getEntity'. 106 | class GGetEntity m a b where 107 | gGetEntity :: a x -> Int -> Codensity m (b x) 108 | 109 | instance (Monad m) 110 | => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where 111 | gGetEntity (K1 (VTable vget _)) e = lift $ fmap K1 $ vget $ Ent e 112 | {-# INLINE gGetEntity #-} 113 | 114 | instance Applicative m 115 | => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where 116 | gGetEntity (K1 a) e = pure . K1 $ I.lookup e $ a 117 | {-# INLINE gGetEntity #-} 118 | 119 | instance Applicative m 120 | => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where 121 | gGetEntity (K1 (Just (e', a))) e | e == e' = pure . K1 $ Just a 122 | gGetEntity _ _ = pure $ K1 Nothing 123 | {-# INLINE gGetEntity #-} 124 | 125 | instance (Functor m, GGetEntity m f f') 126 | => GGetEntity m (M1 i c f) (M1 i' c' f') where 127 | gGetEntity (M1 a) e = fmap M1 $ gGetEntity a e 128 | {-# INLINE gGetEntity #-} 129 | 130 | instance (Applicative m, GGetEntity m a c, GGetEntity m b d) 131 | => GGetEntity m (a :*: b) (c :*: d) where 132 | gGetEntity (a :*: b) e = (:*:) <$> gGetEntity a e <*> gGetEntity b e 133 | {-# INLINE gGetEntity #-} 134 | 135 | 136 | ------------------------------------------------------------------------------ 137 | -- | Utility class for implementing 'Data.Ecstasy.Internal.query' 138 | class GetField (c :: ComponentType) where 139 | getField 140 | :: Monad m 141 | => Component ('WorldOf m) c a 142 | -> Int 143 | -> m (Maybe a) 144 | 145 | instance GetField 'Field where 146 | getField c i = pure $ I.lookup i c 147 | 148 | instance GetField 'Unique where 149 | getField c i = pure $ c >>= \(i', a) -> 150 | case i == i' of 151 | True -> Just a 152 | False -> Nothing 153 | 154 | instance GetField 'Virtual where 155 | getField VTable{vget} i = vget $ Ent i 156 | 157 | 158 | ------------------------------------------------------------------------------ 159 | -- | Utility class for implementing 'Data.Ecstasy.Internal.setEntity'. 160 | class GSetEntity m a b where 161 | gSetEntity :: a x -> Int -> b x -> Codensity m (b x) 162 | 163 | instance Applicative m 164 | => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where 165 | gSetEntity (K1 (Set a)) e _ = pure . K1 $ Just (e, a) 166 | gSetEntity (K1 (Modify _)) _ _ = error "shit what happens here" 167 | gSetEntity (K1 Unset) e (K1 (Just (e', b))) = 168 | pure $ if e == e' 169 | then K1 Nothing 170 | else K1 $ Just (e', b) 171 | gSetEntity _ _ (K1 b) = pure $ K1 b 172 | {-# INLINE gSetEntity #-} 173 | 174 | instance (Monad m) 175 | => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where 176 | gSetEntity (K1 a) e (K1 z@(VTable _ vset)) = 177 | lift (vset (Ent e) a) *> pure (K1 z) 178 | {-# INLINE gSetEntity #-} 179 | 180 | instance Applicative m 181 | => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where 182 | gSetEntity (K1 Keep) _ (K1 b) = pure $ K1 b 183 | gSetEntity (K1 (Set a)) e (K1 b) = pure . K1 $ I.alter (const $ Just a) e b 184 | gSetEntity (K1 Unset) e (K1 b) = pure . K1 $ I.alter (const Nothing) e b 185 | gSetEntity (K1 (Modify f)) e (K1 b) = pure . K1 $ I.alter (fmap f) e b 186 | {-# INLINE gSetEntity #-} 187 | 188 | instance (Functor m, GSetEntity m f f') 189 | => GSetEntity m (M1 i c f) (M1 i' c' f') where 190 | gSetEntity (M1 a) e (M1 b) = fmap M1 $ gSetEntity a e b 191 | {-# INLINE gSetEntity #-} 192 | 193 | instance (Applicative m, GSetEntity m a c, GSetEntity m b d) 194 | => GSetEntity m (a :*: b) (c :*: d) where 195 | gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c 196 | <*> gSetEntity b e d 197 | {-# INLINE gSetEntity #-} 198 | 199 | 200 | def :: forall keep a. (Generic a, GDefault keep (Rep a)) => a 201 | def = to $ gdef @keep 202 | {-# INLINE def #-} 203 | 204 | 205 | ------------------------------------------------------------------------------ 206 | -- | Utility class for implementing various defaults. The 'keep' parameter is 207 | -- used to statically describe whether or not to keep the previous value when 208 | -- dealing with 'Update' fields. 209 | class GDefault (keep :: Bool) f where 210 | gdef :: f a 211 | 212 | instance GDefault keep U1 where 213 | gdef = U1 214 | {-# INLINE gdef #-} 215 | 216 | instance GDefault keep (K1 i (Maybe c)) where 217 | gdef = K1 Nothing 218 | {-# INLINE gdef #-} 219 | 220 | instance GDefault 'False (K1 i (Update c)) where 221 | gdef = K1 Unset 222 | {-# INLINE gdef #-} 223 | 224 | instance GDefault 'True (K1 i (Update c)) where 225 | gdef = K1 Keep 226 | {-# INLINE gdef #-} 227 | 228 | instance GDefault keep (K1 i (IntMap c)) where 229 | gdef = K1 I.empty 230 | {-# INLINE gdef #-} 231 | 232 | instance Monad m => GDefault keep (K1 i (Hooks w m)) where 233 | gdef = K1 defHooks 234 | {-# INLINE gdef #-} 235 | 236 | instance {-# OVERLAPPING #-} (Applicative m, KnownSymbol sym) 237 | => GDefault keep (M1 S ('MetaSel ('Just sym) x y z) 238 | (K1 i (VTable m a))) where 239 | gdef = M1 $ K1 $ VTable (const err) (const $ const err) 240 | where 241 | err :: err 242 | err = error $ mconcat 243 | [ "unset VTable for Virtual component '" 244 | , symbolVal $ Proxy @sym 245 | , "'" 246 | ] 247 | {-# INLINE gdef #-} 248 | 249 | instance GDefault keep f => GDefault keep (M1 i c f) where 250 | gdef = M1 $ gdef @keep 251 | {-# INLINE gdef #-} 252 | 253 | instance (GDefault keep a, GDefault keep b) 254 | => GDefault keep (a :*: b) where 255 | gdef = gdef @keep :*: gdef @keep 256 | {-# INLINE gdef #-} 257 | 258 | -------------------------------------------------------------------------------- /src/Data/Ecstasy/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE MonoLocalBinds #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TupleSections #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | {-# LANGUAGE ViewPatterns #-} 16 | 17 | module Data.Ecstasy.Internal where 18 | 19 | import Control.Applicative (empty) 20 | import Control.Monad (void) 21 | import Control.Monad.Codensity (lowerCodensity) 22 | import Control.Monad.IO.Class (MonadIO (..)) 23 | import Control.Monad.Trans.Class (MonadTrans (..)) 24 | import Control.Monad.Trans.Maybe (runMaybeT, MaybeT (..)) 25 | import qualified Control.Monad.Trans.Reader as R 26 | import Data.Coerce 27 | import Data.Ecstasy.Internal.Deriving 28 | import qualified Data.Ecstasy.Types as T 29 | import Data.Ecstasy.Types hiding (unEnt) 30 | import Data.Foldable (for_) 31 | import Data.IORef 32 | import qualified Data.IntMap as IM 33 | import Data.Maybe (catMaybes) 34 | import Data.Traversable (for) 35 | import GHC.Generics 36 | import Lens.Micro ((.~)) 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | -- | This class provides all of the functionality necessary to manipulate the 41 | -- ECS. 42 | class (Monad m, MonadIO m, HasWorld' world) => HasWorld world m where 43 | 44 | ---------------------------------------------------------------------------- 45 | -- | Fetches an entity from the world given its 'Ent'. 46 | getEntity 47 | :: Monad m 48 | => Ent 49 | -> SystemT world m (world 'FieldOf) 50 | default getEntity 51 | :: ( Monad m 52 | , GGetEntity m 53 | (Rep (world ('WorldOf m))) 54 | (Rep (world 'FieldOf)) 55 | , Generic (world 'FieldOf) 56 | , Generic (world ('WorldOf m)) 57 | ) 58 | => Ent 59 | -> SystemT world m (world 'FieldOf) 60 | getEntity e = do 61 | w <- getWorld 62 | lift . lowerCodensity 63 | . fmap to 64 | . gGetEntity @m (from w) 65 | $ T.unEnt e 66 | {-# INLINE getEntity #-} 67 | 68 | ---------------------------------------------------------------------------- 69 | -- | Updates an 'Ent' in the world given its setter. 70 | setEntity 71 | :: Ent 72 | -> world 'SetterOf 73 | -> SystemT world m () 74 | default setEntity 75 | :: ( GSetEntity m 76 | (Rep (world 'SetterOf)) 77 | (Rep (world ('WorldOf m))) 78 | , Generic (world ('WorldOf m)) 79 | , Generic (world 'SetterOf) 80 | , Monad m 81 | ) 82 | => Ent 83 | -> world 'SetterOf 84 | -> SystemT world m () 85 | setEntity e s = do 86 | w <- getWorld 87 | x <- lift . lowerCodensity 88 | . fmap to 89 | . gSetEntity (from s) (T.unEnt e) 90 | $ from w 91 | modify $ ssWorld .~ x 92 | {-# INLINE setEntity #-} 93 | 94 | ---------------------------------------------------------------------------- 95 | -- | The default world, which contains only empty containers. 96 | defStorage :: world ('WorldOf m) 97 | default defStorage 98 | :: ( Generic (world ('WorldOf m)) 99 | , GDefault 'True (Rep (world ('WorldOf m))) 100 | ) 101 | => world ('WorldOf m) 102 | defStorage = def @'True 103 | {-# INLINE defStorage #-} 104 | 105 | 106 | class HasWorld' world where 107 | ---------------------------------------------------------------------------- 108 | -- | Transforms an entity into a setter to transform the default entity into 109 | -- the given one. Used by 'createEntity'. 110 | convertSetter 111 | :: world 'FieldOf 112 | -> world 'SetterOf 113 | default convertSetter 114 | :: ( GConvertSetter (Rep (world 'FieldOf)) 115 | (Rep (world 'SetterOf)) 116 | , Generic (world 'FieldOf) 117 | , Generic (world 'SetterOf) 118 | ) 119 | => world 'FieldOf 120 | -> world 'SetterOf 121 | convertSetter = to . gConvertSetter . from 122 | {-# INLINE convertSetter #-} 123 | 124 | ---------------------------------------------------------------------------- 125 | -- | The default entity, owning no components. 126 | newEntity :: world 'FieldOf 127 | default newEntity 128 | :: ( Generic (world 'FieldOf) 129 | , GDefault 'True (Rep (world 'FieldOf)) 130 | ) 131 | => world 'FieldOf 132 | newEntity = def @'True 133 | {-# INLINE newEntity #-} 134 | 135 | ---------------------------------------------------------------------------- 136 | -- | The default setter, which keeps all components with their previous value. 137 | unchanged :: world 'SetterOf 138 | default unchanged 139 | :: ( Generic (world 'SetterOf) 140 | , GDefault 'True (Rep (world 'SetterOf)) 141 | ) 142 | => world 'SetterOf 143 | unchanged = def @'True 144 | {-# INLINE unchanged #-} 145 | 146 | ---------------------------------------------------------------------------- 147 | -- | A setter which will delete the entity if its 'QueryT' matches. 148 | delEntity :: world 'SetterOf 149 | default delEntity 150 | :: ( Generic (world 'SetterOf) 151 | , GDefault 'False (Rep (world 'SetterOf)) 152 | ) 153 | => world 'SetterOf 154 | delEntity = def @'False 155 | {-# INLINE delEntity #-} 156 | 157 | 158 | instance ( Generic (world 'SetterOf) 159 | , Generic (world 'FieldOf) 160 | , GConvertSetter (Rep (world 'FieldOf)) 161 | (Rep (world 'SetterOf)) 162 | , GDefault 'True (Rep (world 'FieldOf)) 163 | , GDefault 'False (Rep (world 'SetterOf)) 164 | , GDefault 'True (Rep (world 'SetterOf)) 165 | ) => HasWorld' world 166 | 167 | 168 | instance ( HasWorld' world 169 | , Generic (world 'SetterOf) 170 | , Generic (world ('WorldOf m)) 171 | , Generic (world 'FieldOf) 172 | , GConvertSetter (Rep (world 'FieldOf)) 173 | (Rep (world 'SetterOf)) 174 | , GDefault 'True (Rep (world 'FieldOf)) 175 | , GDefault 'False (Rep (world 'SetterOf)) 176 | , GDefault 'True (Rep (world 'SetterOf)) 177 | , GDefault 'True (Rep (world ('WorldOf m))) 178 | , GSetEntity m 179 | (Rep (world 'SetterOf)) 180 | (Rep (world ('WorldOf m))) 181 | , GGetEntity m 182 | (Rep (world ('WorldOf m))) 183 | (Rep (world 'FieldOf)) 184 | , Monad m 185 | , MonadIO m 186 | ) => HasWorld world m 187 | 188 | 189 | ------------------------------------------------------------------------------ 190 | -- | Utilities for defining 'surgery'. 191 | class StorageSurgeon t m world where 192 | ---------------------------------------------------------------------------- 193 | -- | Hoist storage through a monad transformer. 194 | hoistStorage 195 | :: world ('WorldOf m) 196 | -> world ('WorldOf (t m)) 197 | default hoistStorage 198 | :: ( Generic (world ('WorldOf m)) 199 | , Generic (world ('WorldOf (t m))) 200 | , GHoistWorld t m 201 | (Rep (world ('WorldOf m))) 202 | (Rep (world ('WorldOf (t m)))) 203 | ) 204 | => world ('WorldOf m) 205 | -> world ('WorldOf (t m)) 206 | hoistStorage = to . gHoistWorld @t @m . from 207 | {-# INLINE hoistStorage #-} 208 | 209 | ---------------------------------------------------------------------------- 210 | -- | Grafts two worlds together, using data from the second argument and 211 | -- vtables from the first. 212 | graftStorage 213 | :: world ('WorldOf m) 214 | -> world ('WorldOf (t m)) 215 | -> world ('WorldOf m) 216 | default graftStorage 217 | :: ( Generic (world ('WorldOf m)) 218 | , Generic (world ('WorldOf (t m))) 219 | , GGraft (Rep (world ('WorldOf m))) 220 | (Rep (world ('WorldOf (t m)))) 221 | ) 222 | => world ('WorldOf m) 223 | -> world ('WorldOf (t m)) 224 | -> world ('WorldOf m) 225 | graftStorage a b = to $ gGraft (from a) (from b) 226 | {-# INLINE graftStorage #-} 227 | 228 | 229 | instance ( Generic (world ('WorldOf m)) 230 | , Generic (world ('WorldOf (t m))) 231 | , GHoistWorld t m (Rep (world ('WorldOf m))) 232 | (Rep (world ('WorldOf (t m)))) 233 | , GGraft (Rep (world ('WorldOf m))) 234 | (Rep (world ('WorldOf (t m)))) 235 | , MonadTrans t 236 | ) => StorageSurgeon t m world 237 | 238 | 239 | ------------------------------------------------------------------------------ 240 | -- | Run a monad transformer /underneath/ a 'SystemT'. 241 | -- 242 | -- Due to the recursive interactions between 'SystemT' and 'QueryT', we're 243 | -- often unable to put a temporary monad transformer on the top of the stack. 244 | -- As a result, often 'surgery' is our ony means of introducting ephemeral 245 | -- effects. 246 | -- 247 | -- @ 248 | -- draw :: 'SystemT' World IO [Graphics] 249 | -- draw = fmap fst . 'surgery' runWriterT $ 250 | -- for_ thingsToRender $ \\thingy -> 251 | -- tell [thingy] 252 | -- @ 253 | -- 254 | -- Note: Any hooks installed will *not* be run under surgery. 255 | surgery 256 | :: ( Monad (t m) 257 | , MonadIO (t m) 258 | , Monad m 259 | , MonadIO m 260 | , StorageSurgeon t m world 261 | ) 262 | => (forall x. t m x -> m (x, b)) 263 | -> SystemT world (t m) a 264 | -> SystemT world m (b, a) 265 | surgery f m = SystemT $ R.ReaderT $ \ref -> do 266 | SystemState i s h <- liftIO $ readIORef ref 267 | ((SystemState i' s' _, a), b) <- 268 | f $ yieldSystemT (SystemState i (hoistStorage s) defHooks) m 269 | liftIO . writeIORef ref $ SystemState i' (graftStorage s s') h 270 | pure (b, a) 271 | 272 | 273 | ------------------------------------------------------------------------------ 274 | -- | Retrieve a unique 'Ent'. 275 | nextEntity 276 | :: (Monad m, MonadIO m) 277 | => SystemT a m Ent 278 | nextEntity = do 279 | e <- gets _ssNextId 280 | modify $ ssNextId .~ e + 1 281 | pure $ Ent e 282 | 283 | 284 | ------------------------------------------------------------------------------ 285 | -- | Create a new entity. 286 | createEntity 287 | :: (HasWorld world m, Monad m) 288 | => world 'FieldOf 289 | -> SystemT world m Ent 290 | createEntity cs = do 291 | h <- gets _ssHooks 292 | e <- nextEntity 293 | setEntity e $ convertSetter cs 294 | hookNewEnt h e 295 | pure e 296 | 297 | 298 | ------------------------------------------------------------------------------ 299 | -- | Delete an entity. 300 | deleteEntity 301 | :: (HasWorld world m, Monad m) 302 | => Ent 303 | -> SystemT world m () 304 | deleteEntity e = do 305 | h <- gets _ssHooks 306 | hookDelEnt h e 307 | setEntity e delEntity 308 | 309 | 310 | ------------------------------------------------------------------------------ 311 | -- | Evaluate a 'QueryT'. 312 | unQueryT 313 | :: QueryT world m a 314 | -> Ent 315 | -> SystemState world m 316 | -> m (Maybe a) 317 | unQueryT q e f = runMaybeT $ flip R.runReaderT (e, f) $ runQueryT' q 318 | 319 | 320 | ------------------------------------------------------------------------------ 321 | -- | Map a 'QueryT' transformation over all entites that match it. 322 | emap 323 | :: ( HasWorld world m 324 | , Monad m 325 | ) 326 | => EntTarget world m 327 | -> QueryT world m (world 'SetterOf) 328 | -> SystemT world m () 329 | emap t f = do 330 | world <- gets id 331 | let es = t world 332 | for_ es $ \e -> do 333 | cs <- gets id 334 | sets <- lift $ unQueryT f e cs 335 | for_ sets $ setEntity e 336 | 337 | 338 | ------------------------------------------------------------------------------ 339 | -- | Collect the results of a monadic computation over every entity matching 340 | -- a 'QueryT'. 341 | efor 342 | :: ( HasWorld world m 343 | , Monad m 344 | , MonadIO m 345 | ) 346 | => EntTarget world m 347 | -> QueryT world m a 348 | -> SystemT world m [a] 349 | efor t f = do 350 | world <- gets id 351 | let es = t world 352 | fmap catMaybes $ for es $ \e -> do 353 | cs <- gets id 354 | lift $ unQueryT f e cs 355 | 356 | 357 | ------------------------------------------------------------------------------ 358 | -- | Do an 'emap' and an 'efor' at the same time. 359 | eover 360 | :: ( HasWorld world m 361 | , MonadIO m 362 | , Monad m 363 | ) 364 | => EntTarget world m 365 | -> QueryT world m (a, world 'SetterOf) 366 | -> SystemT world m [a] 367 | eover t f = do 368 | world <- gets id 369 | let es = t world 370 | fmap catMaybes $ for es $ \e -> do 371 | cs <- gets id 372 | mset <- lift $ unQueryT f e cs 373 | for mset $ \(a, setter) -> do 374 | setEntity e setter 375 | pure a 376 | 377 | 378 | ------------------------------------------------------------------------------ 379 | -- | Run a 'QueryT' over a particular 'Ent'. 380 | runQueryT 381 | :: ( HasWorld world m 382 | , Monad m 383 | , MonadIO m 384 | ) 385 | => Ent 386 | -> QueryT world m a 387 | -> SystemT world m (Maybe a) 388 | runQueryT e qt = do 389 | cs <- gets id 390 | lift $ unQueryT qt e cs 391 | 392 | 393 | getWorld :: (MonadIO m, Monad m) => SystemT world m (world ('WorldOf m)) 394 | getWorld = gets _ssWorld 395 | 396 | 397 | ------------------------------------------------------------------------------ 398 | -- | Provides a resumable 'SystemT'. This is a pretty big hack until I come up 399 | -- with a better formalization for everything. 400 | yieldSystemT 401 | :: (MonadIO m, Monad m) 402 | => SystemState world m 403 | -> SystemT world m a 404 | -> m (SystemState world m, a) 405 | yieldSystemT ss m = do 406 | ref <- liftIO $ newIORef ss 407 | a <- R.runReaderT (runSystemT' m) ref 408 | ss' <- liftIO $ readIORef ref 409 | pure (ss', a) 410 | 411 | 412 | ------------------------------------------------------------------------------ 413 | -- | Evaluate a 'SystemT'. 414 | runSystemT 415 | :: (Monad m, MonadIO m) 416 | => world ('WorldOf m) 417 | -> SystemT world m a 418 | -> m a 419 | runSystemT w m = do 420 | ref <- liftIO . newIORef $ SystemState 0 w defHooks 421 | R.runReaderT (runSystemT' m) ref 422 | 423 | 424 | ------------------------------------------------------------------------------ 425 | -- | Only evaluate this 'QueryT' for entities which have the given component. 426 | with 427 | :: forall m c a world 428 | . ( Monad m 429 | , GetField c 430 | , IsInjective m c a 431 | ) 432 | => (world ('WorldOf m) -> Component ('WorldOf m) c a) 433 | -> QueryT world m () 434 | with = void . query @c @a 435 | {-# INLINE with #-} 436 | 437 | 438 | ------------------------------------------------------------------------------ 439 | -- | Only evaluate this 'QueryT' for entities which do not have the given 440 | -- component. 441 | without 442 | :: forall m c a world 443 | . ( Monad m 444 | , GetField c 445 | , IsInjective m c a 446 | ) 447 | => (world ('WorldOf m) -> Component ('WorldOf m) c a) 448 | -> QueryT world m () 449 | without f = queryMaybe @c @a f >>= maybe (pure ()) (const empty) 450 | 451 | 452 | ------------------------------------------------------------------------------ 453 | -- | Get the value of a component, failing the 'QueryT' if it isn't present. 454 | query 455 | :: forall c a m world 456 | . ( Monad m 457 | , GetField c 458 | , IsInjective m c a 459 | ) 460 | => (world ('WorldOf m) -> Component ('WorldOf m) c a) 461 | -> QueryT world m a 462 | query f = queryMaybe f >>= maybe empty pure 463 | 464 | 465 | queryTarget 466 | :: Monad m 467 | => EntTarget world m 468 | -> QueryT world m [Ent] 469 | queryTarget t = do 470 | (_, w) <- QueryT R.ask 471 | pure $ t w 472 | 473 | ------------------------------------------------------------------------------ 474 | -- | Run a subquery inside of a 'QueryT'. 475 | subquery 476 | :: ( HasWorld world m 477 | , Monad m 478 | , MonadIO m 479 | ) 480 | => EntTarget world m 481 | -> QueryT world m a 482 | -> QueryT world m [a] 483 | subquery t q = do 484 | (_, w) <- QueryT R.ask 485 | let es = t w 486 | fmap catMaybes $ for es $ \e -> do 487 | lift $ unQueryT q e w 488 | 489 | 490 | ------------------------------------------------------------------------------ 491 | -- | Attempt to get the value of a component. 492 | queryMaybe 493 | :: forall c a m world 494 | . ( Monad m 495 | , GetField c 496 | , IsInjective m c a 497 | ) 498 | => (world ('WorldOf m) -> Component ('WorldOf m) c a) 499 | -> QueryT world m (Maybe a) 500 | queryMaybe f = do 501 | (Ent e, w) <- QueryT R.ask 502 | lift $ getField @c (f $ _ssWorld w) e 503 | 504 | 505 | ------------------------------------------------------------------------------ 506 | -- | Attempt to get the owner and value of a unique component. 507 | queryUnique 508 | :: ( Monad m 509 | ) 510 | => (world ('WorldOf m) -> Component ('WorldOf m) 'Unique a) 511 | -> QueryT world m (Maybe (Ent, a)) 512 | queryUnique f = do 513 | (_, w) <- QueryT R.ask 514 | pure $ coerce $ f $ _ssWorld w 515 | 516 | 517 | ------------------------------------------------------------------------------ 518 | -- | Get the 'Ent' for whom this query is running. 519 | queryEnt 520 | :: Monad m 521 | => QueryT world m Ent 522 | queryEnt = QueryT $ R.asks fst 523 | 524 | 525 | ------------------------------------------------------------------------------ 526 | -- | Get the 'Ent' for whom this query is running. 527 | querySelf 528 | :: (MonadIO m, HasWorld world m) 529 | => QueryT world m (world 'FieldOf) 530 | querySelf = QueryT $ R.ReaderT $ \(e, w) -> 531 | MaybeT $ fmap Just $ runSystemT (_ssWorld w) $ getEntity e 532 | 533 | 534 | ------------------------------------------------------------------------------ 535 | -- | Query a flag as a 'Bool'. 536 | queryFlag 537 | :: forall m c a world 538 | . ( Monad m 539 | , GetField c 540 | , IsInjective m c a 541 | ) 542 | => (world ('WorldOf m) -> Component ('WorldOf m) c a) 543 | -> QueryT world m Bool 544 | queryFlag = fmap (maybe False (const True)) . queryMaybe @c @a 545 | 546 | 547 | ------------------------------------------------------------------------------ 548 | -- | Perform a query with a default. 549 | queryDef 550 | :: forall m c a world. ( Monad m 551 | , GetField c 552 | , IsInjective m c a 553 | ) 554 | => a 555 | -> (world ('WorldOf m) -> Component ('WorldOf m) c a) 556 | -> QueryT world m a 557 | queryDef z = fmap (maybe z id) . queryMaybe @c 558 | 559 | 560 | ------------------------------------------------------------------------------ 561 | -- | An 'EntTarget' is a set of 'Ent's to iterate over. 562 | type EntTarget world m = SystemState world m -> [Ent] 563 | 564 | 565 | ------------------------------------------------------------------------------ 566 | -- | Lifted 'gets' for 'SystemT'. 567 | gets 568 | :: (Monad m, MonadIO m) 569 | => (SystemState world m -> a) 570 | -> SystemT world m a 571 | gets f = do 572 | ref <- SystemT R.ask 573 | ss <- liftIO $ readIORef ref 574 | pure $ f ss 575 | 576 | 577 | ------------------------------------------------------------------------------ 578 | -- | Lifted 'modify' for 'SystemT'. 579 | modify 580 | :: (Monad m, MonadIO m) 581 | => (SystemState world m -> SystemState world m) 582 | -> SystemT world m () 583 | modify f = do 584 | ref <- SystemT R.ask 585 | liftIO $ modifyIORef ref f 586 | 587 | 588 | ------------------------------------------------------------------------------ 589 | -- | Iterate over all entities. 590 | allEnts :: (MonadIO m, Monad m) => EntTarget world m 591 | allEnts world = coerce [0 .. _ssNextId world - 1] 592 | 593 | 594 | entsWith 595 | :: (MonadIO m, Monad m) 596 | => (world ('WorldOf m) -> Component ('WorldOf m) 'Field a) 597 | -> EntTarget world m 598 | entsWith f = coerce . IM.keys . f . _ssWorld 599 | 600 | 601 | ------------------------------------------------------------------------------ 602 | -- | Target the entity uniquely identified by owning a 'Unique' field. 603 | uniqueEnt 604 | :: ( Monad m 605 | , MonadIO m 606 | ) 607 | => (world ('WorldOf m) -> Component ('WorldOf m) 'Unique a) 608 | -> EntTarget world m 609 | uniqueEnt f = maybe [] (pure . coerce . fst) . f . _ssWorld 610 | 611 | 612 | ------------------------------------------------------------------------------ 613 | -- | Iterate over some entities. 614 | someEnts :: Monad m => [Ent] -> EntTarget world m 615 | someEnts = pure 616 | 617 | 618 | ------------------------------------------------------------------------------ 619 | -- | Iterate over an entity. 620 | anEnt :: Monad m => Ent -> EntTarget world m 621 | anEnt = pure . pure 622 | 623 | 624 | ------------------------------------------------------------------------------ 625 | -- | Turn a 'Maybe' into an 'Update'. 626 | maybeToUpdate :: Maybe a -> Update a 627 | maybeToUpdate Nothing = Unset 628 | maybeToUpdate (Just a) = Set a 629 | 630 | --------------------------------------------------------------------------------