Skip to content

Commit b85197b

Browse files
cootcoot
authored
Merge pull request #79 from input-output-hk/coot/nr
coot/nr
2 parents e29a215 + 3cbc137 commit b85197b

File tree

9 files changed

+109
-22
lines changed

9 files changed

+109
-22
lines changed

‎typed-protocols-doc/typed-protocols-doc.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ library
5454
, th-abstraction >=0.6.0.0 && <0.8
5555
, time >=1.12 && <1.14
5656
, serdoc-core
57-
, typed-protocols ^>= 1.0 || ^>= 1.1
57+
, typed-protocols ^>= 1.0 || ^>= 1.1 || ^>= 1.2
5858
hs-source-dirs: src
5959
default-language: GHC2021
6060
default-extensions: DataKinds

‎typed-protocols/CHANGELOG.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,10 @@
11
# Revision history for typed-protocols
22

3+
## 1.2.0.0 -- 2025-02-05
4+
5+
* Make `runPeerWithDriver` strict, it evaluates the result and `dstate` to
6+
normal form.
7+
38
## 1.1.0.1 -- 2025-10-14
49

510
* Support QuickCheck <= 2.15

‎typed-protocols/examples/Network/TypedProtocol/Driver/Simple.hs‎

Lines changed: 44 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Network.TypedProtocol.Core
3030
import Network.TypedProtocol.Driver
3131
import Network.TypedProtocol.Peer
3232

33+
import Control.DeepSeq (NFData, force)
3334
import Control.Monad.Class.MonadAsync
3435
import Control.Monad.Class.MonadThrow
3536
import Control.Tracer (Tracer (..), contramap, traceWith)
@@ -72,7 +73,11 @@ instance Show (AnyMessage ps) => Show (TraceSendRecv ps) where
7273

7374

7475
driverSimple :: forall ps pr failure bytes m.
75-
(MonadThrow m, Exception failure)
76+
( MonadEvaluate m
77+
, MonadThrow m
78+
, Exception failure
79+
, NFData failure
80+
)
7681
=> Tracer m (TraceSendRecv ps)
7782
-> Codec ps failure m bytes
7883
-> Channel m bytes
@@ -119,7 +124,12 @@ driverSimple tracer Codec{encode, decode} channel@Channel{send} =
119124
--
120125
runPeer
121126
:: forall ps (st :: ps) pr failure bytes m a.
122-
(MonadThrow m, Exception failure)
127+
( MonadEvaluate m
128+
, MonadThrow m
129+
, Exception failure
130+
, NFData failure
131+
, NFData a
132+
)
123133
=> Tracer m (TraceSendRecv ps)
124134
-> Codec ps failure m bytes
125135
-> Channel m bytes
@@ -140,7 +150,13 @@ runPeer tracer codec channel peer =
140150
--
141151
runPipelinedPeer
142152
:: forall ps (st :: ps) pr failure bytes m a.
143-
(MonadAsync m, MonadThrow m, Exception failure)
153+
( MonadAsync m
154+
, MonadEvaluate m
155+
, MonadThrow m
156+
, Exception failure
157+
, NFData failure
158+
, NFData a
159+
)
144160
=> Tracer m (TraceSendRecv ps)
145161
-> Codec ps failure m bytes
146162
-> Channel m bytes
@@ -159,7 +175,10 @@ runPipelinedPeer tracer codec channel peer =
159175
-- | Run a codec incremental decoder 'DecodeStep' against a channel. It also
160176
-- takes any extra input data and returns any unused trailing data.
161177
--
162-
runDecoderWithChannel :: Monad m
178+
runDecoderWithChannel :: ( Monad m
179+
, MonadEvaluate m
180+
, NFData failure
181+
)
163182
=> Channel m bytes
164183
-> Maybe bytes
165184
-> DecodeStep bytes failure m a
@@ -168,7 +187,7 @@ runDecoderWithChannel :: Monad m
168187
runDecoderWithChannel Channel{recv} = go
169188
where
170189
go _ (DecodeDone x trailing) = return (Right (x, trailing))
171-
go _ (DecodeFail failure) = return (Left failure)
190+
go _ (DecodeFail failure) = Left <$> evaluate (force failure)
172191
go Nothing (DecodePartial k) = recv >>= k >>= go Nothing
173192
go (Just trailing) (DecodePartial k) = k (Just trailing) >>= go Nothing
174193

@@ -183,8 +202,14 @@ data Role = Client | Server
183202
-- The first argument is expected to create two channels that are connected,
184203
-- for example 'createConnectedChannels'.
185204
--
186-
runConnectedPeers :: (MonadAsync m, MonadCatch m,
187-
Exception failure)
205+
runConnectedPeers :: ( MonadAsync m
206+
, MonadCatch m
207+
, MonadEvaluate m
208+
, Exception failure
209+
, NFData failure
210+
, NFData a
211+
, NFData b
212+
)
188213
=> m (Channel m bytes, Channel m bytes)
189214
-> Tracer m (Role, TraceSendRecv ps)
190215
-> Codec ps failure m bytes
@@ -201,8 +226,14 @@ runConnectedPeers createChannels tracer codec client server =
201226
tracerClient = contramap ((,) Client) tracer
202227
tracerServer = contramap ((,) Server) tracer
203228

