{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_HADDOCK not-home #-}
module Drama.Internal where
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Reader (ReaderT (..), asks)
import qualified Control.Concurrent.Chan.Unagi as Unagi
import qualified 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 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 msg a b. a -> Actor msg b -> Actor msg a
forall msg 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
<$ :: 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 msg. Functor (Actor msg)
forall a. a -> Actor msg a
forall msg 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 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 a b c.
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
forall msg a b c.
(a -> b -> c) -> Actor msg a -> Actor msg b -> Actor msg c
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
<* :: 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 msg. Applicative (Actor msg)
forall a. a -> Actor msg a
forall msg 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 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
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
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 msg. Monad (Actor msg)
forall a. IO a -> Actor msg a
forall msg a. IO a -> Actor msg a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Actor msg a
$cliftIO :: forall msg a. IO a -> Actor msg a
$cp1MonadIO :: forall msg. Monad (Actor msg)
MonadIO
, 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 msg. Applicative (Actor msg)
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 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
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
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
#if MIN_VERSION_base(4,9,0)
, 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 msg. Monad (Actor msg)
forall msg. Alternative (Actor msg)
forall a. Actor msg a
forall a. Actor msg a -> Actor msg a -> Actor msg a
forall msg a. Actor msg a
forall msg a. Actor msg a -> Actor msg a -> Actor msg a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
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
#endif
, Monad (Actor msg)
Monad (Actor msg)
-> (forall a. String -> Actor msg a) -> MonadFail (Actor msg)
String -> Actor msg a
forall msg. Monad (Actor msg)
forall a. String -> Actor msg a
forall msg a. String -> Actor msg a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> Actor msg a
$cfail :: forall msg a. String -> Actor msg a
$cp1MonadFail :: forall msg. Monad (Actor msg)
MonadFail
, 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 msg. Monad (Actor msg)
forall a. (a -> Actor msg a) -> Actor msg a
forall msg a. (a -> Actor msg a) -> Actor msg a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
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
)
runActor :: MonadIO m => ActorEnv msg -> Actor msg a -> m a
runActor :: ActorEnv msg -> Actor msg a -> m a
runActor ActorEnv msg
actorEnv (Actor ReaderT (ActorEnv msg) IO a
m) = 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
$ 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
m ActorEnv msg
actorEnv
data ActorEnv msg = ActorEnv
{ ActorEnv msg -> Address msg
address :: Address msg
, ActorEnv msg -> Mailbox msg
mailbox :: Mailbox msg
, ActorEnv msg -> Scope
scope :: Scope
}
newtype Address msg = Address (Unagi.InChan msg)
newtype Mailbox msg = Mailbox (Unagi.OutChan msg)
newtype Scope = Scope Ki.Scope
spawn :: Actor childMsg () -> Actor msg (Address childMsg)
spawn :: Actor childMsg () -> Actor msg (Address childMsg)
spawn Actor childMsg ()
actor = do
(InChan childMsg
inChan, OutChan childMsg
outChan) <- IO (InChan childMsg, OutChan childMsg)
-> Actor msg (InChan childMsg, OutChan childMsg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan childMsg, OutChan childMsg)
forall a. IO (InChan a, OutChan a)
Unagi.newChan
let address :: Address childMsg
address = InChan childMsg -> Address childMsg
forall msg. InChan msg -> Address msg
Address InChan childMsg
inChan
let mailbox :: Mailbox childMsg
mailbox = OutChan childMsg -> Mailbox childMsg
forall msg. OutChan msg -> Mailbox msg
Mailbox OutChan childMsg
outChan
Scope Scope
kiScope <- 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
$ Scope -> IO () -> IO ()
Ki.fork_ Scope
kiScope (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Scope -> IO ()) -> IO ()
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
childKiScope ->
let childScope :: Scope
childScope = Scope -> Scope
Scope Scope
childKiScope
childEnv :: ActorEnv childMsg
childEnv = ActorEnv :: forall msg. Address msg -> Mailbox msg -> Scope -> ActorEnv msg
ActorEnv{Address childMsg
address :: Address childMsg
address :: Address childMsg
address, Mailbox childMsg
mailbox :: Mailbox childMsg
mailbox :: Mailbox childMsg
mailbox, scope :: Scope
scope = Scope
childScope}
in ActorEnv childMsg -> Actor childMsg () -> IO ()
forall (m :: * -> *) msg a.
MonadIO m =>
ActorEnv msg -> Actor msg a -> m a
runActor ActorEnv childMsg
childEnv Actor childMsg ()
actor
Address childMsg -> Actor msg (Address childMsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Address childMsg
address
wait :: Actor msg ()
wait :: Actor msg ()
wait = do
Scope Scope
kiScope <- 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
$ Scope -> IO ()
Ki.wait Scope
kiScope
here :: Actor msg (Address msg)
here :: Actor msg (Address msg)
here = 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 :: Address recipientMsg -> recipientMsg -> Actor msg ()
send :: Address recipientMsg -> recipientMsg -> Actor msg ()
send (Address InChan recipientMsg
inChan) recipientMsg
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 recipientMsg -> recipientMsg -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan recipientMsg
inChan recipientMsg
msg
receive :: Actor msg msg
receive :: Actor msg msg
receive = do
Mailbox OutChan 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
IO msg -> Actor msg msg
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO msg -> Actor msg msg) -> IO msg -> Actor msg msg
forall a b. (a -> b) -> a -> b
$ OutChan msg -> IO msg
forall a. OutChan a -> IO a
Unagi.readChan OutChan msg
outChan
tryReceive :: Actor msg (Maybe msg)
tryReceive :: Actor msg (Maybe msg)
tryReceive = do
Mailbox OutChan 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 msg
element, IO msg
_) <- IO (Element msg, IO msg) -> Actor msg (Element msg, IO msg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Element msg, IO msg) -> Actor msg (Element msg, IO msg))
-> IO (Element msg, IO msg) -> Actor msg (Element msg, IO msg)
forall a b. (a -> b) -> a -> b
$ OutChan msg -> IO (Element msg, IO msg)
forall a. OutChan a -> IO (Element a, IO a)
Unagi.tryReadChan OutChan msg
outChan
IO (Maybe msg) -> Actor msg (Maybe msg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe msg) -> Actor msg (Maybe msg))
-> IO (Maybe msg) -> Actor msg (Maybe msg)
forall a b. (a -> b) -> a -> b
$ Element msg -> IO (Maybe msg)
forall a. Element a -> IO (Maybe a)
Unagi.tryRead Element msg
element
run :: MonadIO m => Actor msg a -> m a
run :: Actor msg a -> m a
run Actor msg a
actor = do
(InChan msg
inChan, OutChan msg
outChan) <- IO (InChan msg, OutChan msg) -> m (InChan msg, OutChan msg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan msg, OutChan msg)
forall a. IO (InChan a, OutChan a)
Unagi.newChan
let address :: Address msg
address = InChan msg -> Address msg
forall msg. InChan msg -> Address msg
Address InChan msg
inChan
let mailbox :: Mailbox msg
mailbox = OutChan msg -> Mailbox msg
forall msg. OutChan msg -> Mailbox msg
Mailbox OutChan msg
outChan
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. (Scope -> IO a) -> IO a
Ki.scoped \Scope
kiScope -> do
let scope :: Scope
scope = Scope -> Scope
Scope Scope
kiScope
ActorEnv msg -> Actor msg a -> IO a
forall (m :: * -> *) msg a.
MonadIO m =>
ActorEnv msg -> Actor msg a -> m a
runActor 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} Actor msg a
actor
loop
:: s
-> (s -> Actor msg (Either s a))
-> Actor msg a
loop :: s -> (s -> Actor msg (Either s a)) -> Actor msg a
loop s
s0 s -> Actor msg (Either s a)
k =
s -> Actor msg (Either s a)
k s
s0 Actor msg (Either s a)
-> (Either s a -> Actor msg a) -> Actor msg a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left s
s -> s -> (s -> Actor msg (Either s a)) -> Actor msg a
forall s msg a. s -> (s -> Actor msg (Either s a)) -> Actor msg a
loop s
s s -> Actor msg (Either s a)
k
Right a
x -> a -> Actor msg a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
continue :: s -> Actor msg (Either s a)
continue :: s -> Actor msg (Either s a)
continue s
s = Either s a -> Actor msg (Either s a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Either s a
forall a b. a -> Either a b
Left s
s)
exit :: a -> Actor msg (Either s a)
exit :: a -> Actor msg (Either s a)
exit a
x = Either s a -> Actor msg (Either s a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either s a
forall a b. b -> Either a b
Right a
x)