{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- Module:     Drama.Internal
-- Stability:  experimental
-- License:    BSD-3-Clause
-- Copyright:  © 2022 Evan Relf
-- Maintainer: evan@evanrelf.com

module Drama.Internal where

import Control.Applicative (Alternative)
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (MonadPlus, void)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans.Reader (ReaderT (..), asks)
import Data.Kind (Type)

import qualified Control.Concurrent.Chan.Unagi as Unagi
import qualified Control.Concurrent.STM as STM
import qualified Ki.Unlifted as Ki

-- Support `MonadFail` on GHC 8.6.5
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail (MonadFail)
#endif
#if MIN_VERSION_base(4,13,0)
import Prelude hiding (MonadFail)
#endif


-- | Monad supporting actor operations.
--
-- @since 0.4.0.0
newtype Actor (msg :: Type -> Type) a = Actor (ReaderT (ActorEnv msg) IO a)
  deriving newtype
    ( a -> Actor msg b -> Actor msg a
(a -> b) -> Actor msg a -> Actor msg b
(forall a b. (a -> b) -> Actor msg a -> Actor msg b)
-> (forall a b. a -> Actor msg b -> Actor msg a)
-> Functor (Actor msg)
forall a b. a -> Actor msg b -> Actor msg a
forall a b. (a -> b) -> Actor msg a -> Actor msg b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (msg :: * -> *) a b. a -> Actor msg b -> Actor msg a
forall (msg :: * -> *) a b. (a -> b) -> Actor msg a -> Actor msg b
<$ :: a -> Actor msg b -> Actor msg a
$c<$ :: forall (msg :: * -> *) a b. a -> Actor msg b -> Actor msg a
fmap :: (a -> b) -> Actor msg a -> Actor msg b
$cfmap :: forall (msg :: * -> *) a b. (a -> b) -> Actor msg a -> Actor msg b
Functor
    , Functor (Actor msg)
a -> Actor msg a
Functor (Actor msg)
-> (forall a. a -> Actor msg a)
-> (forall a b. Actor msg (a -> b) -> Actor msg a -> Actor msg b)
-> (forall a b c.
    (a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c)
-> (forall a b. Actor msg a -> Actor msg b -> Actor msg b)
-> (forall a b. Actor msg a -> Actor msg b -> Actor msg a)
-> Applicative (Actor msg)
Actor msg a -> Actor msg b -> Actor msg b
Actor msg a -> Actor msg b -> Actor msg a
Actor msg (a -> b) -> Actor msg a -> Actor msg b
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
forall a. a -> Actor msg a
forall a b. Actor msg a -> Actor msg b -> Actor msg a
forall a b. Actor msg a -> Actor msg b -> Actor msg b
forall a b. Actor msg (a -> b) -> Actor msg a -> Actor msg b
forall a b c.
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
forall (msg :: * -> *). Functor (Actor msg)
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (msg :: * -> *) a. a -> Actor msg a
forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg a
forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg b
forall (msg :: * -> *) a b.
Actor msg (a -> b) -> Actor msg a -> Actor msg b
forall (msg :: * -> *) a b c.
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
<* :: Actor msg a -> Actor msg b -> Actor msg a
$c<* :: forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg a
*> :: Actor msg a -> Actor msg b -> Actor msg b
$c*> :: forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg b
liftA2 :: (a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
$cliftA2 :: forall (msg :: * -> *) a b c.
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
<*> :: Actor msg (a -> b) -> Actor msg a -> Actor msg b
$c<*> :: forall (msg :: * -> *) a b.
Actor msg (a -> b) -> Actor msg a -> Actor msg b
pure :: a -> Actor msg a
$cpure :: forall (msg :: * -> *) a. a -> Actor msg a
$cp1Applicative :: forall (msg :: * -> *). Functor (Actor msg)
Applicative
    , Applicative (Actor msg)
a -> Actor msg a
Applicative (Actor msg)
-> (forall a b. Actor msg a -> (a -> Actor msg b) -> Actor msg b)
-> (forall a b. Actor msg a -> Actor msg b -> Actor msg b)
-> (forall a. a -> Actor msg a)
-> Monad (Actor msg)
Actor msg a -> (a -> Actor msg b) -> Actor msg b
Actor msg a -> Actor msg b -> Actor msg b
forall a. a -> Actor msg a
forall a b. Actor msg a -> Actor msg b -> Actor msg b
forall a b. Actor msg a -> (a -> Actor msg b) -> Actor msg b
forall (msg :: * -> *). Applicative (Actor msg)
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (msg :: * -> *) a. a -> Actor msg a
forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg b
forall (msg :: * -> *) a b.
Actor msg a -> (a -> Actor msg b) -> Actor msg b
return :: a -> Actor msg a
$creturn :: forall (msg :: * -> *) a. a -> Actor msg a
>> :: Actor msg a -> Actor msg b -> Actor msg b
$c>> :: forall (msg :: * -> *) a b.
Actor msg a -> Actor msg b -> Actor msg b
>>= :: Actor msg a -> (a -> Actor msg b) -> Actor msg b
$c>>= :: forall (msg :: * -> *) a b.
Actor msg a -> (a -> Actor msg b) -> Actor msg b
$cp1Monad :: forall (msg :: * -> *). Applicative (Actor msg)
Monad
    , Monad (Actor msg)
Monad (Actor msg)
-> (forall a. IO a -> Actor msg a) -> MonadIO (Actor msg)
IO a -> Actor msg a
forall a. IO a -> Actor msg a
forall (msg :: * -> *). Monad (Actor msg)
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (msg :: * -> *) a. IO a -> Actor msg a
liftIO :: IO a -> Actor msg a
$cliftIO :: forall (msg :: * -> *) a. IO a -> Actor msg a
$cp1MonadIO :: forall (msg :: * -> *). Monad (Actor msg)
MonadIO
    , MonadUnliftIO -- ^ @since 0.5.0.0
    , Applicative (Actor msg)
Actor msg a
Applicative (Actor msg)
-> (forall a. Actor msg a)
-> (forall a. Actor msg a -> Actor msg a -> Actor msg a)
-> (forall a. Actor msg a -> Actor msg [a])
-> (forall a. Actor msg a -> Actor msg [a])
-> Alternative (Actor msg)
Actor msg a -> Actor msg a -> Actor msg a
Actor msg a -> Actor msg [a]
Actor msg a -> Actor msg [a]
forall a. Actor msg a
forall a. Actor msg a -> Actor msg [a]
forall a. Actor msg a -> Actor msg a -> Actor msg a
forall (msg :: * -> *). Applicative (Actor msg)
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (msg :: * -> *) a. Actor msg a
forall (msg :: * -> *) a. Actor msg a -> Actor msg [a]
forall (msg :: * -> *) a. Actor msg a -> Actor msg a -> Actor msg a
many :: Actor msg a -> Actor msg [a]
$cmany :: forall (msg :: * -> *) a. Actor msg a -> Actor msg [a]
some :: Actor msg a -> Actor msg [a]
$csome :: forall (msg :: * -> *) a. Actor msg a -> Actor msg [a]
<|> :: Actor msg a -> Actor msg a -> Actor msg a
$c<|> :: forall (msg :: * -> *) a. Actor msg a -> Actor msg a -> Actor msg a
empty :: Actor msg a
$cempty :: forall (msg :: * -> *) a. Actor msg a
$cp1Alternative :: forall (msg :: * -> *). Applicative (Actor msg)
Alternative
    , Monad (Actor msg)
Alternative (Actor msg)
Actor msg a
Alternative (Actor msg)
-> Monad (Actor msg)
-> (forall a. Actor msg a)
-> (forall a. Actor msg a -> Actor msg a -> Actor msg a)
-> MonadPlus (Actor msg)
Actor msg a -> Actor msg a -> Actor msg a
forall a. Actor msg a
forall a. Actor msg a -> Actor msg a -> Actor msg a
forall (msg :: * -> *). Monad (Actor msg)
forall (msg :: * -> *). Alternative (Actor msg)
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
forall (msg :: * -> *) a. Actor msg a
forall (msg :: * -> *) a. Actor msg a -> Actor msg a -> Actor msg a
mplus :: Actor msg a -> Actor msg a -> Actor msg a
$cmplus :: forall (msg :: * -> *) a. Actor msg a -> Actor msg a -> Actor msg a
mzero :: Actor msg a
$cmzero :: forall (msg :: * -> *) a. Actor msg a
$cp2MonadPlus :: forall (msg :: * -> *). Monad (Actor msg)
$cp1MonadPlus :: forall (msg :: * -> *). Alternative (Actor msg)
MonadPlus
#if MIN_VERSION_base(4,9,0)
    , Monad (Actor msg)
Monad (Actor msg)
-> (forall a. String -> Actor msg a) -> MonadFail (Actor msg)
String -> Actor msg a
forall a. String -> Actor msg a
forall (msg :: * -> *). Monad (Actor msg)
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (msg :: * -> *) a. String -> Actor msg a
fail :: String -> Actor msg a
$cfail :: forall (msg :: * -> *) a. String -> Actor msg a
$cp1MonadFail :: forall (msg :: * -> *). Monad (Actor msg)
MonadFail
#endif
    , Monad (Actor msg)
Monad (Actor msg)
-> (forall a. (a -> Actor msg a) -> Actor msg a)
-> MonadFix (Actor msg)
(a -> Actor msg a) -> Actor msg a
forall a. (a -> Actor msg a) -> Actor msg a
forall (msg :: * -> *). Monad (Actor msg)
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (msg :: * -> *) a. (a -> Actor msg a) -> Actor msg a
mfix :: (a -> Actor msg a) -> Actor msg a
$cmfix :: forall (msg :: * -> *) a. (a -> Actor msg a) -> Actor msg a
$cp1MonadFix :: forall (msg :: * -> *). Monad (Actor msg)
MonadFix
    )


-- | Ambient context provided by the `Actor` monad.
--
-- Values in `ActorEnv` are scoped to the current actor and cannot be safely
-- shared. Functions like `spawn`, `receive`, and `getSelf` use these values as
-- implicit parameters to avoid leaking internals (and for convenience).
--
-- @since 0.4.0.0
data ActorEnv msg = ActorEnv
  { ActorEnv msg -> Address msg
address :: Address msg
    -- ^ Current actor's address.
  , ActorEnv msg -> Mailbox msg
mailbox :: Mailbox msg
    -- ^ Current actor's mailbox.
  , ActorEnv msg -> Scope
scope :: Ki.Scope
    -- ^ Current actor's token used for spawning threads. Delimits the lifetime
    -- of child actors (threads).
  }


-- | Address for sending messages to an actor. Obtained by running `spawn`,
-- `getSelf`, or `receive` (if another actor sends you an address).
--
-- @since 0.4.0.0
newtype Address msg = Address (Unagi.InChan (Envelope msg))


-- | Mailbox where an actor receives messages. Cannot be shared with other
-- actors; used implicitly by `receive` and `tryReceive`.
--
-- @since 0.4.0.0
newtype Mailbox msg = Mailbox (Unagi.OutChan (Envelope msg))


-- | Wrapper around higher-kinded message types.
--
-- Higher-kinded message types are defined as GADTs with a type parameter. This
-- allows specifying the response type for messages.
--
-- @since 0.4.0.0
data Envelope (msg :: Type -> Type) where
  Cast :: msg () -> Envelope msg
  Call :: MVar res -> msg res -> Envelope msg


-- | Message type used by actors which do not receive messages.
--
-- @since 0.4.0.0
data NoMsg res


-- | @since 0.4.0.0
type Actor_ = Actor NoMsg


-- | Spawn a child actor and return its address.
--
-- @since 0.4.0.0
spawn
  :: Actor msg ()
  -- ^ Actor to spawn
  -> Actor _msg (Address msg)
  -- ^ Spawned actor's address
spawn :: Actor msg () -> Actor _msg (Address msg)
spawn Actor msg ()
actor = do
  (InChan (Envelope msg)
inChan, OutChan (Envelope msg)
outChan) <- IO (InChan (Envelope msg), OutChan (Envelope msg))
-> Actor _msg (InChan (Envelope msg), OutChan (Envelope msg))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan (Envelope msg), OutChan (Envelope msg))
forall a. IO (InChan a, OutChan a)
Unagi.newChan
  let address :: Address msg
address = InChan (Envelope msg) -> Address msg
forall (msg :: * -> *). InChan (Envelope msg) -> Address msg
Address InChan (Envelope msg)
inChan
  let mailbox :: Mailbox msg
mailbox = OutChan (Envelope msg) -> Mailbox msg
forall (msg :: * -> *). OutChan (Envelope msg) -> Mailbox msg
Mailbox OutChan (Envelope msg)
outChan
  Address msg -> Mailbox msg -> Actor msg () -> Actor _msg ()
forall (msg :: * -> *) (_msg :: * -> *).
Address msg -> Mailbox msg -> Actor msg () -> Actor _msg ()
spawnImpl Address msg
address Mailbox msg
mailbox Actor msg ()
actor
  Address msg -> Actor _msg (Address msg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Address msg
address


-- | More efficient version of `spawn`, for actors which receive no messages
-- (@msg ~ `NoMsg`@). See docs for `spawn` for more information.
--
-- @since 0.4.0.0
spawn_ :: Actor_ () -> Actor msg ()
spawn_ :: Actor_ () -> Actor msg ()
spawn_ Actor_ ()
actor = do
  let address :: Address msg
address = InChan (Envelope msg) -> Address msg
forall (msg :: * -> *). InChan (Envelope msg) -> Address msg
Address (String -> InChan (Envelope msg)
forall a. HasCallStack => String -> a
error String
noMsgError)
  let mailbox :: Mailbox msg
mailbox = OutChan (Envelope msg) -> Mailbox msg
forall (msg :: * -> *). OutChan (Envelope msg) -> Mailbox msg
Mailbox (String -> OutChan (Envelope msg)
forall a. HasCallStack => String -> a
error String
noMsgError)
  Address NoMsg -> Mailbox NoMsg -> Actor_ () -> Actor msg ()
forall (msg :: * -> *) (_msg :: * -> *).
Address msg -> Mailbox msg -> Actor msg () -> Actor _msg ()
spawnImpl Address NoMsg
forall (msg :: * -> *). Address msg
address Mailbox NoMsg
forall (msg :: * -> *). Mailbox msg
mailbox Actor_ ()
actor


spawnImpl
  :: Address msg
  -> Mailbox msg
  -> Actor msg ()
  -> Actor _msg ()
spawnImpl :: Address msg -> Mailbox msg -> Actor msg () -> Actor _msg ()
spawnImpl Address msg
address Mailbox msg
mailbox Actor msg ()
actor = do
  Scope
scope <- ReaderT (ActorEnv _msg) IO Scope -> Actor _msg Scope
forall (msg :: * -> *) a.
ReaderT (ActorEnv msg) IO a -> Actor msg a
Actor (ReaderT (ActorEnv _msg) IO Scope -> Actor _msg Scope)
-> ReaderT (ActorEnv _msg) IO Scope -> Actor _msg Scope
forall a b. (a -> b) -> a -> b
$ (ActorEnv _msg -> Scope) -> ReaderT (ActorEnv _msg) IO Scope
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ActorEnv _msg -> Scope
forall (msg :: * -> *). ActorEnv msg -> Scope
scope
  Actor _msg (Thread ()) -> Actor _msg ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Actor _msg (Thread ()) -> Actor _msg ())
-> Actor _msg (Thread ()) -> Actor _msg ()
forall a b. (a -> b) -> a -> b
$ IO (Thread ()) -> Actor _msg (Thread ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Thread ()) -> Actor _msg (Thread ()))
-> IO (Thread ()) -> Actor _msg (Thread ())
forall a b. (a -> b) -> a -> b
$ Scope -> IO () -> IO (Thread ())
forall a (m :: * -> *).
MonadUnliftIO m =>
Scope -> m a -> m (Thread a)
Ki.fork Scope
scope (IO () -> IO (Thread ())) -> IO () -> IO (Thread ())
forall a b. (a -> b) -> a -> b
$ Address msg -> Mailbox msg -> Actor msg () -> IO ()
forall (m :: * -> *) (msg :: * -> *) a.
MonadIO m =>
Address msg -> Mailbox msg -> Actor msg a -> m a
runActorImpl Address msg
address Mailbox msg
mailbox Actor msg ()
actor


-- | Block until all child actors have terminated.
--
-- @since 0.4.0.0
wait :: Actor msg ()
wait :: Actor msg ()
wait = do
  Scope
scope <- ReaderT (ActorEnv msg) IO Scope -> Actor msg Scope
forall (msg :: * -> *) a.
ReaderT (ActorEnv msg) IO a -> Actor msg a
Actor (ReaderT (ActorEnv msg) IO Scope -> Actor msg Scope)
-> ReaderT (ActorEnv msg) IO Scope -> Actor msg Scope
forall a b. (a -> b) -> a -> b
$ (ActorEnv msg -> Scope) -> ReaderT (ActorEnv msg) IO Scope
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ActorEnv msg -> Scope
forall (msg :: * -> *). ActorEnv msg -> Scope
scope
  IO () -> Actor msg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Actor msg ()) -> IO () -> Actor msg ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> STM ()