204-
runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m,
205-
Exception failure)
229+
runConnectedPeersPipelined :: ( MonadAsync m
230+
, MonadCatch m
231+
, MonadEvaluate m
232+
, Exception failure
233+
, NFData failure
234+
, NFData a
235+
, NFData b
236+
)
206237
=> m (Channel m bytes, Channel m bytes)
207238
-> Tracer m (PeerRole, TraceSendRecv ps)
208239
-> Codec ps failure m bytes
@@ -225,8 +256,12 @@ runConnectedPeersPipelined createChannels tracer codec client server =
225256
--
226257
runConnectedPeersAsymmetric
227258
:: ( MonadAsync m
259+
, MonadEvaluate m
228260
, MonadMask m
229261
, Exception failure
262+
, NFData failure
263+
, NFData a
264+
, NFData b
230265
)
231266
=> m (Channel m bytes, Channel m bytes)
232267
-> Tracer m (Role, TraceSendRecv ps)

‎typed-protocols/src/Network/TypedProtocol/Codec.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ module Network.TypedProtocol.Codec
4747
, SomeState (..)
4848
) where
4949

50+
import Control.DeepSeq (NFData (..))
5051
import Control.Exception (Exception)
5152
import Data.Kind (Type)
5253

@@ -316,6 +317,10 @@ data CodecFailure = CodecFailureOutOfInput
316317
| CodecFailure String
317318
deriving (Eq, Show)
318319

320+
instance NFData CodecFailure where
321+
rnf CodecFailureOutOfInput = ()
322+
rnf (CodecFailure failure) = rnf failure
323+
319324
-- safe instance with @UndecidableInstances@ in scope
320325
instance Exception CodecFailure
321326

‎typed-protocols/src/Network/TypedProtocol/Driver.hs‎

Lines changed: 23 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -20,9 +20,11 @@ import Network.TypedProtocol.Core
2020
import Network.TypedProtocol.Peer
2121

2222
import Control.Concurrent.Class.MonadSTM.TQueue
23+
import Control.DeepSeq (NFData, force)
2324
import Control.Monad.Class.MonadAsync
2425
import Control.Monad.Class.MonadFork
2526
import Control.Monad.Class.MonadSTM
27+
import Control.Monad.Class.MonadThrow
2628

2729

2830
-- $intro
@@ -114,9 +116,18 @@ data SomeMessage (st :: ps) where
114116
--
115117
-- This runs the peer to completion (if the protocol allows for termination).
116118
--
119+
-- The returned value `a` is evaluated to normal form, any pure exceptions will
120+
-- be raised by `runPeerWithDriver`.
121+
--
122+
-- The returned `dstate` should be fed back into `runPeerWithDriver`, where it
123+
-- will be evaluated incrementally.
124+
--
117125
runPeerWithDriver
118126
:: forall ps (st :: ps) pr dstate m a.
119-
Monad m
127+
( Monad m
128+
, MonadEvaluate m
129+
, NFData a
130+
)
120131
=> Driver ps pr dstate m
121132
-> Peer ps pr NonPipelined st m a
122133
-> m (a, dstate)
@@ -128,7 +139,9 @@ runPeerWithDriver Driver{sendMessage, recvMessage, initialDState} =
128139
-> Peer ps pr 'NonPipelined st' m a
129140
-> m (a, dstate)
130141
go dstate (Effect k) = k >>= go dstate
131-
go dstate (Done _ x) = return (x, dstate)
142+
go dstate (Done _ x) = do
143+
x' <- evaluate (force x)
144+
return (x', dstate)
132145

133146
go dstate (Yield refl msg k) = do
134147
sendMessage refl msg
@@ -165,18 +178,23 @@ runPeerWithDriver Driver{sendMessage, recvMessage, initialDState} =
165178
--
166179
runPipelinedPeerWithDriver
167180
:: forall ps (st :: ps) pr dstate m a.
168-
MonadAsync m
181+
( MonadAsync m
182+
, MonadEvaluate m
183+
, NFData a
184+
)
169185
=> Driver ps pr dstate m
170186
-> PeerPipelined ps pr st m a
171187
-> m (a, dstate)
172188
runPipelinedPeerWithDriver driver@Driver{initialDState} (PeerPipelined peer) = do
173189
receiveQueue <- atomically newTQueue
174190
collectQueue <- atomically newTQueue
175-
a <- runPipelinedPeerReceiverQueue receiveQueue collectQueue driver
191+
r@(a, _dstate) <- runPipelinedPeerReceiverQueue receiveQueue collectQueue driver
176192
`withAsyncLoop`
177193
runPipelinedPeerSender receiveQueue collectQueue driver
178194
peer initialDState
179-
return a
195+
196+
_ <- evaluate (force a)
197+
return r
180198

181199
where
182200
withAsyncLoop :: m Void -> m x -> m x

‎typed-protocols/stateful/Network/TypedProtocol/Stateful/Driver.hs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,9 @@ module Network.TypedProtocol.Stateful.Driver
1111
, DecodeStep (..)
1212
) where
1313

