{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
module TheatreDev.StmBased
( Actor,
spawnStatefulIndividual,
spawnStatefulBatched,
spawnStatelessIndividual,
spawnStatelessBatched,
tell,
kill,
wait,
oneOf,
allOf,
byKeyHash,
)
where
import TheatreDev.Prelude
import TheatreDev.StmBased.StmStructures.Runner (Runner)
import qualified TheatreDev.StmBased.StmStructures.Runner as Runner
import TheatreDev.StmBased.Tell (Tell)
import qualified TheatreDev.StmBased.Tell as Tell
import qualified TheatreDev.StmBased.Wait as Wait
data Actor message = Actor
{
forall message. Actor message -> message -> STM ()
tell :: message -> STM (),
forall message. Actor message -> STM ()
kill :: STM (),
forall message. Actor message -> STM (Maybe SomeException)
wait :: STM (Maybe SomeException)
}
instance Contravariant Actor where
contramap :: forall a' a. (a' -> a) -> Actor a -> Actor a'
contramap a' -> a
fn (Actor a -> STM ()
tell STM ()
kill STM (Maybe SomeException)
wait) =
forall message.
(message -> STM ())
-> STM () -> STM (Maybe SomeException) -> Actor message
Actor (a -> STM ()
tell forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a' -> a
fn) STM ()
kill STM (Maybe SomeException)
wait
instance Divisible Actor where
conquer :: forall a. Actor a
conquer =
forall message.
(message -> STM ())
-> STM () -> STM (Maybe SomeException) -> Actor message
Actor (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())) (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
divide :: forall a b c. (a -> (b, c)) -> Actor b -> Actor c -> Actor a
divide a -> (b, c)
divisor (Actor b -> STM ()
lTell STM ()
lKill STM (Maybe SomeException)
lWait) (Actor c -> STM ()
rTell STM ()
rKill STM (Maybe SomeException)
rWait) =
forall message.
(message -> STM ())
-> STM () -> STM (Maybe SomeException) -> Actor message
Actor a -> STM ()
tell STM ()
kill STM (Maybe SomeException)
wait
where
tell :: a -> STM ()
tell a
msg = case a -> (b, c)
divisor a
msg of (b
lMsg, c
rMsg) -> b -> STM ()
lTell b
lMsg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> STM ()
rTell c
rMsg
kill :: STM ()
kill = STM ()
lKill forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM ()
rKill
wait :: STM (Maybe SomeException)
wait = STM (Maybe SomeException)
-> STM (Maybe SomeException) -> STM (Maybe SomeException)
Wait.both STM (Maybe SomeException)
lWait STM (Maybe SomeException)
rWait
instance Decidable Actor where
lose :: forall a. (a -> Void) -> Actor a
lose a -> Void
fn =
forall message.
(message -> STM ())
-> STM () -> STM (Maybe SomeException) -> Actor message
Actor (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Void -> a
absurd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Void
fn) (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
choose :: forall a b c. (a -> Either b c) -> Actor b -> Actor c -> Actor a
choose a -> Either b c
choice (Actor b -> STM ()
lTell STM ()
lKill STM (Maybe SomeException)
lWait) (Actor c -> STM ()
rTell STM ()
rKill STM (Maybe SomeException)
rWait) =
forall message.
(message -> STM ())
-> STM () -> STM (Maybe SomeException) -> Actor message
Actor a -> STM ()
tell STM ()
kill STM (Maybe SomeException)
wait
where
tell :: a -> STM ()
tell = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> STM ()
lTell c -> STM ()
rTell forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Either b c
choice
kill :: STM ()
kill = STM ()
lKill forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM ()
rKill
wait :: STM (Maybe SomeException)
wait = STM (Maybe SomeException)
-> STM (Maybe SomeException) -> STM (Maybe SomeException)
Wait.both STM (Maybe SomeException)
lWait STM (Maybe SomeException)
rWait
fromRunner :: Runner a -> Actor a
fromRunner :: forall a. Runner a -> Actor a
fromRunner Runner a
runner =
Actor
{ $sel:tell:Actor :: a -> STM ()
tell = forall a. Runner a -> a -> STM ()
Runner.tell Runner a
runner,
$sel:kill:Actor :: STM ()
kill = forall a. Runner a -> STM ()
Runner.kill Runner a
runner,
$sel:wait:Actor :: STM (Maybe SomeException)
wait = forall a. Runner a -> STM (Maybe SomeException)
Runner.wait Runner a
runner
}
oneOf :: [Actor message] -> Actor message
oneOf :: forall message. [Actor message] -> Actor message
oneOf = forall message.
([Tell message] -> Tell message)
-> [Actor message] -> Actor message
tellComposition forall a. [Tell a] -> Tell a
Tell.one
allOf :: [Actor message] -> Actor message
allOf :: forall message. [Actor message] -> Actor message
allOf = forall message.
([Tell message] -> Tell message)
-> [Actor message] -> Actor message
tellComposition forall a. [Tell a] -> Tell a
Tell.all
byKeyHash ::
(message -> Int) ->
[Actor message] ->
Actor message
byKeyHash :: forall message.
(message -> Int) -> [Actor message] -> Actor message
byKeyHash = forall message.
([Tell message] -> Tell message)
-> [Actor message] -> Actor message
tellComposition forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. (a -> Int) -> [Tell a] -> Tell a
Tell.byKeyHash
tellComposition :: ([Tell message] -> Tell message) -> [Actor message] -> Actor message
tellComposition :: forall message.
([Tell message] -> Tell message)
-> [Actor message] -> Actor message
tellComposition [Tell message] -> Tell message
tellReducer [Actor message]
actors =
Actor
{ $sel:tell:Actor :: Tell message
tell = [Tell message] -> Tell message
tellReducer (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.tell) [Actor message]
actors),
$sel:kill:Actor :: STM ()
kill = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (.kill) [Actor message]
actors,
$sel:wait:Actor :: STM (Maybe SomeException)
wait = [STM (Maybe SomeException)] -> STM (Maybe SomeException)
Wait.all (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.wait) [Actor message]
actors)
}
spawnStatelessIndividual ::
(message -> IO ()) ->
IO () ->
IO (Actor message)
spawnStatelessIndividual :: forall message. (message -> IO ()) -> IO () -> IO (Actor message)
spawnStatelessIndividual message -> IO ()
interpreter IO ()
cleaner =
forall state message.
state
-> (state -> message -> IO state)
-> (state -> IO ())
-> IO (Actor message)
spawnStatefulIndividual () (forall a b. a -> b -> a
const message -> IO ()
interpreter) (forall a b. a -> b -> a
const IO ()
cleaner)
spawnStatelessBatched ::
(NonEmpty message -> IO ()) ->
IO () ->
IO (Actor message)
spawnStatelessBatched :: forall message.
(NonEmpty message -> IO ()) -> IO () -> IO (Actor message)
spawnStatelessBatched NonEmpty message -> IO ()
interpreter IO ()
cleaner =
forall state message.
state
-> (state -> NonEmpty message -> IO state)
-> (state -> IO ())
-> IO (Actor message)
spawnStatefulBatched () (forall a b. a -> b -> a
const NonEmpty message -> IO ()
interpreter) (forall a b. a -> b -> a
const IO ()
cleaner)
spawnStatefulIndividual ::
state ->
(state -> message -> IO state) ->
(state -> IO ()) ->
IO (Actor message)
spawnStatefulIndividual :: forall state message.
state
-> (state -> message -> IO state)
-> (state -> IO ())
-> IO (Actor message)
spawnStatefulIndividual state
zero state -> message -> IO state
step state -> IO ()
finalizer =
do
Runner message
runner <- forall a. STM a -> IO a
atomically forall a. STM (Runner a)
Runner.start
((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
let loop :: state -> IO ()
loop !state
state =
do
Maybe message
message <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Runner a -> STM (Maybe a)
Runner.receiveSingle Runner message
runner
case Maybe message
message of
Just message
message ->
do
Either SomeException state
result <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ state -> message -> IO state
step state
state message
message
case Either SomeException state
result of
Right state
newState ->
state -> IO ()
loop state
newState
Left SomeException
exception ->
do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Runner a -> SomeException -> STM ()
Runner.releaseWithException Runner message
runner SomeException
exception
state -> IO ()
finalizer state
state
Maybe message
Nothing ->
state -> IO ()
finalizer state
state
in state -> IO ()
loop state
zero
return $ forall a. Runner a -> Actor a
fromRunner Runner message
runner
spawnStatefulBatched ::
state ->
(state -> NonEmpty message -> IO state) ->
(state -> IO ()) ->
IO (Actor message)
spawnStatefulBatched :: forall state message.
state
-> (state -> NonEmpty message -> IO state)
-> (state -> IO ())
-> IO (Actor message)
spawnStatefulBatched state
zero state -> NonEmpty message -> IO state
step state -> IO ()
finalizer =
do
Runner message
runner <- forall a. STM a -> IO a
atomically forall a. STM (Runner a)
Runner.start
((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
let loop :: state -> IO ()
loop !state
state =
do
Maybe (NonEmpty message)
messages <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Runner a -> STM (Maybe (NonEmpty a))
Runner.receiveMultiple Runner message
runner
case Maybe (NonEmpty message)
messages of
Just NonEmpty message
nonEmptyMessages ->
do
Either SomeException state
result <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ state -> NonEmpty message -> IO state
step state
state NonEmpty message
nonEmptyMessages
case Either SomeException state
result of
Right state
newState ->
state -> IO ()
loop state
newState
Left SomeException
exception ->
do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Runner a -> SomeException -> STM ()
Runner.releaseWithException Runner message
runner SomeException
exception
state -> IO ()
finalizer state
state
Maybe (NonEmpty message)
Nothing -> state -> IO ()
finalizer state
state
in state -> IO ()
loop state
zero
return $ forall a. Runner a -> Actor a
fromRunner Runner message
runner
tell :: Actor message -> message -> IO ()
tell :: forall message. Actor message -> message -> IO ()
tell Actor message
actor =
forall a. STM a -> IO a
atomically forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Actor message
actor.tell
kill :: Actor message -> IO ()
kill :: forall message. Actor message -> IO ()
kill Actor message
actor =
forall a. STM a -> IO a
atomically Actor message
actor.kill
wait :: Actor message -> IO ()
wait :: forall message. Actor message -> IO ()
wait Actor message
actor =
forall a. STM a -> IO a
atomically Actor message
actor.wait forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall e a. Exception e => e -> IO a
throwIO