Skip to content

Commit 0198b80

Browse files
carbolymercarbolymer
committed
Deduplicate code in Cardano.Api.Query.Expr module
1 parent 0cec84f commit 0198b80

File tree

4 files changed

+73
-85
lines changed

4 files changed

+73
-85
lines changed

‎cardano-api/src/Cardano/Api/Internal/Eon/Convert.hs

+4
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE FlexibleInstances #-}
12
{-# LANGUAGE MultiParamTypeClasses #-}
23
{-# LANGUAGE PolyKinds #-}
34
{-# LANGUAGE RankNTypes #-}
@@ -14,3 +15,6 @@ import Data.Kind (Type)
1415
-- relationship between types.
1516
class Convert (f :: a -> Type) (g :: a -> Type) where
1617
convert :: forall era. f era -> g era
18+
19+
instance Convert a a where
20+
convert = id

‎cardano-api/src/Cardano/Api/Internal/Orphans.hs

+3
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,7 @@ import Ouroboros.Consensus.Shelley.Eras qualified as Consensus
7272
import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
7373
import Ouroboros.Consensus.Shelley.Ledger.Query qualified as Consensus
7474
import Ouroboros.Network.Block (HeaderHash, Tip (..))
75+
import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as Net.Tx
7576
import PlutusLedgerApi.Common qualified as P
7677
import PlutusLedgerApi.V2 qualified as V2
7778

@@ -371,6 +372,8 @@ instance ToJSON PraosState where
371372
, "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s
372373
]
373374

375+
deriving instance Show a => Show (Net.Tx.SubmitResult a)
376+
374377
-- We wrap the individual records with Last and use Last's Semigroup instance.
375378
-- In this instance we take the last 'Just' value or the only 'Just' value
376379
instance Semigroup (Ledger.ShelleyPParams StrictMaybe era) where

‎cardano-api/src/Cardano/Api/Internal/Query/Expr.hs

+55-85
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE ScopedTypeVariables #-}
45

@@ -59,6 +60,7 @@ import Cardano.Api.Internal.NetworkId
5960
import Cardano.Api.Internal.Query
6061
import Cardano.Api.Internal.ReexposeLedger qualified as Ledger
6162
import Cardano.Api.Internal.Tx.UTxO
63+
import Cardano.Api.Internal.Utils ((<<<$>>>))
6264

6365
import Cardano.Ledger.Api qualified as L
6466
import Cardano.Ledger.Api.State.Query qualified as L
@@ -128,8 +130,7 @@ queryCurrentEpochState
128130
r
129131
IO
130132
(Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedCurrentEpochState era)))
131-
queryCurrentEpochState sbe =
132-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryCurrentEpochState
133+
queryCurrentEpochState eon = querySbe eon QueryCurrentEpochState
133134

134135
queryEpoch
135136
:: ()
@@ -141,8 +142,7 @@ queryEpoch
141142
r
142143
IO
143144
(Either UnsupportedNtcVersionError (Either EraMismatch EpochNo))
144-
queryEpoch sbe =
145-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryEpoch
145+
queryEpoch eon = querySbe eon QueryEpoch
146146

147147
queryDebugLedgerState
148148
:: ()
@@ -154,8 +154,7 @@ queryDebugLedgerState
154154
r
155155
IO
156156
(Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedDebugLedgerState era)))
157-
queryDebugLedgerState sbe =
158-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryDebugLedgerState
157+
queryDebugLedgerState eon = querySbe eon QueryDebugLedgerState
159158

160159
queryLedgerPeerSnapshot
161160
:: ()
@@ -167,8 +166,7 @@ queryLedgerPeerSnapshot
167166
r
168167
IO
169168
(Either UnsupportedNtcVersionError (Either EraMismatch (Serialised LedgerPeerSnapshot)))
170-
queryLedgerPeerSnapshot sbe =
171-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryLedgerPeerSnapshot
169+
queryLedgerPeerSnapshot eon = querySbe eon QueryLedgerPeerSnapshot
172170

