module Theatre
( Actor,
graceful,
disgraceful,
suicidal,
tell,
kill,
)
where
import qualified Control.Concurrent.Chan.Unagi as E
import qualified SlaveThread as F
import Theatre.Prelude
data Actor message = Actor
{
Actor message -> message -> IO ()
tell :: message -> IO (),
Actor message -> IO ()
kill :: IO ()
}
instance Semigroup (Actor message) where
<> :: Actor message -> Actor message -> Actor message
(<>) (Actor message -> IO ()
leftTell IO ()
leftKill) (Actor message -> IO ()
rightTell IO ()
rightKill) =
(message -> IO ()) -> IO () -> Actor message
forall message. (message -> IO ()) -> IO () -> Actor message
Actor message -> IO ()
tell IO ()
kill
where
tell :: message -> IO ()
tell message
message =
message -> IO ()
leftTell message
message IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> message -> IO ()
rightTell message
message
kill :: IO ()
kill =
IO ()
leftKill IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rightKill
instance Monoid (Actor message) where
mempty :: Actor message
mempty =
(message -> IO ()) -> IO () -> Actor message
forall message. (message -> IO ()) -> IO () -> Actor message
Actor (IO () -> message -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mappend :: Actor message -> Actor message -> Actor message
mappend =
Actor message -> Actor message -> Actor message
forall a. Semigroup a => a -> a -> a
(<>)
instance Contravariant Actor where
contramap :: (a -> b) -> Actor b -> Actor a
contramap a -> b
fn (Actor b -> IO ()
tell IO ()
kill) =
(a -> IO ()) -> IO () -> Actor a
forall message. (message -> IO ()) -> IO () -> Actor message
Actor (b -> IO ()
tell (b -> IO ()) -> (a -> b) -> a -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
fn) IO ()
kill
instance Divisible Actor where
conquer :: Actor a
conquer =
Actor a
forall a. Monoid a => a
mempty
divide :: (a -> (b, c)) -> Actor b -> Actor c -> Actor a
divide a -> (b, c)
divisor (Actor b -> IO ()
leftTell IO ()
leftKill) (Actor c -> IO ()
rightTell IO ()
rightKill) =
(a -> IO ()) -> IO () -> Actor a
forall message. (message -> IO ()) -> IO () -> Actor message
Actor a -> IO ()
tell IO ()
kill
where
tell :: a -> IO ()
tell a
message =
case a -> (b, c)
divisor a
message of
(b
leftMessage, c
rightMessage) -> b -> IO ()
leftTell b
leftMessage IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> IO ()
rightTell c
rightMessage
kill :: IO ()
kill =
IO ()
leftKill IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rightKill
instance Decidable Actor where
lose :: (a -> Void) -> Actor a
lose a -> Void
fn =
(a -> IO ()) -> IO () -> Actor a
forall message. (message -> IO ()) -> IO () -> Actor message
Actor (IO () -> Any -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Any -> IO ()) -> (a -> Any) -> a -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Void -> Any
forall a. Void -> a
absurd (Void -> Any) -> (a -> Void) -> a -> Any
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) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
choose :: (a -> Either b c) -> Actor b -> Actor c -> Actor a
choose a -> Either b c
choice (Actor b -> IO ()
leftTell IO ()
leftKill) (Actor c -> IO ()
rightTell IO ()
rightKill) =
(a -> IO ()) -> IO () -> Actor a
forall message. (message -> IO ()) -> IO () -> Actor message
Actor a -> IO ()
tell IO ()
kill
where
tell :: a -> IO ()
tell =
(b -> IO ()) -> (c -> IO ()) -> Either b c -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> IO ()
leftTell c -> IO ()
rightTell (Either b c -> IO ()) -> (a -> Either b c) -> a -> IO ()
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 :: IO ()
kill =
IO ()
leftKill IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rightKill
graceful ::
(message -> IO ()) ->
IO (Actor message)
graceful :: (message -> IO ()) -> IO (Actor message)
graceful message -> IO ()
interpretMessage =
do
(InChan (Maybe message)
inChan, OutChan (Maybe message)
outChan) <- IO (InChan (Maybe message), OutChan (Maybe message))
forall a. IO (InChan a, OutChan a)
E.newChan
IO () -> IO ThreadId
forall a. IO a -> IO ThreadId
F.fork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
(IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop ->
{-# SCC "graceful/loop" #-}
do
Maybe message
message <- OutChan (Maybe message) -> IO (Maybe message)
forall a. OutChan a -> IO a
E.readChan OutChan (Maybe message)
outChan
case Maybe message
message of
Just message
payload ->
do
message -> IO ()
interpretMessage message
payload
IO ()
loop
Maybe message
Nothing ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Actor message -> IO (Actor message)
forall (m :: * -> *) a. Monad m => a -> m a
return ((message -> IO ()) -> IO () -> Actor message
forall message. (message -> IO ()) -> IO () -> Actor message
Actor (InChan (Maybe message) -> Maybe message -> IO ()
forall a. InChan a -> a -> IO ()
E.writeChan InChan (Maybe message)
inChan (Maybe message -> IO ())
-> (message -> Maybe message) -> message -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. message -> Maybe message
forall a. a -> Maybe a
Just) (InChan (Maybe message) -> Maybe message -> IO ()
forall a. InChan a -> a -> IO ()
E.writeChan InChan (Maybe message)
inChan Maybe message
forall a. Maybe a
Nothing))
disgraceful ::
(message -> IO ()) ->
IO (Actor message)
disgraceful :: (message -> IO ()) -> IO (Actor message)
disgraceful message -> IO ()
receiver =
(IO message -> IO ()) -> IO (Actor message)
forall message. (IO message -> IO ()) -> IO (Actor message)
suicidal (\IO message
producer -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO message
producer IO message -> (message -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= message -> IO ()
receiver))
suicidal ::
(IO message -> IO ()) ->
IO (Actor message)
suicidal :: (IO message -> IO ()) -> IO (Actor message)
suicidal IO message -> IO ()
receiver =
do
(InChan message
inChan, OutChan message
outChan) <- IO (InChan message, OutChan message)
forall a. IO (InChan a, OutChan a)
E.newChan
ThreadId
threadId <- IO () -> IO ThreadId
forall a. IO a -> IO ThreadId
F.fork (IO message -> IO ()
receiver (OutChan message -> IO message
forall a. OutChan a -> IO a
E.readChan OutChan message
outChan))
Actor message -> IO (Actor message)
forall (m :: * -> *) a. Monad m => a -> m a
return ((message -> IO ()) -> IO () -> Actor message
forall message. (message -> IO ()) -> IO () -> Actor message
Actor (InChan message -> message -> IO ()
forall a. InChan a -> a -> IO ()
E.writeChan InChan message
inChan) (ThreadId -> IO ()
killThread ThreadId
threadId))