{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK not-home #-}
module Drama.Server.Internal where
import Control.Monad.IO.Class (MonadIO (..))
import Data.Kind (Type)
import Drama.Process (HasMsg, Process, send)
import Drama.Process.Internal (Address (..))
import qualified Control.Concurrent.Chan.Unagi as Unagi
type Server msg a = Process (Envelope msg) a
data Envelope (msg :: Type -> Type) where
Cast :: msg () -> Envelope msg
Call :: HasMsg res => Address res -> msg res -> Envelope msg
cast
:: Address (Envelope msg)
-> msg ()
-> Process _msg ()
cast :: Address (Envelope msg) -> msg () -> Process _msg ()
cast Address (Envelope msg)
addr msg ()
msg = Address (Envelope msg) -> Envelope msg -> Process _msg ()
forall msg _msg.
HasMsg msg =>
Address msg -> msg -> Process _msg ()
send Address (Envelope msg)
addr (msg () -> Envelope msg
forall (msg :: * -> *). msg () -> Envelope msg
Cast msg ()
msg)
call
:: HasMsg res
=> Address (Envelope msg)
-> msg res
-> Process _msg res
call :: Address (Envelope msg) -> msg res -> Process _msg res
call Address (Envelope msg)
addr msg res
msg = do
(InChan res
inChan, OutChan res
outChan) <- IO (InChan res, OutChan res)
-> Process _msg (InChan res, OutChan res)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan res, OutChan res)
forall a. IO (InChan a, OutChan a)
Unagi.newChan
let returnAddr :: Address res
returnAddr = InChan res -> Address res
forall msg. InChan msg -> Address msg
Address InChan res
inChan
Address (Envelope msg) -> Envelope msg -> Process _msg ()
forall msg _msg.
HasMsg msg =>
Address msg -> msg -> Process _msg ()
send Address (Envelope msg)
addr (Address res -> msg res -> Envelope msg
forall res (msg :: * -> *).
HasMsg res =>
Address res -> msg res -> Envelope msg
Call Address res
returnAddr msg res
msg)
IO res -> Process _msg res
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO res -> Process _msg res) -> IO res -> Process _msg res
forall a b. (a -> b) -> a -> b
$ OutChan res -> IO res
forall a. OutChan a -> IO a
Unagi.readChan OutChan res
outChan
handle
:: (forall res. msg res -> Process _msg res)
-> Envelope msg
-> Process _msg ()
handle :: (forall res. msg res -> Process _msg res)
-> Envelope msg -> Process _msg ()
handle forall res. msg res -> Process _msg res
callback = \case
Cast msg ()
msg ->
msg () -> Process _msg ()
forall res. msg res -> Process _msg res
callback msg ()
msg
Call Address res
returnAddr msg res
msg -> do
res
res <- msg res -> Process _msg res
forall res. msg res -> Process _msg res
callback msg res
msg
Address res -> res -> Process _msg ()
forall msg _msg.
HasMsg msg =>
Address msg -> msg -> Process _msg ()
send Address res
returnAddr res
res