-- |
-- Exploration of perpetual actors.
-- I.e., those that exist for the whole duration of the app.
--
-- This limitation provides for simpler API and most apps
-- are expected not to need more.
module TheatreDev.Perpetual
  ( Actor,
    spawnStateless,
    spawnStateful,
    tell,
  )
where

import Control.Concurrent.Chan.Unagi qualified as Unagi
import TheatreDev.Prelude

-- |
-- Actor, which processes the messages of type @msg@.
--
-- Provides abstraction over the communication channel and threads.
newtype Actor msg
  = Actor (msg -> IO ())

-- |
-- Distributes the message across the merged actors.
instance Semigroup (Actor msg) where
  Actor msg -> IO ()
lTell <> :: Actor msg -> Actor msg -> Actor msg
<> Actor msg -> IO ()
rTell =
    forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> msg -> IO ()
lTell msg
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> msg -> IO ()
rTell msg
msg
  sconcat :: NonEmpty (Actor msg) -> Actor msg
sconcat NonEmpty (Actor msg)
actors = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (Actor msg)
actors forall a b. (a -> b) -> a -> b
$ \(Actor msg -> IO ()
tell) -> msg -> IO ()
tell msg
msg
  stimes :: forall b. Integral b => b -> Actor msg -> Actor msg
stimes b
n (Actor msg -> IO ()
tell) = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n) forall a b. (a -> b) -> a -> b
$ msg -> IO ()
tell msg
msg

-- |
-- Provides an identity for merging the actors,
-- which does nothing.
instance Monoid (Actor msg) where
  mempty :: Actor msg
mempty = forall msg. (msg -> IO ()) -> Actor msg
Actor (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))
  mconcat :: [Actor msg] -> Actor msg
mconcat [Actor msg]
actors = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Actor msg]
actors forall a b. (a -> b) -> a -> b
$ \(Actor msg -> IO ()
tell) -> msg -> IO ()
tell msg
msg

-- |
-- Maps the input message to a different type.
instance Contravariant Actor where
  contramap :: forall a' a. (a' -> a) -> Actor a -> Actor a'
contramap a' -> a
fn (Actor a -> IO ()
tell) =
    forall msg. (msg -> IO ()) -> Actor msg
Actor (a -> IO ()
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)

-- |
-- Splits the message between actors.
instance Divisible Actor where
  conquer :: forall msg. Actor msg
conquer =
    forall a. Monoid a => a
mempty
  divide :: forall a b c. (a -> (b, c)) -> Actor b -> Actor c -> Actor a
divide a -> (b, c)
divisor (Actor b -> IO ()
lTell) (Actor c -> IO ()
rTell) =
    forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \a
msg -> case a -> (b, c)
divisor a
msg of
      (b
lMsg, c
rMsg) -> b -> IO ()
lTell b
lMsg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> IO ()
rTell c
rMsg

-- |
-- Provides a choice between alternative actors to process the message.
instance Decidable Actor where
  lose :: forall a. (a -> Void) -> Actor a
lose a -> Void
_ =
    forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
  choose :: forall a b c. (a -> Either b c) -> Actor b -> Actor c -> Actor a
choose a -> Either b c
decider (Actor b -> IO ()
lTell) (Actor c -> IO ()
rTell) =
    forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> IO ()
lTell c -> IO ()
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
decider

spawnStateless ::
  -- |
  -- Process the next message.
  -- Must not throw any exceptions.
  (msg -> IO ()) ->
  -- |
  -- Action forking a thread to run the actor loop and
  -- producing a handle for sending messages to it.
  IO (Actor msg)
spawnStateless :: forall msg. (msg -> IO ()) -> IO (Actor msg)
spawnStateless msg -> IO ()
process = do
  (InChan msg
inChan, OutChan msg
outChan) <- forall a. IO (InChan a, OutChan a)
Unagi.newChan
  IO () -> IO ThreadId
forkIO
    forall a b. (a -> b) -> a -> b
$ let loop :: IO ()
loop = do
            msg
msg <- forall a. OutChan a -> IO a
Unagi.readChan OutChan msg
outChan
            msg -> IO ()
process msg
msg
            IO ()
loop
       in IO ()
loop
  return $ forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan msg
inChan

spawnStateful ::
  -- |
  -- Initial state.
  state ->
  -- |
  -- Process the next message updating the state.
  -- The IO action must not throw any exceptions.
  (state -> msg -> IO state) ->
  -- |
  -- Action forking a thread to run the actor loop and
  -- producing a handle for sending messages to it.
  IO (Actor msg)
spawnStateful :: forall state msg.
state -> (state -> msg -> IO state) -> IO (Actor msg)
spawnStateful state
state state -> msg -> IO state
process = do
  (InChan msg
inChan, OutChan msg
outChan) <- forall a. IO (InChan a, OutChan a)
Unagi.newChan
  IO () -> IO ThreadId
forkIO
    forall a b. (a -> b) -> a -> b
$ let loop :: state -> IO ()
loop !state
state = do
            msg
msg <- forall a. OutChan a -> IO a
Unagi.readChan OutChan msg
outChan
            state
state <- state -> msg -> IO state
process state
state msg
msg
            state -> IO ()
loop state
state
       in state -> IO ()
loop state
state
  return $ forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan msg
inChan

-- |
-- Schedule a message for the actor to process
-- after the ones already scheduled.
tell :: Actor msg -> msg -> IO ()
tell :: forall msg. Actor msg -> msg -> IO ()
tell = coerce :: forall a b. Coercible a b => a -> b
coerce