{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.STM
(
Map (..)
, Unique (..)
, Global (..)
, makeWorldAndComponents
, 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.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, lift, liftIO, runSystem)
import Apecs.Core
import Apecs.TH (makeWorld, 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 = forall c. Map Int c -> Map c
Map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value.
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
M.lookup Int
ety Map Int c
m) forall a b. (a -> b) -> a -> b
$ \case
Just c
c -> c
c
Maybe c
notFound -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
[ [Char]
"Reading non-existent STM Map component"
, forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe c
notFound)
, [Char]
"for entity"
, 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 = forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
M.insert 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 = forall key value. 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) = forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
(b -> m (Maybe (a, b))) -> b -> m (Vector a)
U.unfoldrM forall (m :: * -> *) a. ListT m a -> m (Maybe (a, ListT m a))
L.uncons forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. STM a -> IO a
S.atomically 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall c. TVar (Maybe (Int, c)) -> Unique c
Unique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar 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
_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref) forall a b. (a -> b) -> a -> b
$ \case
Just (Int
_, c
c) -> c
c
Maybe (Int, c)
notFound -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
[ [Char]
"Reading non-existent STM Unique component"
, forall a. Show a => a -> [Char]
show (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Eq a => a -> a -> Bool
==Int
ety) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Int, c))
ref (forall a. a -> Maybe a
Just (Int
ety, 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 = forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Int, c))
ref forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
==Int
ety) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TVar a -> STM a
readTVar TVar (Maybe (Int, c))
ref) forall a b. (a -> b) -> a -> b
$ \case
Maybe (Int, c)
Nothing -> forall a. Monoid a => a
mempty
Just (Int
ety, c
_) -> forall a. Unbox a => a -> Vector a
U.singleton Int
ety
instance ExplInit IO (Unique c) where
{-# INLINE explInit #-}
explInit :: IO (Unique c)
explInit = forall a. STM a -> IO a
S.atomically 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall c. TVar c -> Global c
Global forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar 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
_ = forall a. TVar a -> STM a
readTVar TVar c
ref
{-# INLINE explExists #-}
explExists :: Global c -> Int -> STM Bool
explExists Global c
_ Int
_ = 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 = forall a. TVar a -> a -> STM ()
writeTVar TVar c
ref Elem (Global c)
c
instance Monoid c => ExplInit IO (Global c) where
{-# INLINE explInit #-}
explInit :: IO (Global c)
explInit = forall a. STM a -> IO a
S.atomically 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. STM a -> IO a
S.atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Global c
m Int
e Elem (Global c)
x
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dec]
wdecls forall a. [a] -> [a] -> [a]
++ [Dec]
cdecls
atomically :: SystemT w STM a -> SystemT w IO a
atomically :: forall w a. SystemT w STM a -> SystemT w IO a
atomically SystemT w STM a
sys = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
S.atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem SystemT w STM a
sys
retry :: SystemT w STM a
retry :: forall w a. SystemT w STM a
retry = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. STM a
S.retry
check :: Bool -> SystemT w STM ()
check :: forall w. Bool -> SystemT w STM ()
check = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> STM ()
S.check
forkSys :: SystemT w IO () -> SystemT w IO S.ThreadId
forkSys :: forall w. SystemT w IO () -> SystemT w IO ThreadId
forkSys SystemT w IO ()
sys = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
S.forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem SystemT w IO ()
sys
threadDelay :: Int -> SystemT w IO ()
threadDelay :: forall w. Int -> SystemT w IO ()
threadDelay = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
S.threadDelay