{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE PolyKinds  #-}
{-# LANGUAGE RankNTypes #-}

-- | A higher level API to implement server for local message notification
-- miniprotocol.
--
-- For execution, 'localMsgNotificationServerPeer' reinterprets this high level
-- description into the underlying typed protocol representation.
--
module DMQ.Protocol.LocalMsgNotification.Server
  ( -- * Server API types
    LocalMsgNotificationServer (..)
  , ServerIdle (..)
  , ServerResponse (..)
    -- * Translates the server into a typed protocol
  , localMsgNotificationServerPeer
  ) where

import DMQ.Protocol.LocalMsgNotification.Type
import Network.TypedProtocol.Peer.Server

-- | The high level server wrapper
--
newtype LocalMsgNotificationServer m msg a =
  LocalMsgNotificationServer (m (ServerIdle m msg a))


-- | The server high level message handlers
--
data ServerIdle m msg a = ServerIdle {
  forall (m :: * -> *) msg a.
ServerIdle m msg a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
msgRequestHandler :: forall blocking.
                       SingBlockingStyle blocking
                    -> m (ServerResponse m blocking msg a),
  forall (m :: * -> *) msg a. ServerIdle m msg a -> m a
msgDoneHandler    :: !(m a)
  }


-- | The server high level response type
--
data ServerResponse m blocking msg a where
  -- | The server provides a response to the client's query
  --
  ServerReply :: BlockingReplyList blocking msg -- ^ received messages
              -> HasMore
              -> ServerIdle m msg a         -- ^ a continuation
              -> ServerResponse m blocking msg a


-- | tranlates the server into the typed protocol representation
--
localMsgNotificationServerPeer
  :: forall m msg a. Monad m
  => LocalMsgNotificationServer m msg a
  -> Server (LocalMsgNotification msg) NonPipelined StIdle m a
localMsgNotificationServerPeer :: forall (m :: * -> *) msg a.
Monad m =>
LocalMsgNotificationServer m msg a
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
localMsgNotificationServerPeer (LocalMsgNotificationServer m (ServerIdle m msg a)
handler) =
  m (Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
 -> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
-> m (Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
forall a b. (a -> b) -> a -> b
$ ServerIdle m msg a
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
go (ServerIdle m msg a
 -> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
-> m (ServerIdle m msg a)
-> m (Server (LocalMsgNotification msg) 'NonPipelined StIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ServerIdle m msg a)
handler
  where
    go  :: ServerIdle m msg a
        -> Server (LocalMsgNotification msg) NonPipelined StIdle m a
    go :: ServerIdle m msg a
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
go ServerIdle { forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
msgRequestHandler :: forall (m :: * -> *) msg a.
ServerIdle m msg a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
msgRequestHandler :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
msgRequestHandler, m a
msgDoneHandler :: forall (m :: * -> *) msg a. ServerIdle m msg a -> m a
msgDoneHandler :: m a
msgDoneHandler } =
      (forall (st' :: LocalMsgNotification msg).
 Message (LocalMsgNotification msg) StIdle st'
 -> Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> Server (LocalMsgNotification msg) 'NonPipelined StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
(forall (st' :: ps). Message ps st st' -> Server ps pl st' m a)
-> Server ps pl st m a
Await \case
        MsgRequest SingBlockingStyle blocking
blocking -> m (Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> Server (LocalMsgNotification msg) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect do
          ServerReply msgs more k <- SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking -> m (ServerResponse m blocking msg a)
msgRequestHandler SingBlockingStyle blocking
blocking
          pure $ Yield (MsgReply msgs more) (go k)

        Message (LocalMsgNotification msg) StIdle st'
R:MessageLocalMsgNotificationfromto msg StIdle st'
MsgClientDone -> m (Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> Server (LocalMsgNotification msg) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (LocalMsgNotification msg) 'NonPipelined st' m a)
 -> Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> m (Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> Server (LocalMsgNotification msg) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ a -> Server (LocalMsgNotification msg) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Server ps pl st m a
Done (a -> Server (LocalMsgNotification msg) 'NonPipelined st' m a)
-> m a
-> m (Server (LocalMsgNotification msg) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
msgDoneHandler