Ki.awaitAll Scope
scope


-- | Return the current actor's address.
--
-- @since 0.4.0.0
getSelf :: Actor msg (Address msg)
getSelf :: Actor msg (Address msg)
getSelf = ReaderT (ActorEnv msg) IO (Address msg) -> Actor msg (Address msg)
forall (msg :: * -> *) a.
ReaderT (ActorEnv msg) IO a -> Actor msg a
Actor (ReaderT (ActorEnv msg) IO (Address msg)
 -> Actor msg (Address msg))
-> ReaderT (ActorEnv msg) IO (Address msg)
-> Actor msg (Address msg)
forall a b. (a -> b) -> a -> b
$ (ActorEnv msg -> Address msg)
-> ReaderT (ActorEnv msg) IO (Address msg)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ActorEnv msg -> Address msg
forall (msg :: * -> *). ActorEnv msg -> Address msg
address


-- | Send a message to another actor, expecting no response. Returns immediately
-- without blocking.
--
-- @since 0.4.0.0
cast
  :: Address msg
  -- ^ Actor's address
  -> msg ()
  -- ^ Message to send
  -> Actor _msg ()
cast :: Address msg -> msg () -> Actor _msg ()
cast (Address InChan (Envelope msg)
inChan) msg ()
msg = IO () -> Actor _msg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Actor _msg ()) -> IO () -> Actor _msg ()
forall a b. (a -> b) -> a -> b
$ InChan (Envelope msg) -> Envelope msg -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan (Envelope msg)
inChan (msg () -> Envelope msg
forall (msg :: * -> *). msg () -> Envelope msg
Cast msg ()
msg)


