apecs-stm (empty) → 0.1.0

raw patch · 7 files changed

+290/−0 lines, 7 filesdep +apecsdep +basedep +containerssetup-changed

Dependencies added: apecs, base, containers, list-t, stm, stm-containers, template-haskell, vector

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +6/−0
Setup.hs +2/−0
apecs-stm.cabal +40/−0
src/Apecs/STM.hs +194/−0
src/Apecs/STM/Prelude.hs +13/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+## [Unreleased]++## [0.1.0]+### Added+- Split out the STM parts of the main apecs package

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Jonas Carpay (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jonas Carpay nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,6 @@+# apecs-stm+Experimental STM stores, allow apecs to be run in the STM monad.+```haskell+atomically . cmap $ \(Position p, Velocity v) -> Position (v+p)+```+Not included in the stack project until stm-containers (or similar) makes it into stackage.

+ Setup.hs view

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

+ apecs-stm.cabal view

@@ -0,0 +1,40 @@+name:                apecs-stm+version:             0.1.0+homepage:            https://github.com/jonascarpay/apecs-stm#readme+license:             BSD3+license-file:        LICENSE+author:              Jonas Carpay+maintainer:          jonascarpay@gmail.com+category:            Game, Control, Data+build-type:          Simple+cabal-version:       >=1.10+synopsis:            STM Stores for apecs+description:+  Apecs stores that live in the STM monad. These support easy concurrency without race conditions.++extra-source-files:+  README.md,+  CHANGELOG.md++source-repository head+  type:     git+  location: git://github.com/jonascarpay/apecs-stm.git++library+  hs-source-dirs:+    src+  exposed-modules:+    Apecs.STM, Apecs.STM.Prelude+  default-language:+    Haskell2010+  build-depends:+    base >= 4.7 && < 5,+    containers,+    stm,+    list-t,+    vector,+    template-haskell,+    stm-containers,+    apecs >= 0.7+  ghc-options:+    -Wall

+ src/Apecs/STM.hs view

@@ -0,0 +1,194 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}++-- | This module contains STM-supporting versions of regular apecs stores, and some convenience functions.+-- It is designed to be imported qualified, since it shadows both apecs and STM names.+-- There is also an @Apecs.STM.Prelude@ module, which can be imported by itself.+--+-- Note that if you want to be able to create entities in STM, you will also need to use a STM-supported @EntityCounter@, typically done through this module's @makeWorld@.++module Apecs.STM+  ( -- * Stores+    Map (..)+  , Unique (..)+  , Global (..)+    -- * EntityCounter+  , EntityCounter (..)+  , nextEntity, newEntity, makeWorld+    -- * STM conveniences+  , atomically, retry, check, forkSys, threadDelay, STM+  ) where++import qualified Control.Concurrent          as S+import           Control.Concurrent.STM      (STM)+import qualified Control.Concurrent.STM      as S+import           Control.Concurrent.STM.TVar as S+import           Control.Monad+import           Data.Maybe+import           Data.Monoid                 (Sum (..))+import           Data.Semigroup+import qualified Data.Vector.Unboxed         as U+import           Language.Haskell.TH+import qualified ListT                       as L+import qualified StmContainers.Map           as M++import           Apecs                       (ask, get, global, lift, liftIO,+                                              runSystem, set)+import           Apecs.Core+import           Apecs.TH                    (makeWorldNoEC)++newtype Map c = Map (M.Map Int c)+type instance Elem (Map c) = c++instance ExplInit STM (Map c) where+  explInit = Map <$> M.new+instance ExplGet STM (Map c) where+  {-# INLINE explExists #-}+  explExists (Map m) ety = isJust   <$> M.lookup ety m+  {-# INLINE explGet #-}+  explGet    (Map m) ety = fromJust <$> M.lookup ety m+instance ExplSet STM (Map c) where+  {-# INLINE explSet #-}+  explSet (Map m) ety x = M.insert x ety m+instance ExplDestroy STM (Map c) where+  {-# INLINE explDestroy #-}+  explDestroy (Map m) ety = M.delete ety m+instance ExplMembers STM (Map c) where+  {-# INLINE explMembers #-}+  explMembers (Map m) = U.unfoldrM L.uncons $ fst <$> M.listT m++instance ExplInit IO (Map c) where+  {-# INLINE explInit #-}+  explInit = S.atomically explInit+instance ExplGet IO (Map c) where+  {-# INLINE explExists #-}+  explExists m e = S.atomically $ explExists m e+  {-# INLINE explGet #-}+  explGet m e = S.atomically $ explGet m e+instance ExplSet IO (Map c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x+instance ExplDestroy IO (Map c) where+  {-# INLINE explDestroy #-}+  explDestroy m e = S.atomically $ explDestroy m e+instance ExplMembers IO (Map c) where+  {-# INLINE explMembers #-}+  explMembers m = S.atomically $ explMembers m++newtype Unique c = Unique (TVar (Maybe (Int, c)))+type instance Elem (Unique c) = c+instance ExplInit STM (Unique c) where+  explInit = Unique <$> newTVar Nothing++instance ExplGet STM (Unique c) where+  {-# INLINE explGet #-}+  explGet (Unique ref) _ = flip fmap (readTVar ref) $ \case+    Nothing -> error "Reading empty Unique"+    Just (_, c)  -> c+  {-# INLINE explExists #-}+  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVar ref++instance ExplSet STM (Unique c) where+  {-# INLINE explSet #-}+  explSet (Unique ref) ety c = writeTVar ref (Just (ety, c))++instance ExplDestroy STM (Unique c) where+  {-# INLINE explDestroy #-}+  explDestroy (Unique ref) ety = readTVar ref >>=+    mapM_ (flip when (writeTVar ref Nothing) . (==ety) . fst)++instance ExplMembers STM (Unique c) where+  {-# INLINE explMembers #-}+  explMembers (Unique ref) = flip fmap (readTVar ref) $ \case+    Nothing -> mempty+    Just (ety, _) -> U.singleton ety++instance ExplInit IO (Unique c) where+  {-# INLINE explInit #-}+  explInit = S.atomically explInit+instance ExplGet IO (Unique c) where+  {-# INLINE explExists #-}+  explExists m e = S.atomically $ explExists m e+  {-# INLINE explGet #-}+  explGet m e = S.atomically $ explGet m e+instance ExplSet IO (Unique c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x+instance ExplDestroy IO (Unique c) where+  {-# INLINE explDestroy #-}+  explDestroy m e = S.atomically $ explDestroy m e+instance ExplMembers IO (Unique c) where+  {-# INLINE explMembers #-}+  explMembers m = S.atomically $ explMembers m++newtype Global c = Global (TVar c)+type instance Elem (Global c) = c+instance Monoid c => ExplInit STM (Global c) where+  {-# INLINE explInit #-}+  explInit = Global <$> newTVar mempty+instance ExplGet STM (Global c) where+  {-# INLINE explGet #-}+  explGet (Global ref) _ = readTVar ref+  {-# INLINE explExists #-}+  explExists _ _ = return True+instance ExplSet STM (Global c) where+  {-# INLINE explSet #-}+  explSet (Global ref) _ c = writeTVar ref c++instance Monoid c => ExplInit IO (Global c) where+  {-# INLINE explInit #-}+  explInit = S.atomically explInit+instance ExplGet IO (Global c) where+  {-# INLINE explExists #-}+  explExists m e = S.atomically $ explExists m e+  {-# INLINE explGet #-}+  explGet m e = S.atomically $ explGet m e+instance ExplSet IO (Global c) where+  {-# INLINE explSet #-}+  explSet m e x = S.atomically $ explSet m e x++newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Semigroup, Monoid, Eq, Show)++instance Component EntityCounter where+  type Storage EntityCounter = Global EntityCounter++{-# INLINE nextEntity #-}+nextEntity :: (Get w m EntityCounter, Set w m EntityCounter) => SystemT w m Entity+nextEntity = do EntityCounter n <- get global+                set global (EntityCounter $ n+1)+                return (Entity . getSum $ n)++{-# INLINE newEntity #-}+newEntity :: (Set w m c, Get w m EntityCounter, Set w m EntityCounter)+          => c -> SystemT w m Entity+newEntity c = do ety <- nextEntity+                 set ety c+                 return ety++-- | Like @makeWorld@ from @Apecs@, but uses the STM @EntityCounter@+makeWorld :: String -> [Name] -> Q [Dec]+makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])++-- | @atomically@ from STM, lifted to the System level.+atomically :: SystemT w STM a -> SystemT w IO a+atomically sys = ask >>= liftIO . S.atomically . runSystem sys++-- | @retry@ from STM, lifted to the System level.+retry :: SystemT w STM a+retry = lift S.retry++-- | @check@ from STM, lifted to the System level.+check :: Bool -> SystemT w STM ()+check = lift . S.check++-- | Runs a system on a new thread.+forkSys :: SystemT w IO () -> SystemT w IO S.ThreadId+forkSys sys = ask >>= liftIO . S.forkIO . runSystem sys++-- | Suspends the current thread for a number of microseconds.+threadDelay :: Int -> SystemT w IO ()+threadDelay = liftIO . S.threadDelay

+ src/Apecs/STM/Prelude.hs view

@@ -0,0 +1,13 @@+-- | This module re-exports the apecs prelude with STM versions.++module Apecs.STM.Prelude+  ( System+  , module Apecs.STM+  , module Apecs+  ) where++import           Apecs     hiding (EntityCounter, Global, Map, System, Unique,+                            makeWorld, newEntity)+import           Apecs.STM++type System w a = SystemT w STM a