{-# 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 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
#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
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
, 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
)
data ActorEnv msg = ActorEnv
{ ActorEnv msg -> Address msg
address :: Address msg
, ActorEnv msg -> Mailbox msg
mailbox :: Mailbox msg
, ActorEnv msg -> Scope
scope :: Ki.Scope
}
newtype Address msg = Address (Unagi.InChan (Envelope msg))
newtype Mailbox msg = Mailbox (Unagi.OutChan (Envelope msg))
data Envelope (msg :: Type -> Type) where
Cast :: msg () -> Envelope msg
Call :: MVar res -> msg res -> Envelope msg
data NoMsg res
type Actor_ = Actor NoMsg
spawn
:: Actor msg ()
-> Actor _msg (Address msg)
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
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
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
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
cast
:: Address msg
-> msg ()
-> 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)
call
:: Address msg
-> msg res
-> Actor _msg res
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
:: (forall res. msg res -> Actor msg res)
-> 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
tryReceive
:: (forall res. msg res -> Actor msg res)
-> 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
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
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"
]
]