Skip to content

Commit 589360e

Browse files
cootcoot
committed
protocols: use LambdaCase & BlockArguments
1 parent 47e25d0 commit 589360e

File tree

13 files changed

+143
-130
lines changed

13 files changed

+143
-130
lines changed

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Client.hs

Lines changed: 37 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE GADTs #-}
5+
{-# LANGUAGE LambdaCase #-}
46
{-# LANGUAGE NamedFieldPuns #-}
57
{-# LANGUAGE PolyKinds #-}
68
{-# LANGUAGE ScopedTypeVariables #-}
@@ -54,40 +56,40 @@ blockFetchClientPeer
5456
=> BlockFetchClient block point m a
5557
-> Client (BlockFetch block point) NonPipelined BFIdle m a
5658
blockFetchClientPeer (BlockFetchClient mclient) =
57-
Effect $ blockFetchRequestPeer <$> mclient
59+
Effect $ blockFetchRequestPeer <$> mclient
5860
where
59-
blockFetchRequestPeer
60-
:: BlockFetchRequest block point m a
61-
-> Client (BlockFetch block point) NonPipelined BFIdle m a
62-
63-
blockFetchRequestPeer (SendMsgClientDone result) =
64-
Yield MsgClientDone (Done result)
65-
66-
blockFetchRequestPeer (SendMsgRequestRange range resp next) =
67-
Yield
68-
(MsgRequestRange range)
69-
(blockFetchResponsePeer next resp)
70-
71-
72-
blockFetchResponsePeer
73-
:: BlockFetchClient block point m a
74-
-> BlockFetchResponse block m a
75-
-> Client (BlockFetch block point) NonPipelined BFBusy m a
76-
blockFetchResponsePeer next BlockFetchResponse{handleNoBlocks, handleStartBatch} =
77-
Await $ \msg -> case msg of
78-
MsgStartBatch -> Effect $ blockReceiver next <$> handleStartBatch
79-
MsgNoBlocks -> Effect $ handleNoBlocks >> (blockFetchRequestPeer <$> runBlockFetchClient next)
80-
81-
blockReceiver
82-
:: BlockFetchClient block point m a
83-
-> BlockFetchReceiver block m
84-
-> Client (BlockFetch block point) NonPipelined BFStreaming m a
85-
blockReceiver next BlockFetchReceiver{handleBlock, handleBatchDone} =
86-
Await $ \msg -> case msg of
87-
MsgBlock block -> Effect $ blockReceiver next <$> handleBlock block
88-
MsgBatchDone -> Effect $ do
89-
handleBatchDone
90-
blockFetchRequestPeer <$> runBlockFetchClient next
61+
blockFetchRequestPeer
62+
:: BlockFetchRequest block point m a
63+
-> Client (BlockFetch block point) NonPipelined BFIdle m a
64+
65+
blockFetchRequestPeer (SendMsgClientDone result) =
66+
Yield MsgClientDone (Done result)
67+
68+
blockFetchRequestPeer (SendMsgRequestRange range resp next) =
69+
Yield
70+
(MsgRequestRange range)
71+
(blockFetchResponsePeer next resp)
72+
73+
74+
blockFetchResponsePeer
75+
:: BlockFetchClient block point m a
76+
-> BlockFetchResponse block m a
77+
-> Client (BlockFetch block point) NonPipelined BFBusy m a
78+
blockFetchResponsePeer next BlockFetchResponse{handleNoBlocks, handleStartBatch} =
79+
Await \case
80+
MsgStartBatch -> Effect $ blockReceiver next <$> handleStartBatch
81+
MsgNoBlocks -> Effect $ handleNoBlocks >> (blockFetchRequestPeer <$> runBlockFetchClient next)
82+
83+
blockReceiver
84+
:: BlockFetchClient block point m a
85+
-> BlockFetchReceiver block m
86+
-> Client (BlockFetch block point) NonPipelined BFStreaming m a
87+
blockReceiver next BlockFetchReceiver{handleBlock, handleBatchDone} =
88+
Await \case
89+
MsgBlock block -> Effect $ blockReceiver next <$> handleBlock block
90+
MsgBatchDone -> Effect do
91+
handleBatchDone
92+
blockFetchRequestPeer <$> runBlockFetchClient next
9193

9294
--
9395
-- Pipelined client
@@ -152,15 +154,15 @@ blockFetchClientPeerSender (SendMsgRequestRangePipelined range c0 receive next)
152154
-- consume a stream of blocks.
153155
YieldPipelined
154156
(MsgRequestRange range)
155-
(ReceiverAwait $ \msg -> case msg of
157+
(ReceiverAwait \case
156158
MsgStartBatch -> receiveBlocks c0
157159
MsgNoBlocks -> ReceiverDone c0)
158160
(blockFetchClientPeerSender next)
159161
where
160162
receiveBlocks
161163
:: c
162164
-> Receiver (BlockFetch block point) BFStreaming BFIdle m c
163-
receiveBlocks c = ReceiverAwait $ \msg -> case msg of
165+
receiveBlocks c = ReceiverAwait \case
164166
-- received a block, run an acction and compute the result
165167
MsgBlock block -> ReceiverEffect $ do
166168
c' <- receive (Just block) c

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Server.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
35
{-# LANGUAGE ScopedTypeVariables #-}
46

57
module Ouroboros.Network.Protocol.BlockFetch.Server where
@@ -53,7 +55,7 @@ blockFetchServerPeer
5355
=> BlockFetchServer block point m a
5456
-> Server (BlockFetch block point) NonPipelined BFIdle m a
5557
blockFetchServerPeer (BlockFetchServer requestHandler result) =
56-
Await $ \msg -> case msg of
58+
Await \case
5759
MsgRequestRange range -> Effect $ sendBatch <$> requestHandler range
5860
MsgClientDone -> Done result
5961
where

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Client.hs

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
35
{-# LANGUAGE NamedFieldPuns #-}
46
{-# LANGUAGE ScopedTypeVariables #-}
57

@@ -196,23 +198,21 @@ chainSyncClientPeer (ChainSyncClient mclient) =
196198
-- This code could be factored more easily by changing the protocol type
197199
-- to put both roll forward and back under a single constructor.
198200
MsgAwaitReply ->
199-
Effect $ do
201+
Effect do
200202
stAwait
201-
pure $ Await $ \resp' ->
202-
case resp' of
203-
MsgRollForward header tip ->
204-
chainSyncClientPeer (recvMsgRollForward header tip)
205-
where
206-
ClientStNext{recvMsgRollForward} = stNext
207-
MsgRollBackward pRollback tip ->
208-
chainSyncClientPeer (recvMsgRollBackward pRollback tip)
209-
where
210-
ClientStNext{recvMsgRollBackward} = stNext
203+
pure $ Await \case
204+
MsgRollForward header tip ->
205+
chainSyncClientPeer (recvMsgRollForward header tip)
206+
where
207+
ClientStNext{recvMsgRollForward} = stNext
208+
MsgRollBackward pRollback tip ->
209+
chainSyncClientPeer (recvMsgRollBackward pRollback tip)
210+
where
211+
ClientStNext{recvMsgRollBackward} = stNext
211212

212213
chainSyncClientPeer_ (SendMsgFindIntersect points stIntersect) =
213214
Yield (MsgFindIntersect points) $
214-
Await $ \resp ->
215-
case resp of
215+
Await \case
216216
MsgIntersectFound pIntersect tip ->
217217
chainSyncClientPeer (recvMsgIntersectFound pIntersect tip)
218218

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/ClientPipelined.hs

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE CPP #-}
23
{-# LANGUAGE DataKinds #-}
34
{-# LANGUAGE GADTs #-}
@@ -202,8 +203,8 @@ chainSyncClientPeerSender
202203
chainSyncClientPeerSender n@Zero (SendMsgRequestNext stAwait stNext) =
203204

204205
Yield
205-
MsgRequestNext
206-
(Await $ \case
206+
MsgRequestNext $
207+
Await \case
207208
MsgRollForward header tip -> Effect $
208209
chainSyncClientPeerSender n
209210
<$> recvMsgRollForward header tip
@@ -216,9 +217,9 @@ chainSyncClientPeerSender n@Zero (SendMsgRequestNext stAwait stNext) =
216217
where
217218
ClientStNext {recvMsgRollBackward} = stNext
218219

219-
MsgAwaitReply -> Effect $ do
220+
MsgAwaitReply -> Effect do
220221
stAwait
221-
pure $ Await $ \case
222+
pure $ Await \case
222223
MsgRollForward header tip -> Effect $
223224
chainSyncClientPeerSender n
224225
<$> recvMsgRollForward header tip
@@ -229,7 +230,7 @@ chainSyncClientPeerSender n@Zero (SendMsgRequestNext stAwait stNext) =
229230
chainSyncClientPeerSender n
230231
<$> recvMsgRollBackward pRollback tip
231232
where
232-
ClientStNext {recvMsgRollBackward} = stNext)
233+
ClientStNext {recvMsgRollBackward} = stNext
233234

234235

235236
chainSyncClientPeerSender n (SendMsgRequestNextPipelined await next) =
@@ -239,15 +240,15 @@ chainSyncClientPeerSender n (SendMsgRequestNextPipelined await next) =
239240
MsgRequestNext
240241
(ReceiverAwait
241242
-- await for the reply
242-
$ \case
243+
\case
243244
MsgRollForward header tip -> ReceiverDone (RollForward header tip)
244245
MsgRollBackward pRollback tip -> ReceiverDone (RollBackward pRollback tip)
245246

246247
-- we need to wait for the next message; this time it must come with
247248
-- an instruction
248-
MsgAwaitReply -> ReceiverEffect $ do
249+
MsgAwaitReply -> ReceiverEffect do
249250
await
250-
pure $ ReceiverAwait $ \case
251+
pure $ ReceiverAwait \case
251252
MsgRollForward header tip -> ReceiverDone (RollForward header tip)
252253
MsgRollBackward pRollback tip -> ReceiverDone (RollBackward pRollback tip))
253254

@@ -264,7 +265,7 @@ chainSyncClientPeerSender n (SendMsgFindIntersect points
264265
(MsgFindIntersect points)
265266
(Await
266267
-- await for the response and recurse
267-
$ \case
268+
\case
268269
MsgIntersectFound pIntersect tip -> Effect $
269270
chainSyncClientPeerSender n <$> recvMsgIntersectFound pIntersect tip
270271
MsgIntersectNotFound tip -> Effect $

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/KeepAlive/Server.hs

Lines changed: 11 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
35
{-# LANGUAGE NamedFieldPuns #-}
46

57
module Ouroboros.Network.Protocol.KeepAlive.Server
@@ -24,13 +26,12 @@ keepAliveServerPeer
2426
=> KeepAliveServer m a
2527
-> Server KeepAlive NonPipelined StClient m a
2628
keepAliveServerPeer KeepAliveServer { recvMsgKeepAlive, recvMsgDone } =
27-
Await $ \msg ->
28-
case msg of
29-
MsgDone -> Effect $ Done <$> recvMsgDone
30-
31-
MsgKeepAlive cookie ->
32-
Effect $
33-
fmap (\server ->
34-
Yield (MsgKeepAliveResponse cookie)
35-
(keepAliveServerPeer server))
36-
recvMsgKeepAlive
29+
Await \case
30+
MsgDone -> Effect $ Done <$> recvMsgDone
31+
32+
MsgKeepAlive cookie ->
33+
Effect $
34+
fmap (\server ->
35+
Yield (MsgKeepAliveResponse cookie)
36+
(keepAliveServerPeer server))
37+
recvMsgKeepAlive

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,7 @@ data ClientStAcquired block point query m a where
8484
--
8585
-- * a result
8686
--
87-
data ClientStQuerying block point query m a result = ClientStQuerying {
87+
newtype ClientStQuerying block point query m a result = ClientStQuerying {
8888
recvMsgResult :: result -> m (ClientStAcquired block point query m a)
8989
}
9090

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Client.hs

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE LambdaCase #-}
@@ -126,7 +127,7 @@ localTxMonitorClientPeer (LocalTxMonitorClient mClient) =
126127
handleStIdle = \case
127128
SendMsgAcquire stAcquired ->
128129
Yield MsgAcquire $
129-
Await $ \case
130+
Await \case
130131
MsgAcquired slot -> Effect $ handleStAcquired <$> stAcquired slot
131132
SendMsgDone a ->
132133
Yield MsgDone (Done a)
@@ -137,27 +138,27 @@ localTxMonitorClientPeer (LocalTxMonitorClient mClient) =
137138
handleStAcquired = \case
138139
SendMsgNextTx stAcquired ->
139140
Yield MsgNextTx $
140-
Await $ \case
141+
Await \case
141142
MsgReplyNextTx tx ->
142143
Effect $ handleStAcquired <$> stAcquired tx
143144
SendMsgHasTx txid stAcquired ->
144145
Yield (MsgHasTx txid) $
145-
Await $ \case
146+
Await \case
146147
MsgReplyHasTx res ->
147148
Effect $ handleStAcquired <$> stAcquired res
148149
SendMsgGetSizes stAcquired ->
149150
Yield MsgGetSizes $
150-
Await $ \case
151+
Await \case
151152
MsgReplyGetSizes sizes ->
152153
Effect $ handleStAcquired <$> stAcquired sizes
153154
SendMsgGetMeasures stAcquired ->
154155
Yield MsgGetMeasures $
155-
Await $ \case
156+
Await \case
156157
MsgReplyGetMeasures measures ->
157158
Effect $ handleStAcquired <$> stAcquired measures
158159
SendMsgAwaitAcquire stAcquired ->
159160
Yield MsgAwaitAcquire $
160-
Await $ \case
161+
Await \case
161162
MsgAcquired slot ->
162163
Effect $ handleStAcquired <$> stAcquired slot
163164
SendMsgRelease stIdle ->

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxMonitor/Server.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE KindSignatures #-}
@@ -118,7 +119,7 @@ localTxMonitorServerPeer (LocalTxMonitorServer mServer) =
118119
-> Server (LocalTxMonitor txid tx slot) NonPipelined StIdle m a
119120
handleStIdle = \case
120121
ServerStIdle{recvMsgDone, recvMsgAcquire} ->
121-
Await $ \case
122+
Await \case
122123
MsgAcquire ->
123124
Effect $ handleStAcquiring <$> recvMsgAcquire
124125
MsgDone ->
@@ -143,7 +144,7 @@ localTxMonitorServerPeer (LocalTxMonitorServer mServer) =
143144
, recvMsgGetMeasures
144145
, recvMsgAwaitAcquire
145146
, recvMsgRelease
146-
} -> Await $ \case
147+
} -> Await \case
147148
MsgNextTx ->
148149
Effect $ handleNextTx <$> recvMsgNextTx
149150
MsgHasTx txid ->

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Client.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
35
{-# LANGUAGE RankNTypes #-}
46
{-# LANGUAGE ScopedTypeVariables #-}
57

@@ -96,7 +98,7 @@ localTxSubmissionClientPeer (LocalTxSubmissionClient client) =
9698
-> Client (LocalTxSubmission tx reject) NonPipelined StIdle m a
9799
go (SendMsgSubmitTx tx k) =
98100
Yield (MsgSubmitTx tx) $
99-
Await $ \msg -> case msg of
101+
Await \case
100102
MsgAcceptTx -> Effect (go <$> k SubmitSuccess)
101103
MsgRejectTx reject -> Effect (go <$> k (SubmitFail reject))
102104

‎ouroboros-network-protocols/src/Ouroboros/Network/Protocol/LocalTxSubmission/Server.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
35
{-# LANGUAGE KindSignatures #-}
46
{-# LANGUAGE NamedFieldPuns #-}
57
{-# LANGUAGE ScopedTypeVariables #-}
@@ -61,8 +63,8 @@ localTxSubmissionServerPeer server =
6163
go :: LocalTxSubmissionServer tx reject m a
6264
-> Server (LocalTxSubmission tx reject) NonPipelined StIdle m a
6365
go LocalTxSubmissionServer{recvMsgSubmitTx, recvMsgDone} =
64-
Await $ \msg -> case msg of
65-
MsgSubmitTx tx -> Effect $ do
66+
Await \case
67+
MsgSubmitTx tx -> Effect do
6668
(result, k) <- recvMsgSubmitTx tx
6769
return $
6870
case result of

0 commit comments

Comments
 (0)