{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.TypedProtocol.ReqResp.Examples where

import           Network.TypedProtocol.ReqResp.Client
import           Network.TypedProtocol.ReqResp.Server

import           Network.TypedProtocol.Peer.Client

-- | An example request\/response client which ignores received responses.
--
reqRespClient :: Monad m
              => [req]
              -> ReqRespClient req resp m ()
reqRespClient :: forall (m :: * -> *) req resp.
Monad m =>
[req] -> ReqRespClient req resp m ()
reqRespClient = [req] -> ReqRespClient req resp m ()
forall (m :: * -> *) req resp.
Monad m =>
[req] -> ReqRespClient req resp m ()
go
  where
    go :: [req] -> ReqRespClient req resp m ()
go []         = m () -> ReqRespClient req resp m ()
forall (m :: * -> *) a req resp. m a -> ReqRespClient req resp m a
SendMsgDone (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    go (req
req:[req]
reqs) = req
-> (resp -> m (ReqRespClient req resp m ()))
-> ReqRespClient req resp m ()
forall req resp (m :: * -> *) a.
req
-> (resp -> m (ReqRespClient req resp m a))
-> ReqRespClient req resp m a
SendMsgReq req
req (\resp
_resp -> ReqRespClient req resp m () -> m (ReqRespClient req resp m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([req] -> ReqRespClient req resp m ()
go [req]
reqs))


-- | A request\/response server instance that computes a 'Data.List.mapAccumL'
-- over the stream of requests.
--
reqRespServerMapAccumL :: Monad m
                       => (acc -> req -> m (acc, resp))
                       -> acc
                       -> ReqRespServer req resp m acc
reqRespServerMapAccumL :: forall (m :: * -> *) acc req resp.
Monad m =>
(acc -> req -> m (acc, resp))
-> acc -> ReqRespServer req resp m acc
reqRespServerMapAccumL acc -> req -> m (acc, resp)
f !acc
acc =
    ReqRespServer {
      recvMsgReq :: req -> m (resp, ReqRespServer req resp m acc)
recvMsgReq  = \req
req -> do (acc', resp) <- acc -> req -> m (acc, resp)
f acc
acc req
req
                               return (resp, reqRespServerMapAccumL f acc'),
      recvMsgDone :: m acc
recvMsgDone = acc -> m acc
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc
    }


-- | An example request\/response client that sends the given list of requests
-- and collects the list of responses.
--
reqRespClientMap :: Monad m
                 => [req]
                 -> ReqRespClient req resp m [resp]
reqRespClientMap :: forall (m :: * -> *) req resp.
Monad m =>
[req] -> ReqRespClient req resp m [resp]
reqRespClientMap = [resp] -> [req] -> ReqRespClient req resp m [resp]
forall {m :: * -> *} {a} {req}.
Monad m =>
[a] -> [req] -> ReqRespClient req a m [a]
go []
  where
    go :: [a] -> [req] -> ReqRespClient req a m [a]
go [a]
resps []         = m [a] -> ReqRespClient req a m [a]
forall (m :: * -> *) a req resp. m a -> ReqRespClient req resp m a
SendMsgDone ([a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
resps)
    go [a]
resps (req
req:[req]
reqs) =
      req
-> (a -> m (ReqRespClient req a m [a]))
-> ReqRespClient req a m [a]
forall req resp (m :: * -> *) a.
req
-> (resp -> m (ReqRespClient req resp m a))
-> ReqRespClient req resp m a
SendMsgReq req
req ((a -> m (ReqRespClient req a m [a])) -> ReqRespClient req a m [a])
-> (a -> m (ReqRespClient req a m [a]))
-> ReqRespClient req a m [a]
forall a b. (a -> b) -> a -> b
$ \a
resp ->
      ReqRespClient req a m [a] -> m (ReqRespClient req a m [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [req] -> ReqRespClient req a m [a]
go (a
respa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
resps) [req]
reqs)

--
-- Pipelined example
--

-- | An example request\/response client that sends the given list of requests
-- and collects the list of responses.
--
-- It is pipelined and tries to collect any replies if they are available.
-- This allows pipelining but keeps it to a minimum, and correspondingly it
-- gives maximum choice to the environment (drivers).
--
-- In theory, with enough and large enough requests and responses, this should
-- be able to saturate any channel of any bandwidth and latency, because it
-- should be able to have both peers send essentially continuously.
--
reqRespClientMapPipelined :: forall req resp m.
                             Monad m
                          => [req]
                          -> ReqRespClientPipelined req resp m [resp]
reqRespClientMapPipelined :: forall req resp (m :: * -> *).
Monad m =>
[req] -> ReqRespClientPipelined req resp m [resp]
reqRespClientMapPipelined [req]
reqs0 =
    ReqRespIdle req resp 'Z resp m [resp]
-> ReqRespClientPipelined req resp m [resp]
forall req resp c (m :: * -> *) a.
ReqRespIdle req resp 'Z c m a
-> ReqRespClientPipelined req resp m a
ReqRespClientPipelined ([resp] -> Nat 'Z -> [req] -> ReqRespIdle req resp 'Z resp m [resp]
forall (o :: N).
[resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp]
go [] Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero [req]
reqs0)
  where
    go :: [resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp]
    go :: forall (o :: N).
[resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp]
go [resp]
resps Nat o
Zero [req]
reqs =
      case [req]
reqs of
        []        -> [resp] -> ReqRespIdle req resp 'Z resp m [resp]
forall a req resp c (m :: * -> *).
a -> ReqRespIdle req resp 'Z c m a
SendMsgDonePipelined ([resp] -> [resp]
forall a. [a] -> [a]
reverse [resp]
resps)
        req
req:[req]
reqs' -> [resp]
-> Nat o -> req -> [req] -> ReqRespIdle req resp o resp m [resp]
forall (o :: N).
[resp]
-> Nat o -> req -> [req] -> ReqRespIdle req resp o resp m [resp]
sendReq [resp]
resps Nat o
forall (n :: N). ('Z ~ n) => Nat n
Zero req
req [req]
reqs'

    go [resp]
resps (Succ Nat n
o) [req]
reqs =
      Maybe (ReqRespIdle req resp ('S n) resp m [resp])
-> (resp -> m (ReqRespIdle req resp n resp m [resp]))
-> ReqRespIdle req resp ('S n) resp m [resp]
forall req resp (n1 :: N) c (m :: * -> *) a.
Maybe (ReqRespIdle req resp ('S n1) c m a)
-> (c -> m (ReqRespIdle req resp n1 c m a))
-> ReqRespIdle req resp ('S n1) c m a
CollectPipelined
        (case [req]
reqs of
           []        -> Maybe (ReqRespIdle req resp ('S n) resp m [resp])
forall a. Maybe a
Nothing
           req
req:[req]
reqs' -> ReqRespIdle req resp ('S n) resp m [resp]
-> Maybe (ReqRespIdle req resp ('S n) resp m [resp])
forall a. a -> Maybe a
Just ([resp]
-> Nat ('S n)
-> req
-> [req]
-> ReqRespIdle req resp ('S n) resp m [resp]
forall (o :: N).
[resp]
-> Nat o -> req -> [req] -> ReqRespIdle req resp o resp m [resp]
sendReq [resp]
resps (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
o) req
req [req]
reqs'))
        (\resp
resp -> ReqRespIdle req resp n resp m [resp]
-> m (ReqRespIdle req resp n resp m [resp])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReqRespIdle req resp n resp m [resp]
 -> m (ReqRespIdle req resp n resp m [resp]))
-> ReqRespIdle req resp n resp m [resp]
-> m (ReqRespIdle req resp n resp m [resp])
forall a b. (a -> b) -> a -> b
$ [resp] -> Nat n -> [req] -> ReqRespIdle req resp n resp m [resp]
forall (o :: N).
[resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp]
go (resp
respresp -> [resp] -> [resp]
forall a. a -> [a] -> [a]
:[resp]
resps) Nat n
o [req]
reqs)

    sendReq :: [resp] -> Nat o -> req -> [req]
            -> ReqRespIdle req resp o resp m [resp]
    sendReq :: forall (o :: N).
[resp]
-> Nat o -> req -> [req] -> ReqRespIdle req resp o resp m [resp]
sendReq [resp]
resps Nat o
o req
req [req]
reqs' =
      req
-> (resp -> m resp)
-> ReqRespIdle req resp ('S o) resp m [resp]
-> ReqRespIdle req resp o resp m [resp]
forall req resp (m :: * -> *) c (n :: N) a.
req
-> (resp -> m c)
-> ReqRespIdle req resp ('S n) c m a
-> ReqRespIdle req resp n c m a
SendMsgReqPipelined req
req
        (\resp
resp -> resp -> m resp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return resp
resp)
        ([resp]
-> Nat ('S o) -> [req] -> ReqRespIdle req resp ('S o) resp m [resp]
forall (o :: N).
[resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp]
go [resp]
resps (Nat o -> Nat ('S o)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat o
o) [req]
reqs')