{-# 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, makeWorldAndComponents
    -- * 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           Data.Typeable (Typeable, typeRep)
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, makeMapComponentsFor)

newtype Map c = Map (M.Map Int c)
type instance Elem (Map c) = c

instance ExplInit STM (Map c) where
  explInit :: STM (Map c)
explInit = Map Int c -> Map c
forall c. Map Int c -> Map c
Map (Map Int c -> Map c) -> STM (Map Int c) -> STM (Map c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Int c)
forall key value. STM (Map key value)
M.new
instance Typeable c => ExplGet STM (Map c) where
  {-# INLINE explExists #-}
  {-# INLINE explGet #-}
  explExists :: Map c -> Int -> STM Bool
explExists (Map Map Int c
m) Int
ety = Maybe c -> Bool
forall a. Maybe a -> Bool
isJust   (Maybe c -> Bool) -> STM (Maybe c) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Map Int c -> STM (Maybe c)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup Int
ety Map Int c
m
  explGet :: Map c -> Int -> STM (Elem (Map c))
explGet    (Map Map Int c
m) Int
ety = ((Maybe c -> c) -> STM (Maybe c) -> STM c)
-> STM (Maybe c) -> (Maybe c -> c) -> STM c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe c -> c) -> STM (Maybe c) -> STM c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Map Int c -> STM (Maybe c)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup Int
ety Map Int c
m) ((Maybe c -> c) -> STM c) -> (Maybe c -> c) -> STM c
forall a b. (a -> b) -> a -> b
$ \case
    Just c
c -> c
c
    Maybe c
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"Reading non-existent STM Map component"
      , TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe c -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe c
notFound)
      , [Char]
"for entity"
      , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ety
      ]

