-- |
-- Minimalistic actor library.
module Theatre
  ( Actor,

    -- * Construction
    graceful,
    disgraceful,
    suicidal,

    -- * Usage
    tell,
    kill,
  )
where

import qualified Control.Concurrent.Chan.Unagi as E
import qualified SlaveThread as F
import Theatre.Prelude

-- |
-- Actor, which processes the messages of type @message@.
--
-- An abstraction over the message channel, thread-forking and killing.
data Actor message = Actor
  { -- | Send a message to the actor
    Actor message -> message -> IO ()
tell :: message -> IO (),
    -- | Kill the actor
    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

-- |
-- An actor which cannot die by itself unless explicitly killed.
--
-- Given an interpreter of messages,
-- forks a thread to run the computation on and
-- produces a handle to address that actor.
--
-- Killing that actor will make it process all the messages in the queue first.
-- All the messages sent to it after killing won't be processed.
graceful ::
  -- | Interpreter of a message
  (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))

-- |
-- An actor which cannot die by itself unless explicitly killed.
--
-- Given an interpreter of messages,
-- forks a thread to run the computation on and
-- produces a handle to address that actor.
disgraceful ::
  -- | Interpreter of a message
  (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))

-- |
-- An actor, whose interpreter can decide that the actor should die.
--
-- Given an implementation of a receiver loop of messages,
-- forks a thread to run that receiver on and
-- produces a handle to address that actor.
suicidal ::
  -- | A message receiver loop. When the loop exits, the actor dies
  (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))