173171
queryEraHistory
174172
:: ()
@@ -186,8 +184,7 @@ queryGenesisParameters
186184
r
187185
IO
188186
(Either UnsupportedNtcVersionError (Either EraMismatch (GenesisParameters ShelleyEra)))
189-
queryGenesisParameters sbe =
190-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters
187+
queryGenesisParameters eon = querySbe eon QueryGenesisParameters
191188

192189
queryPoolDistribution
193190
:: ()
@@ -200,9 +197,7 @@ queryPoolDistribution
200197
r
201198
IO
202199
(Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era)))
203-
queryPoolDistribution era mPoolIds = do
204-
let sbe = convert era
205-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds
200+
queryPoolDistribution eon = querySbe eon . QueryPoolDistribution
206201

207202
queryPoolState
208203
:: ()
@@ -215,9 +210,7 @@ queryPoolState
215210
r
216211
IO
217212
(Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era)))
218-
queryPoolState era mPoolIds = do
219-
let sbe = convert era
220-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds
213+
queryPoolState eon = querySbe eon . QueryPoolState
221214

222215
queryProtocolParameters
223216
:: ()
@@ -229,8 +222,7 @@ queryProtocolParameters
229222
r
230223
IO
231224
(Either UnsupportedNtcVersionError (Either EraMismatch (Ledger.PParams (ShelleyLedgerEra era))))
232-
queryProtocolParameters sbe =
233-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolParameters
225+
queryProtocolParameters eon = querySbe eon QueryProtocolParameters
234226

235227
queryConstitutionHash
236228
:: ()
@@ -245,11 +237,9 @@ queryConstitutionHash
245237
UnsupportedNtcVersionError
246238
(Either EraMismatch (SafeHash L.AnchorData))
247239
)
248-
queryConstitutionHash sbe =
249-
(fmap . fmap . fmap) (L.anchorDataHash . L.constitutionAnchor) $
250-
queryExpr $
251-
QueryInEra $
252-
QueryInShelleyBasedEra sbe QueryConstitution
240+
queryConstitutionHash eon =
241+
(L.anchorDataHash . L.constitutionAnchor)
242+
<<<$>>> querySbe eon QueryConstitution
253243

254244
queryProtocolState
255245
:: ()
@@ -261,8 +251,7 @@ queryProtocolState
261251
r
262252
IO
263253
(Either UnsupportedNtcVersionError (Either EraMismatch (ProtocolState era)))
264-
queryProtocolState sbe =
265-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryProtocolState
254+
queryProtocolState eon = querySbe eon QueryProtocolState
266255

267256
queryStakeAddresses
268257
:: ()
@@ -279,8 +268,7 @@ queryStakeAddresses
279268
UnsupportedNtcVersionError
280269
(Either EraMismatch (Map StakeAddress L.Coin, Map StakeAddress PoolId))
281270
)
282-
queryStakeAddresses sbe stakeCredentials networkId =
283-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId
271+
queryStakeAddresses eon stakeCredentials networkId = querySbe eon $ QueryStakeAddresses stakeCredentials networkId
284272

285273
queryStakeDelegDeposits
286274
:: BabbageEraOnwards era
@@ -292,11 +280,9 @@ queryStakeDelegDeposits
292280
r
293281
IO
294282
(Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential L.Coin)))
295-
queryStakeDelegDeposits era stakeCreds
283+
queryStakeDelegDeposits eon stakeCreds
296284
| S.null stakeCreds = pure . pure $ pure mempty
297-
| otherwise = do
298-
let sbe = convert era
299-
queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds
285+
| otherwise = querySbe eon $ QueryStakeDelegDeposits stakeCreds
300286

301287
queryStakeDistribution
302288
:: ()
@@ -308,8 +294,7 @@ queryStakeDistribution
308294
r
309295
IO
310296
(Either UnsupportedNtcVersionError (Either EraMismatch (Map (Hash StakePoolKey) Rational)))
311-
queryStakeDistribution sbe =
312-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryStakeDistribution
297+
queryStakeDistribution eon = querySbe eon QueryStakeDistribution
313298

