{-# 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 (..)
    -- * STM conveniences
  , 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

-- | Like @makeWorldAndComponents@ from @Apecs@, but uses 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
  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@ from STM, lifted to the System level.
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@ from STM, lifted to the System level.
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@ from STM, lifted to the System level.
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

-- | Runs a system on a new thread.
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

-- | Suspends the current thread for a number of microseconds.
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