-- | Send a message to another actor, and wait for a response.
--
-- @since 0.4.0.0
call
  :: Address msg
  -- ^ Actor's address
  -> msg res
  -- ^ Message to send
  -> Actor _msg res
  -- ^ Response
call :: Address msg -> msg res -> Actor _msg res
call (Address InChan (Envelope msg)
inChan) msg res
msg = IO res -> Actor _msg res
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  MVar res
resMVar <- IO (MVar res)
forall a. IO (MVar a)
newEmptyMVar
  InChan (Envelope msg) -> Envelope msg -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan (Envelope msg)
inChan (MVar res -> msg res -> Envelope msg
forall res (msg :: * -> *). MVar res -> msg res -> Envelope msg
Call MVar res
resMVar msg res
msg)
  MVar res -> IO res
forall a. MVar a -> IO a
takeMVar MVar res
resMVar


-- | Receive a message. When the mailbox is empty, blocks until a message
-- arrives.
--
-- @since 0.4.0.0
receive
  :: (forall res. msg res -> Actor msg res)
  -- ^ Callback function that responds to messages
  -> Actor msg ()
receive :: (forall res. msg res -> Actor msg res) -> Actor msg ()
receive forall res. msg res -> Actor msg res
callback = do
  Mailbox OutChan (Envelope msg)