314299
queryStakePoolParameters
315300
:: ()
@@ -322,10 +307,10 @@ queryStakePoolParameters
322307
r
323308
IO
324309
(Either UnsupportedNtcVersionError (Either EraMismatch (Map PoolId StakePoolParameters)))
325-
queryStakePoolParameters sbe poolIds
310+
queryStakePoolParameters eon poolIds
326311
| S.null poolIds = pure . pure $ pure mempty
327312
| otherwise =
328-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakePoolParameters poolIds
313+
querySbe eon $ QueryStakePoolParameters poolIds
329314

330315
queryStakePools
331316
:: ()
@@ -337,8 +322,7 @@ queryStakePools
337322
r
338323
IO
339324
(Either UnsupportedNtcVersionError (Either EraMismatch (Set PoolId)))
340-
queryStakePools sbe =
341-
queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools
325+
queryStakePools eon = querySbe eon QueryStakePools
342326

343327
queryStakeSnapshot
344328
:: ()
@@ -351,9 +335,7 @@ queryStakeSnapshot
351335
r
352336
IO
353337
(Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era)))
354-
queryStakeSnapshot era mPoolIds = do
355-
let sbe = convert era
356-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds
338+
queryStakeSnapshot eon = querySbe eon . QueryStakeSnapshot
357339

358340
querySystemStart
359341
:: ()
@@ -372,8 +354,7 @@ queryUtxo
372354
r
373355
IO
374356
(Either UnsupportedNtcVersionError (Either EraMismatch (UTxO era)))
375-
queryUtxo sbe utxoFilter =
376-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter
357+
queryUtxo eon = querySbe eon . QueryUTxO
377358

378359
queryConstitution
379360
:: ()
@@ -385,9 +366,7 @@ queryConstitution
385366
r
386367
IO
387368
(Either UnsupportedNtcVersionError (Either EraMismatch (L.Constitution (ShelleyLedgerEra era))))
388-
queryConstitution era = do
389-
let sbe = convert era
390-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution
369+
queryConstitution eon = querySbe eon QueryConstitution
391370

392371
queryGovState
393372
:: ()
@@ -399,9 +378,7 @@ queryGovState
399378
r
400379
IO
401380
(Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era))))
402-
queryGovState era = do
403-
let sbe = convert era
404-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState
381+
queryGovState eon = querySbe eon QueryGovState
405382

406383
queryRatifyState
407384
:: ()
@@ -413,9 +390,7 @@ queryRatifyState
413390
r
414391
IO
415392
(Either UnsupportedNtcVersionError (Either EraMismatch (L.RatifyState (ShelleyLedgerEra era))))
416-
queryRatifyState era = do
417-
let sbe = convert era
418-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryRatifyState
393+
queryRatifyState eon = querySbe eon QueryRatifyState
419394

420395
queryFuturePParams
421396
:: ()
@@ -427,9 +402,7 @@ queryFuturePParams
427402
r
428403
IO
429404
(Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.PParams (ShelleyLedgerEra era)))))
430-
queryFuturePParams era = do
431-
let sbe = convert era
432-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryFuturePParams
405+
queryFuturePParams eon = querySbe eon QueryFuturePParams
433406

434407
queryDRepState
435408
:: ConwayEraOnwards era
@@ -445,9 +418,7 @@ queryDRepState
445418
UnsupportedNtcVersionError
446419
(Either EraMismatch (Map (L.Credential L.DRepRole) L.DRepState))
447420
)
448-
queryDRepState era drepCreds = do
449-
let sbe = convert era
450-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds
421+
queryDRepState eon = querySbe eon . QueryDRepState
451422

452423
queryDRepStakeDistribution
453424
:: ConwayEraOnwards era
@@ -460,9 +431,7 @@ queryDRepStakeDistribution
460431
r
461432
IO
462433
(Either UnsupportedNtcVersionError (Either EraMismatch (Map L.DRep L.Coin)))
463-
queryDRepStakeDistribution era dreps = do
464-
let sbe = convert era
465-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps
434+
queryDRepStakeDistribution eon = querySbe eon . QueryDRepStakeDistr
466435

