Better stateful API

.github/workflows/github-page.yml

@@ -1,8 +1,9 @@
 name: Haddocks
 
 on:
- schedule:
- - cron: '0 0 * * *'
+ push:
+ branches:
+ - main
  workflow_dispatch:
 
 jobs:

typed-protocols-cborg/typed-protocols-cborg.cabal

@@ -1,6 +1,6 @@
-cabal-version: 3.0
+cabal-version: 3.4
 name: typed-protocols-cborg
-version: 0.2.0.0
+version: 0.3.0.0
 synopsis: CBOR codecs for typed-protocols
 -- description:
 license: Apache-2.0
@@ -18,13 +18,13 @@ extra-source-files: CHANGELOG.md, README.md
 library
  exposed-modules: Network.TypedProtocol.Codec.CBOR
 
- build-depends: base >=4.12 && <4.21,
- bytestring >=0.10 && <0.13,
- cborg >=0.2.1 && <0.3,
- singletons, 
+ build-depends: base  >=4.12 && <4.21,
+ bytestring  >=0.10 && <0.13,
+ cborg  >=0.2.1 && <0.3,
+ singletons,  
 
- io-classes ^>=1.5,
- typed-protocols
+ io-classes  ^>=1.5,
+ typed-protocols ^>=0.3
 
  hs-source-dirs: src
  default-language: Haskell2010

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs

@@ -30,12 +30,12 @@ reqRespClientPeer
  -> Client (ReqResp req) StIdle State m a
 
 reqRespClientPeer (SendMsgDone a) =
- Yield StateDone MsgDone (Done a)
+ Yield StateIdle StateDone MsgDone (Done a)
 
 reqRespClientPeer (SendMsgReq req next) =
- Yield (StateBusy req)
+ Yield StateIdle (StateBusy req)
  (MsgReq req) $