outChan <- ReaderT (ActorEnv msg) IO (Mailbox msg) -> Actor msg (Mailbox msg)
forall (msg :: * -> *) a.
ReaderT (ActorEnv msg) IO a -> Actor msg a
Actor (ReaderT (ActorEnv msg) IO (Mailbox msg)
 -> Actor msg (Mailbox msg))
-> ReaderT (ActorEnv msg) IO (Mailbox msg)
-> Actor msg (Mailbox msg)
forall a b. (a -> b) -> a -> b
$ (ActorEnv msg -> Mailbox msg)
-> ReaderT (ActorEnv msg) IO (Mailbox msg)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ActorEnv msg -> Mailbox msg
forall (msg :: * -> *). ActorEnv msg -> Mailbox msg
mailbox
  Envelope msg
envelope <- IO (Envelope msg) -> Actor msg (Envelope msg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Envelope msg) -> Actor msg (Envelope msg))
-> IO (Envelope msg) -> Actor msg (Envelope msg)
forall a b. (a -> b) -> a -> b
$ OutChan (Envelope msg) -> IO (Envelope msg)
forall a. OutChan a -> IO a
Unagi.readChan OutChan (Envelope msg)
outChan
  case Envelope msg
envelope of
    Cast msg ()
msg ->
      msg () -> Actor msg ()