14+
import Control.DeepSeq (NFData, force)
1415
import Control.Monad.Class.MonadSTM
16+
import Control.Monad.Class.MonadThrow
1517

1618
import Data.Kind (Type)
1719

@@ -82,7 +84,10 @@ data Driver ps (pr :: PeerRole) bytes failure dstate f m =
8284
--
8385
runPeerWithDriver
8486
:: forall ps (st :: ps) pr bytes failure dstate (f :: ps -> Type) m a.
85-
MonadSTM m
87+
( MonadEvaluate m
88+
, MonadSTM m
89+
, NFData a
90+
)
8691
=> Driver ps pr bytes failure dstate f m
8792
-> f st
8893
-> Peer ps pr st f m a
@@ -100,7 +105,9 @@ runPeerWithDriver Driver{ sendMessage
100105
-> m (a, dstate)
101106
go !dstate !f (Effect k) = k >>= go dstate f
102107

103-
go !dstate _ (Done _ x) = return (x, dstate)
108+
go !dstate _ (Done _ x) = do
109+
x' <- evaluate (force x)
110+
return (x', dstate)
104111

105112
go !dstate _ (Yield refl !f !f' msg k) = do
106113
sendMessage refl f msg

‎typed-protocols/test/Network/TypedProtocol/PingPong/Tests.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -290,7 +290,12 @@ prop_connect_pipelined5 choices (Positive omax) (NonNegative n) =
290290

291291
-- | Run a non-pipelined client and server over a channel using a codec.
292292
--
293-
prop_channel :: (MonadLabelledSTM m, MonadTraceSTM m, MonadAsync m, MonadCatch m)
293+
prop_channel :: ( MonadLabelledSTM m
294+
, MonadTraceSTM m
295+
, MonadAsync m
296+
, MonadCatch m
297+
, MonadEvaluate m
298+
)
294299
=> NonNegative Int
295300
-> m Bool
296301
prop_channel (NonNegative n) = do

‎typed-protocols/test/Network/TypedProtocol/ReqResp/Tests.hs‎

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -172,7 +172,12 @@ prop_connectPipelined cs f xs =
172172
-- Properties using channels, codecs and drivers.
173173
--
174174

175-
prop_channel :: (MonadLabelledSTM m, MonadTraceSTM m, MonadAsync m, MonadCatch m)
175+
prop_channel :: ( MonadLabelledSTM m
176+
, MonadTraceSTM m
177+
, MonadAsync m
178+
, MonadCatch m
179+
, MonadEvaluate m
180+
)
176181
=> (Int -> Int -> (Int, Int)) -> [Int]
177182
-> m Bool
178183
prop_channel f xs = do
@@ -195,8 +200,12 @@ prop_channel_ST f xs =
195200
runSimOrThrow (prop_channel f xs)
196201

197202

198-
prop_channelPipelined :: ( MonadLabelledSTM m, MonadAsync m, MonadCatch m
199-
, MonadST m)
203+
prop_channelPipelined :: ( MonadLabelledSTM m
204+
, MonadAsync m
205+
, MonadCatch m
206+
, MonadEvaluate m
207+
, MonadST m
208+
)
200209
=> (Int -> Int -> (Int, Int)) -> [Int]
201210
-> m Bool
202211
prop_channelPipelined f xs = do

‎typed-protocols/typed-protocols.cabal‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 3.4
22
name: typed-protocols
3-
version: 1.1.0.1
3+
version: 1.2.0.0
44
synopsis: A framework for strongly typed protocols
55
description: A robust session type framework which supports protocol pipelining.
66
Haddocks are published [here](https://input-output-hk.github.io/typed-protocols/)
@@ -43,6 +43,7 @@ library
4343
, Network.TypedProtocol.Proofs
4444
other-modules: Network.TypedProtocol.Lemmas
4545
build-depends: base >=4.12 && <4.22,
46+
deepseq,
4647
io-classes:io-classes ^>= 1.8,
4748
singletons ^>= 3.0
4849
hs-source-dirs: src
@@ -84,6 +85,7 @@ library stateful
8485
, Network.TypedProtocol.Stateful.Proofs
8586
, Network.TypedProtocol.Stateful.Codec
8687
build-depends: base,
88+
deepseq,
8789
singletons,
8890
io-classes:io-classes,
8991
typed-protocols:typed-protocols
@@ -139,6 +141,7 @@ library examples
139141
build-depends: base,
140142
bytestring,
141143
cborg,
144+
deepseq,
142145
serialise,
143146
singletons,
144147
contra-tracer,

0 commit comments

Comments
 (0)