typed-protocols-examples: ReqResp2 example

An example which demonstrates that one can pipeline two kinds of
requests, and collect all the responses.

typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Client.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
+
+
+
+module Network.TypedProtocol.ReqResp2.Client where
+
+import           Network.TypedProtocol.ReqResp2.Type
+
+import           Network.TypedProtocol.Core
+import           Network.TypedProtocol.Peer.Client
+
+
+reqResp2Client :: forall req resp m.
+                  ()
+               => [Either req req]
+               -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) Z StIdle m [Either resp resp]
+reqResp2Client = send Zero
+  where
+    -- pipeline all the requests, either through `MsgReq` or `MsgReq'`.
+    send :: forall (n :: N).
+            Nat n
+         -> [Either req req] -- requests to send
+         -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp))  n StIdle m [Either resp resp]
+
+    send !n (Left req : reqs) =
+      YieldPipelined (MsgReq  req) receiver (send (Succ n) reqs)
+
+    send !n (Right req : reqs) =
+      YieldPipelined (MsgReq' req) receiver' (send (Succ n) reqs)
+
+    send !n [] = collect n []
+
+
+    receiver :: Receiver (ReqResp2 req resp) StBusy StIdle m (Either resp resp)
+    receiver = ReceiverAwait (\(MsgResp resp) -> ReceiverDone (Left resp))
+
+
+    receiver' :: Receiver (ReqResp2 req resp) StBusy' StIdle m (Either resp resp)
+    receiver' = ReceiverAwait (\(MsgResp' resp) -> ReceiverDone (Right resp))
+
+
+    -- collect all the responses
+    collect :: Nat n
+            -> [Either resp resp] -- all the responses received so far
+            -> Client (ReqResp2 req resp) ('Pipelined (Either resp resp)) n StIdle m [Either resp resp]
+
+    collect Zero !resps = Yield MsgDone (Done (reverse resps))
+
+    collect (Succ n) !resps =
+      Collect Nothing $ \c  -> collect n (c : resps)
+
+
+

typed-protocols-examples/src/Network/TypedProtocol/ReqResp2/Type.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE EmptyCase          #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies       #-}
+
+
+module Network.TypedProtocol.ReqResp2.Type where
+
+import           Data.Singletons
+
+import           Network.TypedProtocol.Core
+
+
+data ReqResp2 req resp where
+  StIdle  :: ReqResp2 req resp
+  StBusy  :: ReqResp2 req resp
+  StBusy' :: ReqResp2 req resp
+  StDone  :: ReqResp2 req resp
+
+data SReqResp2 (st :: ReqResp2 req resp) where
+    SingIdle  :: SReqResp2 StIdle
+    SingBusy  :: SReqResp2 StBusy
+    SingBusy' :: SReqResp2 StBusy'
+    SingDone  :: SReqResp2 StDone
+
+deriving instance Show (SReqResp2 st)
+
+type instance Sing = SReqResp2
+instance SingI StIdle where
+    sing = SingIdle
+instance SingI StBusy where
+    sing = SingBusy
+instance SingI StBusy' where
+    sing = SingBusy'
+instance SingI StDone where
+    sing = SingDone
+
+
+instance Protocol (ReqResp2 req resp) where
+
+  data Message (ReqResp2 req resp) from to where
+    MsgReq   :: req  -> Message (ReqResp2 req resp) StIdle  StBusy
+    MsgResp  :: resp -> Message (ReqResp2 req resp) StBusy  StIdle
+
+    MsgReq'  :: req  -> Message (ReqResp2 req resp) StIdle  StBusy'
+    MsgResp' :: resp -> Message (ReqResp2 req resp) StBusy' StIdle
+
+    MsgDone  ::         Message (ReqResp2 req resp) StIdle  StDone
+
+  type StateAgency StIdle  = ClientAgency
+  type StateAgency StBusy  = ServerAgency
+  type StateAgency StBusy' = ServerAgency
+  type StateAgency StDone  = NobodyAgency
+
+
+deriving instance (Show req, Show resp)
+               => Show (Message (ReqResp2 req resp) from to)
+
+deriving instance (Eq req, Eq resp)
+               => Eq (Message (ReqResp2 req resp) from to)
+

typed-protocols-examples/typed-protocols-examples.cabal

@@ -35,6 +35,8 @@ library
                    , Network.TypedProtocol.ReqResp.Codec.CBOR
                    , Network.TypedProtocol.ReqResp.Examples
 
+                   , Network.TypedProtocol.ReqResp2.Type
+                   , Network.TypedProtocol.ReqResp2.Client
   other-extensions:  GADTs
                    , RankNTypes
                    , PolyKinds