forall res. msg res -> Actor msg res
callback msg ()
msg
    Call MVar res
resMVar msg res
msg -> do
      res
res <- msg res -> Actor msg res
forall res. msg res -> Actor msg res
callback msg res
msg
      IO () -> Actor msg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Actor msg ()) -> IO () -> Actor msg ()
forall a b. (a -> b) -> a -> b
$ MVar res -> res -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar res
resMVar res
res


-- | Try to receive a message. When the mailbox is empty, returns immediately.
--
-- @since 0.4.0.0
tryReceive
  :: (forall res. msg res -> Actor msg res)
  -- ^ Callback function that responds to messages
  -> Actor msg Bool
tryReceive :: (forall res. msg res -> Actor msg res) -> Actor msg Bool
tryReceive forall res. msg res -> Actor msg res
callback = do
  Mailbox OutChan (Envelope msg)
outChan <- ReaderT (ActorEnv msg) IO (Mailbox msg) -> Actor msg (Mailbox msg)
forall (msg :: * -> *) a.
ReaderT (ActorEnv msg) IO a -> Actor msg a
Actor (ReaderT (ActorEnv msg) IO (Mailbox msg)
 -> Actor msg (Mailbox msg))
-> ReaderT (ActorEnv msg) IO (Mailbox msg)
-> Actor msg (Mailbox msg)
forall a b. (a -> b) -> a -> b
$ (ActorEnv msg -> Mailbox msg)
-> ReaderT (ActorEnv msg) IO (Mailbox msg)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ActorEnv msg -> Mailbox msg
forall (msg :: * -> *). ActorEnv msg -> Mailbox msg
mailbox
  (Element (Envelope msg)
element, IO (Envelope msg)
_) <- IO (Element (Envelope msg), IO (Envelope msg))
-> Actor msg (Element (Envelope msg), IO (Envelope msg))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Element (Envelope msg), IO (Envelope msg))
 -> Actor msg (Element (Envelope msg), IO (Envelope msg)))
