{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_HADDOCK not-home #-}

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

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


-- | @since 0.3.0.0
type Server msg a = Process (Envelope msg) a


-- | Wrapper around higher-kinded message types, to make them compatible with
-- the lower-level `Process` machinery.
--
-- Higher-kinded message types are defined as GADTs with a type parameter. This
-- allows specifying the response type for messages.
--
-- @since 0.3.0.0
data Envelope (msg :: Type -> Type) where
  Cast :: msg () -> Envelope msg
  Call :: HasMsg res => Address res -> msg res -> Envelope msg


-- | Send a message to another process, expecting no response. Returns
-- immediately without blocking.
--
-- @since 0.3.0.0
cast
  :: Address (Envelope msg)
  -- ^ Process' address
  -> msg ()
  -- ^ Message to send
  -> 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)


-- | Send a message to another process, and wait for a response.
--
-- @since 0.3.0.0
call
  :: HasMsg res
  => Address (Envelope msg)
  -- ^ Process' address
  -> msg res
  -- ^ Message to send
  -> Process _msg res
  -- ^ Response
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 messages which may require a response. This is the only way to
-- consume an `Envelope`.
--
-- @since 0.3.0.0
handle
  :: (forall res. msg res -> Process _msg res)
  -- ^ Callback function that responds to messages
  -> Envelope msg
  -- ^ Message to handle
  -> 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