{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TypedProtocol.ReqResp.Server where

import           Network.TypedProtocol.Core
import           Network.TypedProtocol.Peer.Server
import           Network.TypedProtocol.ReqResp.Type


data ReqRespServer req resp m a = ReqRespServer {
    -- | The client sent us a ping message. We have no choices here, and
    -- the response is nullary, all we have are local effects.
    forall req resp (m :: * -> *) a.
ReqRespServer req resp m a
-> req -> m (resp, ReqRespServer req resp m a)
recvMsgReq  :: req -> m (resp, ReqRespServer req resp m a)

    -- | The client terminated. Here we have a pure return value, but we
    -- could have done another action in 'm' if we wanted to.
  , forall req resp (m :: * -> *) a. ReqRespServer req resp m a -> m a
recvMsgDone :: m a
  }


-- | Interpret a particular server action sequence into the server side of the
-- 'ReqResp' protocol.
--
reqRespServerPeer
  :: Monad m
  => ReqRespServer req resp m a
  -> Server (ReqResp req resp) NonPipelined StIdle m a
reqRespServerPeer :: forall (m :: * -> *) req resp a.
Monad m =>
ReqRespServer req resp m a
-> Server (ReqResp req resp) 'NonPipelined 'StIdle m a
reqRespServerPeer ReqRespServer{m a
req -> m (resp, ReqRespServer req resp m a)
recvMsgReq :: forall req resp (m :: * -> *) a.
ReqRespServer req resp m a
-> req -> m (resp, ReqRespServer req resp m a)
recvMsgDone :: forall req resp (m :: * -> *) a. ReqRespServer req resp m a -> m a
recvMsgReq :: req -> m (resp, ReqRespServer req resp m a)
recvMsgDone :: m a
..} =

    -- In the 'StIdle' the server is awaiting a request message
    (forall (st' :: ReqResp req resp).
 Message (ReqResp req resp) 'StIdle st'
 -> Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) '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 ((forall (st' :: ReqResp req resp).
  Message (ReqResp req resp) 'StIdle st'
  -> Server (ReqResp req resp) 'NonPipelined st' m a)
 -> Server (ReqResp req resp) 'NonPipelined 'StIdle m a)
-> (forall (st' :: ReqResp req resp).
    Message (ReqResp req resp) 'StIdle st'
    -> Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$ \Message (ReqResp req resp) 'StIdle st'
msg ->

    -- The client got to choose between two messages and we have to handle
    -- either of them
    case Message (ReqResp req resp) 'StIdle st'
msg of

      -- The client sent the done transition, so we're in the 'StDone' state
      -- so all we can do is stop using 'done', with a return value.
      Message (ReqResp req resp) 'StIdle st'
R:MessageReqRespfromto (*) (*) req resp 'StIdle st'
MsgDone -> m (Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) '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 (ReqResp req resp) 'NonPipelined st' m a)
 -> Server (ReqResp req resp) 'NonPipelined st' m a)
-> m (Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ a -> Server (ReqResp req resp) '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 (ReqResp req resp) 'NonPipelined st' m a)
-> m a -> m (Server (ReqResp req resp) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
recvMsgDone

      -- The client sent us a ping request, so now we're in the 'StBusy' state
      -- which means it's the server's turn to send.
      MsgReq req1
req -> m (Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) '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 (ReqResp req resp) 'NonPipelined st' m a)
 -> Server (ReqResp req resp) 'NonPipelined st' m a)
-> m (Server (ReqResp req resp) 'NonPipelined st' m a)
-> Server (ReqResp req resp) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
        (resp, next) <- req -> m (resp, ReqRespServer req resp m a)
recvMsgReq req
req1
req
        pure $ Yield (MsgResp resp) (reqRespServerPeer next)