- Await $ \_ (MsgResp _ resp) ->
+ Await $ \_ (MsgResp resp) ->
  let client = next resp
  in ( Effect $ reqRespClientPeer <$> client
  , StateIdle

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs

@@ -37,12 +37,12 @@ codecReqResp
 codecReqResp encodeReq decodeReq encodeResp decodeResp =
  Codec { encode, decode }
  where
- encode :: State st'
+ encode :: State st
  -> Message (ReqResp req) st st'
  -> String
  encode _ (MsgReq req) = "MsgReq " ++ encodeReq req ++ "\n"
  encode _ MsgDone = "MsgDone\n"
- encode _ (MsgResp req resp) = "MsgResp " ++ encodeResp req resp ++ "\n"
+ encode (StateBusy req) (MsgResp resp) = "MsgResp " ++ encodeResp req resp ++ "\n"
 
  decode :: forall (st :: ReqResp req).
  ActiveState st
@@ -60,7 +60,7 @@ codecReqResp encodeReq decodeReq encodeResp decodeResp =
  (SingBusy, StateBusy req, ("MsgResp", str'))
  -- note that we need `req` to decode response of the given type
  | Just resp <- decodeResp req str'
- -> DecodeDone (SomeMessage (MsgResp req resp)) trailing
+ -> DecodeDone (SomeMessage (MsgResp resp)) trailing
  (_, _, _) -> DecodeFail failure
  where failure = CodecFailure ("unexpected server message: " ++ str)
 
@@ -106,7 +106,7 @@ codecReqRespId eqRespTypes = Codec { encode, decode }
 
  msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle
  -> Proxy resp
- msgRespType (MsgResp _ _) = Proxy
+ msgRespType (MsgResp _) = Proxy
 
  reqRespType :: forall resp. FileAPI resp -> Proxy resp
  reqRespType _ = Proxy

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs

@@ -30,7 +30,7 @@ reqRespServerPeer ReqRespServer { reqRespServerDone = a,
  MsgDone -> (Done a, StateDone)
  MsgReq req ->
  ( Effect $
- (\(resp, k') -> Yield StateIdle (MsgResp req resp) (reqRespServerPeer k'))
+ (\(resp, k') -> Yield (StateBusy req) StateIdle (MsgResp resp) (reqRespServerPeer k'))
  <$> k req
  , StateBusy req
  )

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Type.hs

@@ -54,12 +54,7 @@ instance Protocol (ReqResp req) where
  -- promoted to the state `StBusy` state.
  -> Message (ReqResp req) StIdle (StBusy resp)
  MsgResp :: Typeable resp
- => req resp -- ^ request, not sent over the wire, just useful in the
- -- codec.
- --
- -- TODO: https://github.com/input-output-hk/typed-protocols/issues/59
-
- -> resp -- ^ respond
+ => resp -- ^ respond
  -> Message (ReqResp req) (StBusy resp) StIdle
  MsgDone :: Message (ReqResp req) StIdle StDone
 

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

@@ -1,6 +1,6 @@
-cabal-version: 3.0
+cabal-version: 3.4
 name: typed-protocols-examples
-version: 0.4.0.0
+version: 0.5.0.0
 synopsis: Examples and tests for the typed-protocols framework
 -- description:
 license: Apache-2.0
@@ -63,7 +63,7 @@ library
  si-timers,
  network,
  time,
- typed-protocols ^>= 0.2,
+ typed-protocols ^>= 0.3,
  typed-protocols-cborg,
  typed-protocols-stateful
 

typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs

@@ -48,7 +48,7 @@ mkCodecCborStrictBS
  => (forall (st :: ps) (st' :: ps).
  StateTokenI st
  =>ActiveState st
- => f st' -> Message ps st st' -> CBOR.Encoding)
+ => f st -> Message ps st st' -> CBOR.Encoding)
  -- ^ cbor encoder
 
  -> (forall (st :: ps) s.
@@ -90,7 +90,7 @@ mkCodecCborLazyBS
  => (forall (st :: ps) (st' :: ps).
  StateTokenI st
  => ActiveState st
- => f st'
+ => f st
  -> Message ps st st' -> CBOR.Encoding)
  -- ^ cbor encoder
 

typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal

@@ -1,6 +1,6 @@
-cabal-version: 3.0
+cabal-version: 3.4
 name: typed-protocols-stateful-cborg
-version: 0.2.0.0
+version: 0.3.0.0
 synopsis: CBOR codecs for typed-protocols
 -- description:
 license: Apache-2.0
@@ -25,7 +25,7 @@ library
  singletons, 
 
  io-classes,
- typed-protocols,
+ typed-protocols ^>= 0.3,
  typed-protocols-cborg,
  typed-protocols-stateful
 

typed-protocols-stateful/src/Network/TypedProtocol/Stateful/Codec.hs

@@ -41,8 +41,8 @@ module Network.TypedProtocol.Stateful.Codec
  -- * CodecFailure
  , CodecFailure (..)
  -- * Testing codec properties
- , AnyMessage (..)
- , pattern AnyMessageAndAgency
+ , AnyMessage (.., AnyMessageAndAgency)
+ , showAnyMessage
  , prop_codecM
  , prop_codec
  , prop_codec_splitsM
@@ -59,7 +59,7 @@ import Network.TypedProtocol.Codec (CodecFailure (..),
  DecodeStep (..), SomeMessage (..), hoistDecodeStep,
  isoDecodeStep, mapFailureDecodeStep, runDecoder,
  runDecoderPure)
-import qualified Network.TypedProtocol.Codec as TP
+import qualified Network.TypedProtocol.Codec as TP hiding (AnyMessageAndAgency)
 
 
 -- | A stateful codec.
@@ -68,14 +68,23 @@ data Codec ps failure (f :: ps -> Type) m bytes = Codec {
  encode :: forall (st :: ps) (st' :: ps).
  StateTokenI st
  => ActiveState st
- => f st'
+ => f st
+ -- local state, which contain extra context for the encoding
+ -- process.
+ --
+ -- TODO: input-output-hk/typed-protocols#57
  -> Message ps st st'
+ -- message to be encoded
  -> bytes,
 
  decode :: forall (st :: ps).
  ActiveState st
  => StateToken st
  -> f st
+ -- local state, which can contain extra context from the
+ -- previous message.
+ --
+ -- TODO: input-output-hk/typed-protocols#57
  -> m (DecodeStep bytes failure m (SomeMessage st))
  }
 
@@ -130,22 +139,32 @@ data AnyMessage ps (f :: ps -> Type) where
  , ActiveState st
  )
  => f st
- -> f st'
+ -- ^ local state
  -> Message ps (st :: ps) (st' :: ps)
+ -- ^ protocol messsage
  -> AnyMessage ps f
 
-instance ( forall (st :: ps) (st' :: ps). Show (Message ps st st')
- , forall (st :: ps). Show (f st)
- )
- => Show (AnyMessage ps f) where
- show (AnyMessage st st' msg) = concat [ "AnyMessage "
- , show st
- , " "
- , show st'
- , " "
- , show msg
- ]
 
+-- | `showAnyMessage` is can be used to provide `Show` instance for
+-- `AnyMessage` if showing `Message` is independent of the state or one accepts
+-- showing only partial information included in message constructors or accepts
+-- message constructors to carry `Show` instances for its arguments. Note that
+-- the proper solution is to define a custom `Show (AnyMessage ps f)` instance
+-- for a protocol `ps`, which give access to the state functor `f` in scope of
+-- `show`.
+--
+showAnyMessage :: forall ps f.
+ ( forall st st'. Show (Message ps st st')
+ , forall st. Show (f st)
+ )
+ => AnyMessage ps f
+ -> String
+showAnyMessage (AnyMessage st msg) =
+ concat [ "AnyMessage "
+ , show st
+ , " "
+ , show msg
+ ]
 
 
 -- | A convenient pattern synonym which unwrap 'AnyMessage' giving both the
@@ -156,10 +175,9 @@ pattern AnyMessageAndAgency :: forall ps f. ()
  (StateTokenI st, ActiveState st)
  => StateToken st
  -> f st
- -> f st'
  -> Message ps st st'
  -> AnyMessage ps f
-pattern AnyMessageAndAgency stateToken f f' msg <- AnyMessage f f' (getAgency -> (msg, stateToken))
+pattern AnyMessageAndAgency stateToken f msg <- AnyMessage f (getAgency -> (msg, stateToken))
  where
  AnyMessageAndAgency _ msg = AnyMessage msg
 {-# COMPLETE AnyMessageAndAgency #-}
@@ -169,28 +187,29 @@ pattern AnyMessageAndAgency stateToken f f' msg <- AnyMessage f f' (getAgency ->
 getAgency :: StateTokenI st => Message ps st st' -> (Message ps st st', StateToken st)
 getAgency msg = (msg, stateToken)
 
+
 -- | The 'Codec' round-trip property: decode after encode gives the same
 -- message. Every codec must satisfy this property.
 --
 prop_codecM
  :: forall ps failure f m bytes.
  ( Monad m
- , Eq (TP.AnyMessage ps)
+ , Eq (AnyMessage ps f)
  )
  => Codec ps failure f m bytes
  -> AnyMessage ps f
  -> m Bool
-prop_codecM Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do
- r <- decode (stateToken :: StateToken st) f >>= runDecoder [encode f' msg]
+prop_codecM Codec {encode, decode} a@(AnyMessage f (msg :: Message ps st st')) = do
+ r <- decode (stateToken :: StateToken st) f >>= runDecoder [encode f msg]
  case r :: Either failure (SomeMessage st) of
- Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg
+ Right (SomeMessage msg') -> return $ AnyMessage f msg' == a
  Left _ -> return False
 
 -- | The 'Codec' round-trip property in a pure monad.
 --
 prop_codec
  :: forall ps failure f m bytes.
- (Monad m, Eq (TP.AnyMessage ps))
+ (Monad m, Eq (AnyMessage ps f))
  => (forall a. m a -> a)
  -> Codec ps failure f m bytes
  -> AnyMessage ps f
@@ -212,28 +231,28 @@ prop_codec runM codec msg =
 --
 prop_codec_splitsM
  :: forall ps failure f m bytes.
- (Monad m, Eq (TP.AnyMessage ps))
+ (Monad m, Eq (AnyMessage ps f))
  => (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form
  -> Codec ps failure f m bytes
  -> AnyMessage ps f
  -> m Bool
 prop_codec_splitsM splits
- Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do
+ Codec {encode, decode} a@(AnyMessage f (msg :: Message ps st st')) = do
  and <$> sequence
  [ do r <- decode (stateToken :: StateToken st) f >>= runDecoder bytes'
  case r :: Either failure (SomeMessage st) of
- Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg
+ Right (SomeMessage msg') -> return $ AnyMessage f msg' == a
  Left _ -> return False
 
- | let bytes = encode f' msg
+ | let bytes = encode f msg
  , bytes' <- splits bytes ]
 
 
 -- | Like @'prop_codec_splitsM'@ but run in a pure monad @m@, e.g. @Identity@.
 --
 prop_codec_splits
  :: forall ps failure f m bytes.
- (Monad m, Eq (TP.AnyMessage ps))
+ (Monad m, Eq (AnyMessage ps f))
  => (bytes -> [[bytes]])
  -> (forall a. m a -> a)
  -> Codec ps failure f m bytes
@@ -250,30 +269,30 @@ prop_codec_splits splits runM codec msg =
 prop_codecs_compatM
  :: forall ps failure f m bytes.
  ( Monad m
- , Eq (TP.AnyMessage ps)
+ , Eq (AnyMessage ps f)
  , forall a. Monoid a => Monoid (m a)
  )
  => Codec ps failure f m bytes
  -> Codec ps failure f m bytes
  -> AnyMessage ps f
  -> m Bool
 prop_codecs_compatM codecA codecB
- (AnyMessage f f' (msg :: Message ps st st')) =
- getAll <$> do r <- decode codecB (stateToken :: StateToken st) f >>= runDecoder [encode codecA f' msg]
+ a@(AnyMessage f (msg :: Message ps st st')) =
+ getAll <$> do r <- decode codecB (stateToken :: StateToken st) f >>= runDecoder [encode codecA f msg]
  case r :: Either failure (SomeMessage st) of
- Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg
+ Right (SomeMessage msg') -> return $ All $ AnyMessage f msg' == a
  Left _ -> return $ All False
- <> do r <- decode codecA (stateToken :: StateToken st) f >>= runDecoder [encode codecB f' msg]
+ <> do r <- decode codecA (stateToken :: StateToken st) f >>= runDecoder [encode codecB f msg]
  case r :: Either failure (SomeMessage st) of
- Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg
+ Right (SomeMessage msg') -> return $ All $ AnyMessage f msg' == a
  Left _ -> return $ All False
 
 -- | Like @'prop_codecs_compatM'@ but run in a pure monad @m@, e.g. @Identity@.
 --
 prop_codecs_compat
  :: forall ps failure f m bytes.
  ( Monad m
- , Eq (TP.AnyMessage ps)
+ , Eq (AnyMessage ps f)
  , forall a. Monoid a => Monoid (m a)
  )
  => (forall a. m a -> a)