-> IO (Element (Envelope msg), IO (Envelope msg))
-> Actor msg (Element (Envelope msg), IO (Envelope msg))
forall a b. (a -> b) -> a -> b
$ OutChan (Envelope msg)
-> IO (Element (Envelope msg), IO (Envelope msg))
forall a. OutChan a -> IO (Element a, IO a)
Unagi.tryReadChan OutChan (Envelope msg)
outChan
  Maybe (Envelope msg)
envelope <- IO (Maybe (Envelope msg)) -> Actor msg (Maybe (Envelope msg))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Envelope msg)) -> Actor msg (Maybe (Envelope msg)))
-> IO (Maybe (Envelope msg)) -> Actor msg (Maybe (Envelope msg))
forall a b. (a -> b) -> a -> b
$ Element (Envelope msg) -> IO (Maybe (Envelope msg))
forall a. Element a -> IO (Maybe a)
Unagi.tryRead Element (Envelope msg)
element
  case Maybe (Envelope msg)
envelope of
    Maybe (Envelope msg)
Nothing ->
      Bool -> Actor msg Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just (Cast msg ()
msg) -> do
      msg () -> Actor msg ()
forall res. msg res -> Actor msg res
callback msg ()
msg
      Bool -> Actor msg Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just (Call MVar res
resMVar msg res
msg) -> do
      res
res <- msg res -> Actor msg res
forall res. msg res -> Actor msg res
callback msg res
msg
      IO () -> Actor msg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Actor msg ()) -> IO () -> Actor msg ()
forall a b. (a -> b) -> a -> b
$ MVar res -> res -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar res
resMVar res
res
      Bool -> Actor msg Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True