instance ExplSet STM (Map c) where
  {-# INLINE explSet #-}
  explSet :: Map c -> Int -> Elem (Map c) -> STM ()
explSet (Map Map Int c
m) Int
ety Elem (Map c)
x = c -> Int -> Map Int c -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert c
Elem (Map c)
x Int
ety Map Int c
m
instance ExplDestroy STM (Map c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Map c -> Int -> STM ()
explDestroy (Map Map Int c
m) Int
ety = Int -> Map Int c -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete Int
ety Map Int c
m
instance ExplMembers STM (Map c) where
  {-# INLINE explMembers #-}
  explMembers :: Map c -> STM (Vector Int)
explMembers (Map Map Int c
m) = (ListT STM Int -> STM (Maybe (Int, ListT STM Int)))
-> ListT STM Int -> STM (Vector Int)
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
(b -> m (Maybe (a, b))) -> b -> m (Vector a)
U.unfoldrM ListT STM Int -> STM (Maybe (Int, ListT STM Int))
forall (m :: * -> *) a. ListT m a -> m (Maybe (a, ListT m a))
L.uncons (ListT STM Int -> STM (Vector Int))
-> ListT STM Int -> STM (Vector Int)
forall a b. (a -> b) -> a -> b
$ (Int, c) -> Int
forall a b. (a, b) -> a
fst ((Int, c) -> Int) -> ListT STM (Int, c) -> ListT STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Int c -> ListT STM (Int, c)
forall key value. Map key value -> ListT STM (key, value)
M.listT Map Int c
m

instance ExplInit IO (Map c) where
  {-# INLINE explInit #-}
  explInit :: IO (Map c)
explInit = STM (Map c) -> IO (Map c)
forall a. STM a -> IO a
S.atomically STM (Map c)
forall (m :: * -> *) s. ExplInit m s => m s
explInit
instance Typeable c => ExplGet IO (Map c) where
  {-# INLINE explExists #-}
  {-# INLINE explGet #-}
  explExists :: Map c -> Int -> IO Bool
explExists Map c
m Int
e = STM Bool -> IO Bool
forall a. STM a -> IO a
S.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Map c -> Int -> STM Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Map c
m Int
e
  explGet :: Map c -> Int -> IO (Elem (Map c))
explGet Map c
m Int
e = STM c -> IO c
forall a. STM a -> IO a
S.atomically (STM c -> IO c) -> STM c -> IO c
forall a b. (a -> b) -> a -> b
$ Map c -> Int -> STM (Elem (Map c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Map c
m Int
e
instance ExplSet IO (Map c) where
  {-# INLINE explSet #-}
  explSet :: Map c -> Int -> Elem (Map c) -> IO ()
explSet Map c
m Int
e Elem (Map c)
x = STM () -> IO ()
forall a. STM a -> IO a
S.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map c -> Int -> Elem (Map c) -> STM ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Map c
m Int
e Elem (Map c)
x
instance ExplDestroy IO (Map c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Map c -> Int -> IO ()
explDestroy Map c
m Int
e = STM () -> IO ()
forall a. STM a -> IO a
S.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map c -> Int -> STM ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy Map c
m Int
e
instance ExplMembers IO (Map c) where
  {-# INLINE explMembers #-}
  explMembers :: Map c -> IO (Vector Int)
explMembers Map c
m = STM (Vector Int) -> IO (Vector Int)
forall a. STM a -> IO a
S.atomically (STM (Vector Int) -> IO (Vector Int))
-> STM (Vector Int) -> IO (Vector Int)
forall a b. (a -> b) -> a -> b
$ Map c -> STM (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Map c
m

newtype Unique c = Unique (TVar (Maybe (Int, c)))
type instance Elem (Unique c) = c
instance ExplInit STM (Unique c) where
  explInit :: STM (Unique c)
explInit = TVar (Maybe (Int, c)) -> Unique c
forall c. TVar (Maybe (Int, c)) -> Unique c
Unique (TVar (Maybe (Int, c)) -> Unique c)
-> STM (TVar (Maybe (Int, c))) -> STM (Unique c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, c) -> STM (TVar (Maybe (Int, c)))
forall a. a -> STM (TVar a)
newTVar Maybe (Int, c)
forall a. Maybe a
Nothing

instance Typeable c => ExplGet STM (Unique c) where
  {-# INLINE explGet #-}
  explGet :: Unique c -> Int -> STM (Elem (Unique c))
explGet (Unique TVar (Maybe (Int, c))
ref) Int
_ = ((Maybe (Int, c) -> c) -> STM (Maybe (Int, c)) -> STM c)
-> STM (Maybe (Int, c)) -> (Maybe (Int, c) -> c) -> STM c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> c) -> STM (Maybe (Int, c)) -> STM c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TVar (Maybe (Int, c)) -> STM (Maybe (Int, c))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref) ((Maybe (Int, c) -> c) -> STM c) -> (Maybe (Int, c) -> c) -> STM c
forall a b. (a -> b) -> a -> b
$ \case
    Just (Int
_, c
c)  -> c
c
    Maybe (Int, c)
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"Reading non-existent STM Unique component"
      , TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (Int, c) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe (Int, c)
notFound)
      ]
  {-# INLINE explExists #-}
  explExists :: Unique c -> Int -> STM Bool
explExists (Unique TVar (Maybe (Int, c))
ref) Int
ety = Bool -> ((Int, c) -> Bool) -> Maybe (Int, c) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst) (Maybe (Int, c) -> Bool) -> STM (Maybe (Int, c)) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe (Int, c)) -> STM (Maybe (Int, c))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref

instance ExplSet STM (Unique c) where
  {-# INLINE explSet #-}
  explSet :: Unique c -> Int -> Elem (Unique c) -> STM ()
explSet (Unique TVar (Maybe (Int, c))
ref) Int
ety Elem (Unique c)
c = TVar (Maybe (Int, c)) -> Maybe (Int, c) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Int, c))
ref ((Int, c) -> Maybe (Int, c)
forall a. a -> Maybe a
Just (Int
ety, c
Elem (Unique c)
c))

instance ExplDestroy STM (Unique c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Unique c -> Int -> STM ()
explDestroy (Unique TVar (Maybe (Int, c))
ref) Int
ety = TVar (Maybe (Int, c)) -> STM (Maybe (Int, c))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref STM (Maybe (Int, c)) -> (Maybe (Int, c) -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    ((Int, c) -> STM ()) -> Maybe (Int, c) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Bool -> STM () -> STM ()) -> STM () -> Bool -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVar (Maybe (Int, c)) -> Maybe (Int, c) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Int, c))
ref Maybe (Int, c)
forall a. Maybe a
Nothing) (Bool -> STM ()) -> ((Int, c) -> Bool) -> (Int, c) -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst)

instance ExplMembers STM (Unique c) where
  {-# INLINE explMembers #-}
  explMembers :: Unique c -> STM (Vector Int)
explMembers (Unique TVar (Maybe (Int, c))
ref) = ((Maybe (Int, c) -> Vector Int)
 -> STM (Maybe (Int, c)) -> STM (Vector Int))
-> STM (Maybe (Int, c))
-> (Maybe (Int, c) -> Vector Int)
-> STM (Vector Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> Vector Int)
-> STM (Maybe (Int, c)) -> STM (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TVar (Maybe (Int, c)) -> STM (Maybe (Int, c))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref) ((Maybe (Int, c) -> Vector Int) -> STM (Vector Int))
-> (Maybe (Int, c) -> Vector Int) -> STM (Vector Int)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Int, c)
Nothing -> Vector Int
forall a. Monoid a => a
mempty
    Just (Int
ety, c
_) -> Int -> Vector Int
forall a. Unbox a => a -> Vector a
U.singleton Int
ety

instance ExplInit IO (Unique c) where
  {-# INLINE explInit #-}
  explInit :: IO (Unique c)
explInit = STM (Unique c) -> IO (Unique c)
forall a. STM a -> IO a
S.atomically STM (Unique c)
forall (m :: * -> *) s. ExplInit m s => m s
explInit
instance Typeable c => ExplGet IO (Unique c) where
  {-# INLINE explExists #-}
  explExists :: Unique c -> Int -> IO Bool
explExists Unique c
m Int
e = STM Bool -> IO Bool
forall a. STM a -> IO a
S.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Unique c -> Int -> STM Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Unique c
m Int
e
  {-# INLINE explGet #-}
  explGet :: Unique c -> Int -> IO (Elem (Unique c))
explGet Unique c
m Int
e = STM c -> IO c
forall a. STM a -> IO a
S.atomically (STM c -> IO c) -> STM c -> IO c
forall a b. (a -> b) -> a -> b
$ Unique c -> Int -> STM (Elem (Unique c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Unique c
m Int
e
instance ExplSet IO (Unique c) where
  {-# INLINE explSet #-}
  explSet :: Unique c -> Int -> Elem (Unique c) -> IO ()
explSet Unique c
m Int
e Elem (Unique c)
x = STM () -> IO ()
forall a. STM a -> IO a
S.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique c -> Int -> Elem (Unique c) -> STM ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Unique c
m Int
e Elem (Unique c)
x
instance ExplDestroy IO (Unique c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Unique c -> Int -> IO ()
explDestroy Unique c
m Int
e = STM () -> IO ()
forall a. STM a -> IO a
S.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique c -> Int -> STM ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy Unique c
m Int
e
instance ExplMembers IO (Unique c) where
  {-# INLINE explMembers #-}
  explMembers :: Unique c -> IO (Vector Int)
explMembers Unique c
m = STM (Vector Int) -> IO (Vector Int)
forall a. STM a -> IO a
S.atomically (STM (Vector Int) -> IO (Vector Int))
-> STM (Vector Int) -> IO (Vector Int)
forall a b. (a -> b) -> a -> b
$ Unique c -> STM (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Unique c
m

newtype Global c = Global (TVar c)
type instance Elem (Global c) = c
instance Monoid c => ExplInit STM (Global c) where
  {-# INLINE explInit #-}
  explInit :: STM (Global c)
explInit = TVar c -> Global c
forall c. TVar c -> Global c
Global (TVar c -> Global c) -> STM (TVar c) -> STM (Global c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> STM (TVar c)
forall a. a -> STM (TVar a)
newTVar c
forall a. Monoid a => a
mempty
instance ExplGet STM (Global c) where
  {-# INLINE explGet #-}
  explGet :: Global c -> Int -> STM (Elem (Global c))
explGet (Global TVar c
ref) Int
_ = TVar c -> STM c
forall a. TVar a -> STM a
readTVar TVar c
ref
  {-# INLINE explExists #-}
  explExists :: Global c -> Int -> STM Bool
explExists Global c
_ Int
_ = Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
instance ExplSet STM (Global c) where
  {-# INLINE explSet #-}
  explSet :: Global c -> Int -> Elem (Global c) -> STM ()
explSet (Global TVar c
ref) Int
_ Elem (Global c)
c = TVar c -> c -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar c
ref c
Elem (Global c)
c

instance Monoid c => ExplInit IO (Global c) where
  {-# INLINE explInit #-}
  explInit :: IO (Global c)
explInit = STM (Global c) -> IO (Global c)
forall a. STM a -> IO a
S.atomically STM (Global c)
forall (m :: * -> *) s. ExplInit m s => m s
explInit
instance ExplGet IO (Global c) where
  {-# INLINE explExists #-}
  explExists :: Global c -> Int -> IO Bool
explExists Global c
m Int
e = STM Bool -> IO Bool
forall a. STM a -> IO a
S.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Global c -> Int -> STM Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Global c
m Int
e
  {-# INLINE explGet #-}
  explGet :: Global c -> Int -> IO (Elem (Global c))
explGet Global c
m Int
e = STM c -> IO c
forall a. STM a -> IO a
S.atomically (STM c -> IO c) -> STM c -> IO c
forall a b. (a -> b) -> a -> b
$ Global c -> Int -> STM (Elem (Global c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Global c
m Int
e
instance ExplSet IO (Global c) where
  {-# INLINE explSet #-}
  explSet :: Global c -> Int -> Elem (Global c) -> IO ()
explSet Global c
m Int
e Elem (Global c)
x = STM () -> IO ()
forall a. STM a -> IO a
S.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Global c -> Int -> Elem (Global c) -> STM ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Global c
m Int
e Elem (Global c)
x

newtype EntityCounter = EntityCounter {EntityCounter -> Sum Int
getCounter :: Sum Int} deriving (b -> EntityCounter -> EntityCounter
NonEmpty EntityCounter -> EntityCounter
EntityCounter -> EntityCounter -> EntityCounter
(EntityCounter -> EntityCounter -> EntityCounter)
-> (NonEmpty EntityCounter -> EntityCounter)
-> (forall b. Integral b => b -> EntityCounter -> EntityCounter)
-> Semigroup EntityCounter
forall b. Integral b => b -> EntityCounter -> EntityCounter
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> EntityCounter -> EntityCounter
$cstimes :: forall b. Integral b => b -> EntityCounter -> EntityCounter
sconcat :: NonEmpty EntityCounter -> EntityCounter
$csconcat :: NonEmpty EntityCounter -> EntityCounter
<> :: EntityCounter -> EntityCounter -> EntityCounter
$c<> :: EntityCounter -> EntityCounter -> EntityCounter
Semigroup, Semigroup EntityCounter
EntityCounter
Semigroup EntityCounter
-> EntityCounter
-> (EntityCounter -> EntityCounter -> EntityCounter)
-> ([EntityCounter] -> EntityCounter)
-> Monoid EntityCounter
[EntityCounter] -> EntityCounter
EntityCounter -> EntityCounter -> EntityCounter
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [EntityCounter] -> EntityCounter
$cmconcat :: [EntityCounter] -> EntityCounter
mappend :: EntityCounter -> EntityCounter -> EntityCounter
$cmappend :: EntityCounter -> EntityCounter -> EntityCounter
mempty :: EntityCounter
$cmempty :: EntityCounter
$cp1Monoid :: Semigroup EntityCounter
Monoid, EntityCounter -> EntityCounter -> Bool
(EntityCounter -> EntityCounter -> Bool)
-> (EntityCounter -> EntityCounter -> Bool) -> Eq EntityCounter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EntityCounter -> EntityCounter -> Bool
$c/= :: EntityCounter -> EntityCounter -> Bool
== :: EntityCounter -> EntityCounter -> Bool
$c== :: EntityCounter -> EntityCounter -> Bool
Eq, Int -> EntityCounter -> ShowS
[EntityCounter] -> ShowS
EntityCounter -> [Char]
(Int -> EntityCounter -> ShowS)
-> (EntityCounter -> [Char])
-> ([EntityCounter] -> ShowS)
-> Show EntityCounter
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EntityCounter] -> ShowS
$cshowList :: [EntityCounter] -> ShowS
show :: EntityCounter -> [Char]
$cshow :: EntityCounter -> [Char]
showsPrec :: Int -> EntityCounter -> ShowS
$cshowsPrec :: Int -> EntityCounter -> ShowS
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 :: SystemT w m Entity
nextEntity = do EntityCounter Sum Int
n <- Entity -> SystemT w m EntityCounter
forall w (m :: * -> *) c. Get w m c => Entity -> SystemT w m c
get Entity
global
                Entity -> EntityCounter -> SystemT w m ()
forall w (m :: * -> *) c.
Set w m c =>
Entity -> c -> SystemT w m ()
set Entity
global (Sum Int -> EntityCounter
EntityCounter (Sum Int -> EntityCounter) -> Sum Int -> EntityCounter
forall a b. (a -> b) -> a -> b
$ Sum Int
nSum Int -> Sum Int -> Sum Int
forall a. Num a => a -> a -> a
+Sum Int
1)
                Entity -> SystemT w m Entity
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Entity
Entity (Int -> Entity) -> (Sum Int -> Int) -> Sum Int -> Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Entity) -> Sum Int -> Entity
forall a b. (a -> b) -> a -> b
$ Sum Int
n)

{-# INLINE newEntity #-}
newEntity :: (Set w m c, Get w m EntityCounter, Set w m EntityCounter)
          => c -> SystemT w m Entity
newEntity :: c -> SystemT w m Entity
newEntity c
c = do Entity
ety <- SystemT w m Entity
forall w (m :: * -> *).
(Get w m EntityCounter, Set w m EntityCounter) =>
SystemT w m Entity
nextEntity
                 Entity -> c -> SystemT w m ()
forall w (m :: * -> *) c.
Set w m c =>
Entity -> c -> SystemT w m ()
set Entity
ety c
c
                 Entity -> SystemT w m Entity
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
ety

-- | Like @makeWorld@ from @Apecs@, but uses the STM @EntityCounter@
makeWorld :: String -> [Name] -> Q [Dec]
makeWorld :: [Char] -> [Name] -> Q [Dec]
makeWorld [Char]
worldName [Name]
cTypes = [Char] -> [Name] -> Q [Dec]
makeWorldNoEC [Char]
worldName ([Name]
cTypes [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''EntityCounter])

-- | Like @makeWorldAndComponents@ from @Apecs@, but uses the STM @EntityCounter@ and the STM @Map@
makeWorldAndComponents :: String -> [Name] -> Q [Dec]
makeWorldAndComponents :: [Char] -> [Name] -> Q [Dec]
makeWorldAndComponents [Char]
worldName [Name]
cTypes = do
  [Dec]
wdecls <- [Char] -> [Name] -> Q [Dec]
makeWorld [Char]
worldName [Name]
cTypes
  [Dec]
cdecls <- Name -> [Name] -> Q [Dec]
makeMapComponentsFor ''Map [Name]
cTypes
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
wdecls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
cdecls

-- | @atomically@ from STM, lifted to the System level.
atomically :: SystemT w STM a -> SystemT w IO a
atomically :: SystemT w STM a -> SystemT w IO a
atomically SystemT w STM a
sys = SystemT w IO w
forall r (m :: * -> *). MonadReader r m => m r
ask SystemT w IO w -> (w -> SystemT w IO a) -> SystemT w IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> SystemT w IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> SystemT w IO a) -> (w -> IO a) -> w -> SystemT w IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
S.atomically (STM a -> IO a) -> (w -> STM a) -> w -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemT w STM a -> w -> STM a
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem SystemT w STM a
sys

-- | @retry@ from STM, lifted to the System level.
retry :: SystemT w STM a
retry :: SystemT w STM a
retry = STM a -> SystemT w STM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift STM a
forall a. STM a
S.retry

-- | @check@ from STM, lifted to the System level.
check :: Bool -> SystemT w STM ()
check :: Bool -> SystemT w STM ()
check = STM () -> SystemT w STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> SystemT w STM ())
-> (Bool -> STM ()) -> Bool -> SystemT w STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> STM ()
S.check

-- | Runs a system on a new thread.
forkSys :: SystemT w IO () -> SystemT w IO S.ThreadId
forkSys :: SystemT w IO () -> SystemT w IO ThreadId
forkSys SystemT w IO ()
sys = SystemT w IO w
forall r (m :: * -> *). MonadReader r m => m r
ask SystemT w IO w
-> (w -> SystemT w IO ThreadId) -> SystemT w IO ThreadId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ThreadId -> SystemT w IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> SystemT w IO ThreadId)
-> (w -> IO ThreadId) -> w -> SystemT w IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
S.forkIO (IO () -> IO ThreadId) -> (w -> IO ()) -> w -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemT w IO () -> w -> IO ()
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem SystemT w IO ()
sys

-- | Suspends the current thread for a number of microseconds.
threadDelay :: Int -> SystemT w IO ()
threadDelay :: Int -> SystemT w IO ()
threadDelay = IO () -> SystemT w IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SystemT w IO ())
-> (Int -> IO ()) -> Int -> SystemT w IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
S.threadDelay