Skip to content

Commit 83395a5

Browse files
cootcoot
committed
protocols: use LambdaCase & BlockArguments
1 parent 47e25d0 commit 83395a5

File tree

13 files changed

+104
-92
lines changed

13 files changed

+104
-92
lines changed

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

Lines changed: 5 additions & 3 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 #-}
@@ -74,7 +76,7 @@ blockFetchClientPeer (BlockFetchClient mclient) =
7476
-> BlockFetchResponse block m a
7577
-> Client (BlockFetch block point) NonPipelined BFBusy m a
7678
blockFetchResponsePeer next BlockFetchResponse{handleNoBlocks, handleStartBatch} =
77-
Await $ \msg -> case msg of
79+
Await \case
7880
MsgStartBatch -> Effect $ blockReceiver next <$> handleStartBatch
7981
MsgNoBlocks -> Effect $ handleNoBlocks >> (blockFetchRequestPeer <$> runBlockFetchClient next)
8082

@@ -83,7 +85,7 @@ blockFetchClientPeer (BlockFetchClient mclient) =
8385
-> BlockFetchReceiver block m
8486
-> Client (BlockFetch block point) NonPipelined BFStreaming m a
8587
blockReceiver next BlockFetchReceiver{handleBlock, handleBatchDone} =
86-
Await $ \msg -> case msg of
88+
Await \case
8789
MsgBlock block -> Effect $ blockReceiver next <$> handleBlock block
8890
MsgBatchDone -> Effect $ do
8991
handleBatchDone
@@ -160,7 +162,7 @@ blockFetchClientPeerSender (SendMsgRequestRangePipelined range c0 receive next)
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: 11 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE NamedFieldPuns #-}
45
{-# LANGUAGE ScopedTypeVariables #-}
56

@@ -198,21 +199,19 @@ chainSyncClientPeer (ChainSyncClient mclient) =
198199
MsgAwaitReply ->
199200
Effect $ do
200201
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
202+
pure $ Await $ \case
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
211211

212212
chainSyncClientPeer_ (SendMsgFindIntersect points stIntersect) =
213213
Yield (MsgFindIntersect points) $
214-
Await $ \resp ->
215-
case resp of
214+
Await $ \case
216215
MsgIntersectFound pIntersect tip ->
217216
chainSyncClientPeer (recvMsgIntersectFound pIntersect tip)
218217

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

Lines changed: 6 additions & 5 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 #-}
@@ -203,7 +204,7 @@ chainSyncClientPeerSender n@Zero (SendMsgRequestNext stAwait stNext) =
203204

204205
Yield
205206
MsgRequestNext
206-
(Await $ \case
207+
(Await \case
207208
MsgRollForward header tip -> Effect $
208209
chainSyncClientPeerSender n
209210
<$> recvMsgRollForward header tip
@@ -218,7 +219,7 @@ chainSyncClientPeerSender n@Zero (SendMsgRequestNext stAwait stNext) =
218219

219220
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
@@ -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
248249
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: 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 KindSignatures #-}
46
{-# LANGUAGE NamedFieldPuns #-}
57
{-# LANGUAGE ScopedTypeVariables #-}
@@ -61,7 +63,7 @@ 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
66+
Await \case
6567
MsgSubmitTx tx -> Effect $ do
6668
(result, k) <- recvMsgSubmitTx tx
6769
return $

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

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

57
module Ouroboros.Network.Protocol.PeerSharing.Server where
68

79
import Network.TypedProtocol.Peer.Server
810
import Ouroboros.Network.Protocol.PeerSharing.Type
911

10-
data PeerSharingServer peerAddress m = PeerSharingServer {
12+
newtype PeerSharingServer peerAddress m = PeerSharingServer {
1113
-- | The client sent us a 'MsgShareRequest'. We have need to compute the
1214
-- response.
1315
--
@@ -22,14 +24,13 @@ peerSharingServerPeer :: Monad m
2224
-> Server (PeerSharing peerAddress) NonPipelined StIdle m ()
2325
peerSharingServerPeer PeerSharingServer{..} =
2426
-- Await to receive a message
25-
Await $ \msg ->
27+
Await \case
2628
-- Can be either 'MsgShareRequest' or 'MsgDone'
27-
case msg of
29+
MsgShareRequest amount -> Effect do
2830
-- Compute the response and send 'MsgSharePeers' message
29-
MsgShareRequest amount -> Effect $ do
30-
(resp, server) <- recvMsgShareRequest amount
31-
return $
32-
Yield (MsgSharePeers resp)
33-
(peerSharingServerPeer server)
34-
-- Nothing to do.
35-
MsgDone -> Done ()
31+
(resp, server) <- recvMsgShareRequest amount
32+
return $
33+
Yield (MsgSharePeers resp)
34+
(peerSharingServerPeer server)
35+
-- Nothing to do.
36+
MsgDone -> Done ()

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

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
1+
{-# LANGUAGE BlockArguments #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE KindSignatures #-}
45
{-# LANGUAGE ScopedTypeVariables #-}
56
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE LambdaCase #-}
68

79
-- | A view of the transaction submission protocol from the point of view of
810
-- the server.
@@ -108,29 +110,26 @@ txSubmissionServerPeerPipelined (TxSubmissionServerPipelined server) =
108110
go (SendMsgRequestTxIdsBlocking ackNo reqNo kDone k) =
109111
Yield
110112
(MsgRequestTxIds SingBlocking ackNo reqNo) $
111-
Await $ \msg ->
112-
case msg of
113-
MsgDone ->
114-
Effect (Done <$> kDone)
113+
Await \case
114+
MsgDone ->
115+
Effect (Done <$> kDone)
115116

116-
MsgReplyTxIds (BlockingReply txids) ->
117-
Effect (go <$> k txids)
117+
MsgReplyTxIds (BlockingReply txids) ->
118+
Effect (go <$> k txids)
118119

119120
go (SendMsgRequestTxIdsPipelined ackNo reqNo k) =
120121
YieldPipelined
121122
(MsgRequestTxIds SingNonBlocking ackNo reqNo)
122-
(ReceiverAwait $ \msg ->
123-
case msg of
124-
MsgReplyTxIds (NonBlockingReply txids) ->
125-
ReceiverDone (CollectTxIds reqNo txids))
123+
(ReceiverAwait \case
124+
MsgReplyTxIds (NonBlockingReply txids) ->
125+
ReceiverDone (CollectTxIds reqNo txids))
126126
(Effect (go <$> k))
127127

128128
go (SendMsgRequestTxsPipelined txids k) =
129129
YieldPipelined
130130
(MsgRequestTxs txids)
131-
(ReceiverAwait $ \msg ->
132-
case msg of
133-
MsgReplyTxs txs -> ReceiverDone (CollectTxs txids txs))
131+
(ReceiverAwait \case
132+
MsgReplyTxs txs -> ReceiverDone (CollectTxs txids txs))
134133
(Effect (go <$> k))
135134

136135
go (CollectPipelined mNone collect) =

0 commit comments

Comments
 (0)