467436
querySPOStakeDistribution
468437
:: ConwayEraOnwards era
@@ -478,9 +447,7 @@ querySPOStakeDistribution
478447
UnsupportedNtcVersionError
479448
(Either EraMismatch (Map (L.KeyHash 'L.StakePool) L.Coin))
480449
)
481-
querySPOStakeDistribution era spos = do
482-
let sbe = convert era
483-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QuerySPOStakeDistr spos
450+
querySPOStakeDistribution eon = querySbe eon . QuerySPOStakeDistr
484451

485452
-- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses.
486453
-- If empty sets are passed as filters, then no filtering is done.
@@ -496,11 +463,8 @@ queryCommitteeMembersState
496463
r
497464
IO
498465
(Either UnsupportedNtcVersionError (Either EraMismatch L.CommitteeMembersState))
499-
queryCommitteeMembersState era coldCreds hotCreds statuses = do
500-
let sbe = convert era
501-
queryExpr $
502-
QueryInEra $
503-
QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses)
466+
queryCommitteeMembersState eon coldCreds hotCreds memberStatuses =
467+
querySbe eon $ QueryCommitteeMembersState coldCreds hotCreds memberStatuses
504468

505469
queryStakeVoteDelegatees
506470
:: ConwayEraOnwards era
@@ -515,9 +479,7 @@ queryStakeVoteDelegatees
515479
UnsupportedNtcVersionError
516480
(Either EraMismatch (Map StakeCredential L.DRep))
517481
)
518-
queryStakeVoteDelegatees era stakeCredentials = do
519-
let sbe = convert era
520-
queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeVoteDelegatees stakeCredentials
482+
queryStakeVoteDelegatees eon = querySbe eon . QueryStakeVoteDelegatees
521483

522484
queryAccountState
523485
:: ConwayEraOnwards era
@@ -528,10 +490,7 @@ queryAccountState
528490
r
529491
IO
530492
(Either UnsupportedNtcVersionError (Either EraMismatch L.AccountState))
531-
queryAccountState cOnwards =
532-
queryExpr $
533-
QueryInEra . QueryInShelleyBasedEra (convert cOnwards) $
534-
QueryAccountState
493+
queryAccountState eon = querySbe eon QueryAccountState
535494

536495
queryProposals
537496
:: forall era block point r
@@ -549,11 +508,7 @@ queryProposals
549508
UnsupportedNtcVersionError
550509
(Either EraMismatch (Seq (L.GovActionState (ShelleyLedgerEra era))))
551510
)
552-
queryProposals cOnwards govActionIds = do
553-
let sbe = convert cOnwards
554-
queryExpr $
555-
QueryInEra . QueryInShelleyBasedEra sbe $
556-
QueryProposals govActionIds
511+
queryProposals eon = querySbe eon . QueryProposals
557512

558513
queryStakePoolDefaultVote
559514
:: forall era block point r
@@ -569,8 +524,23 @@ queryStakePoolDefaultVote
569524
UnsupportedNtcVersionError
570525
(Either EraMismatch L.DefaultVote)
571526
)
572-
queryStakePoolDefaultVote cOnwards stakePools = do
573-
let sbe = convert cOnwards
574-
queryExpr $
575-
QueryInEra . QueryInShelleyBasedEra sbe $
576-
QueryStakePoolDefaultVote stakePools
527+
queryStakePoolDefaultVote eon = querySbe eon . QueryStakePoolDefaultVote
528+
529+
querySbe
530+
:: Convert eon ShelleyBasedEra
531+
=> eon era
532+
-> QueryInShelleyBasedEra era result
533+
-> LocalStateQueryExpr
534+
block
535+
point
536+
QueryInMode
537+
r
538+
IO
539+
( Either
540+
UnsupportedNtcVersionError
541+
(Either EraMismatch result)
542+
)
543+
querySbe eon queryInSbe =
544+
shelleyBasedEraConstraints (convert eon) $
545+
queryExpr . QueryInEra $
546+
QueryInShelleyBasedEra (convert eon) queryInSbe

0 commit comments

Comments
 (0)