-- | Run a top-level actor. Intended to be used at the entry point of your
-- program.
--
-- If your program is designed with actors in mind, you can use `Actor` as
-- your program's base monad:
--
-- > main :: IO ()
-- > main = runActor root
-- >
-- > root :: Actor RootMsg ()
-- > root = do
-- >   ...
--
-- Otherwise, use `runActor` like you would with @run@ functions from libraries
-- like @transformers@ or @mtl@.
--
-- @since 0.4.0.0
runActor :: MonadIO m => Actor msg a -> m a
runActor :: Actor msg a -> m a
runActor Actor msg a
actor = do
  (InChan (Envelope msg)
inChan, OutChan (Envelope msg)
outChan) <- IO (InChan (Envelope msg), OutChan (Envelope msg))
-> m (InChan (Envelope msg), OutChan (Envelope msg))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan (Envelope msg), OutChan (Envelope msg))
forall a. IO (InChan a, OutChan a)
Unagi.newChan
  let address :: Address msg
address = InChan (Envelope msg) -> Address msg
forall (msg :: * -> *). InChan (Envelope msg) -> Address msg
Address InChan (Envelope msg)
inChan
  let mailbox :: Mailbox msg
mailbox = OutChan (Envelope msg) -> Mailbox msg
forall (msg :: * -> *). OutChan (Envelope msg) -> Mailbox msg
Mailbox OutChan (Envelope msg)
outChan
  Address msg -> Mailbox msg -> Actor msg a -> m a
forall (m :: * -> *) (msg :: * -> *) a.
MonadIO m =>
Address msg -> Mailbox msg -> Actor msg a -> m a
runActorImpl Address msg
address Mailbox msg
mailbox Actor msg a
actor


-- | More efficient version of `runActor`, for actors which receive no messages
-- (@msg ~ `NoMsg`@). See docs for `runActor` for more information.
--
-- @since 0.4.0.0
runActor_ :: MonadIO m => Actor_ a -> m a
runActor_ :: Actor_ a -> m a
runActor_ Actor_ a
actor = do
  let address :: Address msg
address = InChan (Envelope msg) -> Address msg
forall (msg :: * -> *). InChan (Envelope msg) -> Address msg
Address (String -> InChan (Envelope msg)
forall a. HasCallStack => String -> a
error String
noMsgError)
  let mailbox :: Mailbox msg
mailbox = OutChan (Envelope msg) -> Mailbox msg
forall (msg :: * -> *). OutChan (Envelope msg) -> Mailbox msg
Mailbox (String -> OutChan (Envelope msg)
forall a. HasCallStack => String -> a
error String
noMsgError)
  Address NoMsg -> Mailbox NoMsg -> Actor_ a -> m a
forall (m :: * -> *) (msg :: * -> *) a.
MonadIO m =>
Address msg -> Mailbox msg -> Actor msg a -> m a
runActorImpl Address NoMsg
forall (msg :: * -> *). Address msg
address Mailbox NoMsg
forall (msg :: * -> *). Mailbox msg
mailbox Actor_ a
actor


runActorImpl :: MonadIO m => Address msg -> Mailbox msg -> Actor msg a -> m a
runActorImpl :: Address msg -> Mailbox msg -> Actor msg a -> m a
runActorImpl Address msg
address Mailbox msg
mailbox (Actor ReaderT (ActorEnv msg) IO a
reader) =
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ (Scope -> IO a) -> IO a
forall a (m :: * -> *). MonadUnliftIO m => (Scope -> m a) -> m a
Ki.scoped \Scope
scope ->
    ReaderT (ActorEnv msg) IO a -> ActorEnv msg -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ActorEnv msg) IO a
reader ActorEnv :: forall (msg :: * -> *).
Address msg -> Mailbox msg -> Scope -> ActorEnv msg
ActorEnv{Address msg
address :: Address msg
address :: Address msg
address, Mailbox msg
mailbox :: Mailbox msg
mailbox :: Mailbox msg
mailbox, Scope
scope :: Scope
scope :: Scope
scope}


noMsgError :: String
noMsgError :: String
noMsgError = [String] -> String
unlines ([String] -> String)
-> ([[String]] -> [String]) -> [[String]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> [[String]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
unwords ([[String]] -> String) -> [[String]] -> String
forall a b. (a -> b) -> a -> b
$
  [ [String
"[!] drama internal error"]
  , []
  , [ String
"Attempted to use the address or mailbox of a actor which cannot send"
    , String
"or receive messages (msg ~ NoMsg)."
    ]
  , [ String
"This should be impossible using non-internal modules!" ]
  , []
  , [ String
"Please report this issue at https://github.com/evanrelf/drama/issues"
    ]
  ]