From e0b22a2338f405bca9691ee4e4df358e14a68c1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 26 Sep 2025 14:37:24 +0200 Subject: [PATCH 1/2] Generalize splitsM property tests To improve code coverage of client libraries, additional parameters were added to the function such that real client runDecoder functions can be tested in addition to the previous codec tests. --- .../Network/TypedProtocol/Codec/Properties.hs | 129 ++++++++++++------ typed-protocols/typed-protocols.cabal | 1 + 2 files changed, 87 insertions(+), 43 deletions(-) diff --git a/typed-protocols/properties/Network/TypedProtocol/Codec/Properties.hs b/typed-protocols/properties/Network/TypedProtocol/Codec/Properties.hs index 9686dae..937c8af 100644 --- a/typed-protocols/properties/Network/TypedProtocol/Codec/Properties.hs +++ b/typed-protocols/properties/Network/TypedProtocol/Codec/Properties.hs @@ -33,6 +33,10 @@ module Network.TypedProtocol.Codec.Properties , SomeState (..) ) where +import Control.Monad.Class.MonadST +import Data.Maybe +import Data.STRef + import Network.TypedProtocol.Codec import Network.TypedProtocol.Core @@ -161,28 +165,40 @@ prop_anncodec = prop_codecF runAnnotator -- | A more general version of 'prop_codec_splitsM' for 'CodecF'. -- prop_codecF_splitsM - :: forall ps failure m f bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m annotator f bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , MonadST m ) - => (forall (st :: ps). f st -> bytes -> SomeMessage st) + => (forall (st :: ps). annotator st -> f (SomeMessage st)) + -> (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (f (SomeMessage st)) + -> m (Either failure (SomeMessage st))) -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form - -> CodecF ps failure m f bytes + -> CodecF ps failure m annotator bytes -> AnyMessage ps -> m Property -prop_codecF_splitsM runF splits +prop_codecF_splitsM conv mkChannel runDecoder' splits Codec {encode, decode} (AnyMessage (msg :: Message ps st st')) = do property . foldMap Every <$> sequence - [ do r <- decode stateToken >>= runDecoder bytes' - case r :: Either failure (f st) of - Right f -> case runF f (mconcat bytes') of - SomeMessage msg' -> - return $! AnyMessage msg' === AnyMessage msg - Left err -> return $ counterexample (show err) False + [ do + stateRef <- stToIO . newSTRef $ tail bytes' + let channelAction = stToIO $ do + chunksRemaining <- readSTRef stateRef + modifySTRef' stateRef (drop 1) + return $! listToMaybe chunksRemaining + channel = mkChannel channelAction + decoder <- decode @st stateToken + r <- runDecoder' channel (listToMaybe bytes') (conv <$> decoder) + case r of + Right (SomeMessage msg') -> + return $! AnyMessage msg' === AnyMessage msg + Left err -> return $ counterexample (show err) False | let bytes = encode msg , bytes' <- splits bytes ] @@ -200,31 +216,42 @@ prop_codecF_splitsM runF splits -- to be checked. -- prop_codec_splitsM - :: forall ps failure m bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m f bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , Applicative f + , MonadST m ) - => (bytes -> [[bytes]]) + => (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (f (SomeMessage st)) + -> m (Either failure (SomeMessage st))) + -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> Codec ps failure m bytes -> AnyMessage ps -> m Property -prop_codec_splitsM = prop_codecF_splitsM const +prop_codec_splitsM = prop_codecF_splitsM pure -- | A variant of 'prop_codec_splitsM' for 'AnnotatedCodec'. -- prop_anncodec_splitsM - :: forall ps failure m bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , MonadST m ) - => (bytes -> [[bytes]]) + => (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (bytes -> SomeMessage st) + -> m (Either failure (SomeMessage st))) + -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> AnnotatedCodec ps failure m bytes -> AnyMessage ps @@ -235,51 +262,67 @@ prop_anncodec_splitsM = prop_codecF_splitsM runAnnotator -- | A more general version of 'prop_codec_splits' for 'CodecF'. -- prop_codecF_splits - :: forall ps failure m f bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m annotator f bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , MonadST m ) - => (forall (st :: ps). f st -> bytes -> SomeMessage st) + => (forall (st :: ps). annotator st -> f (SomeMessage st)) + -> (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (f (SomeMessage st)) + -> m (Either failure (SomeMessage st))) -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> (forall a. m a -> a) - -> CodecF ps failure m f bytes + -> CodecF ps failure m annotator bytes -> AnyMessage ps -> Property -prop_codecF_splits runF splits runM codec msg = - runM $ prop_codecF_splitsM runF splits codec msg +prop_codecF_splits runF mkChannel runDecoder' splits runM codec msg = + runM $ prop_codecF_splitsM runF mkChannel runDecoder' splits codec msg -- | Like @'prop_codec_splitsM'@ but run in a pure monad @m@, e.g. @Identity@. -- prop_codec_splits - :: forall ps failure m bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m f bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , Applicative f + , MonadST m ) - => (bytes -> [[bytes]]) + => (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (f (SomeMessage st)) + -> m (Either failure (SomeMessage st))) + -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> (forall a. m a -> a) -> Codec ps failure m bytes -> AnyMessage ps -> Property -prop_codec_splits = prop_codecF_splits const +prop_codec_splits = prop_codecF_splits pure -- | Like 'prop_codec_splits' but for 'AnnotatorCodec'. prop_anncodec_splits - :: forall ps failure m bytes. - ( Monad m - , Eq (AnyMessage ps) + :: forall ps failure m bytes channel. + ( Eq (AnyMessage ps) , Show (AnyMessage ps) , Show failure - , Monoid bytes + , MonadST m ) - => (bytes -> [[bytes]]) + => (m (Maybe bytes) -> channel) + -> (forall (st :: ps). + channel + -> Maybe bytes + -> DecodeStep bytes failure m (bytes -> SomeMessage st) + -> m (Either failure (SomeMessage st))) + -> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form -> (forall a. m a -> a) -> AnnotatedCodec ps failure m bytes diff --git a/typed-protocols/typed-protocols.cabal b/typed-protocols/typed-protocols.cabal index 7171b53..e854b7d 100644 --- a/typed-protocols/typed-protocols.cabal +++ b/typed-protocols/typed-protocols.cabal @@ -55,6 +55,7 @@ library codec-properties exposed-modules: Network.TypedProtocol.Codec.Properties Network.TypedProtocol.Stateful.Codec.Properties build-depends: base >=4.12 && <4.22, + io-classes, typed-protocols:{stateful, typed-protocols}, QuickCheck >= 2.16 hs-source-dirs: properties From 32e16714670635e7e416c047b175aad5847c4131 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 30 Sep 2025 15:16:10 +0200 Subject: [PATCH 2/2] update changelog --- typed-protocols/CHANGELOG.md | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/typed-protocols/CHANGELOG.md b/typed-protocols/CHANGELOG.md index 6442966..b4cb25c 100644 --- a/typed-protocols/CHANGELOG.md +++ b/typed-protocols/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for typed-protocols +## next version + +### Breaking changes + +### Non-breaking changes + +* generalized prop_codecF_splitsM to run the decoder function provided by a client + library (instead of `runDecoder` here) to test it as well. + ## 1.1.0.0 -- 05.08.2025 ### Breaking changes @@ -55,4 +64,4 @@ * Support `ghc-9.6.1`. * Use `io-classes-1.1.0.0`. -[singletons-3.0.1]: https://hackage.haskell.org/package/singletons +[singletons-3.0.1]: https://hackage.haskell.org/package/singletons