Skip to content

Commit

Permalink
Rewrite fromConsensusQueryResultShelleyBased
Browse files Browse the repository at this point in the history
  • Loading branch information
@smelc
smelc committed Jun 19, 2024
1 parent 4bbf621 commit 97292c7
Showing 1 changed file with 57 additions and 127 deletions.
184 changes: 57 additions & 127 deletions cardano-api/internal/Cardano/Api/Query.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -841,133 +841,63 @@ fromConsensusQueryResultShelleyBased
-> Consensus.BlockQuery (Consensus.ShelleyBlock protocol ledgerera) result'
-> result'
-> result
fromConsensusQueryResultShelleyBased _ QueryEpoch q' epoch =
case q' of
Consensus.GetEpochNo -> epoch
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryConstitution q' mConstitution =
case q' of
Consensus.GetConstitution -> mConstitution
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryGenesisParameters q' r' =
case q' of
Consensus.GetGenesisConfig -> fromShelleyGenesis
(Consensus.getCompactGenesis r')
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryProtocolParameters q' r' =
case q' of
Consensus.GetCurrentPParams -> r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased sbe QueryProtocolParametersUpdate q' r' =
case q' of
Consensus.GetProposedPParamsUpdates -> fromLedgerProposedPPUpdates sbe r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakeDistribution q' r' =
case q' of
Consensus.GetStakeDistribution -> fromShelleyPoolDistr r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased sbe (QueryUTxO QueryUTxOWhole) q' utxo' =
case q' of
Consensus.GetUTxOWhole -> fromLedgerUTxO sbe utxo'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased sbe (QueryUTxO QueryUTxOByAddress{}) q' utxo' =
case q' of
Consensus.GetUTxOByAddress{} -> fromLedgerUTxO sbe utxo'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased sbe (QueryUTxO QueryUTxOByTxIn{}) q' utxo' =
case q' of
Consensus.GetUTxOByTxIn{} -> fromLedgerUTxO sbe utxo'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ (QueryStakeAddresses _ nId) q' r' =
case q' of
Consensus.GetFilteredDelegationsAndRewardAccounts{}
-> let (delegs, rwaccs) = r'
in ( Map.mapKeys (makeStakeAddress nId) $ fromShelleyRewardAccounts rwaccs
, Map.mapKeys (makeStakeAddress nId) $ fromShelleyDelegations delegs
)
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakePools q' poolids' =
case q' of
Consensus.GetStakePools -> Set.map StakePoolKeyHash poolids'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakePoolParameters{} q' poolparams' =
case q' of
Consensus.GetStakePoolParams{} -> Map.map fromShelleyPoolParams
. Map.mapKeysMonotonic StakePoolKeyHash
$ poolparams'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryDebugLedgerState{} q' r' =
case q' of
Consensus.GetCBOR Consensus.DebugNewEpochState -> SerialisedDebugLedgerState r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryProtocolState q' r' =
case q' of
Consensus.GetCBOR Consensus.DebugChainDepState -> ProtocolState r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryCurrentEpochState q' r' =
case q' of
Consensus.GetCBOR Consensus.DebugEpochState -> SerialisedCurrentEpochState r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryPoolState{} q' r' =
case q' of
Consensus.GetCBOR Consensus.GetPoolState {} -> SerialisedPoolState r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryPoolDistribution{} q' r' =
case q' of
Consensus.GetCBOR Consensus.GetPoolDistr {} -> SerialisedPoolDistribution r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakeSnapshot{} q' r' =
case q' of
Consensus.GetCBOR Consensus.GetStakeSnapshots {} -> SerialisedStakeSnapshots r'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakeDelegDeposits{} q' stakeCreds' =
case q' of
Consensus.GetStakeDelegDeposits{} -> Map.mapKeysMonotonic fromShelleyStakeCredential stakeCreds'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryGovState{} q' govState' =
case q' of
Consensus.GetGovState{} -> govState'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryDRepState{} q' drepState' =
case q' of
Consensus.GetDRepState{} -> drepState'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryDRepStakeDistr{} q' stakeDistr' =
case q' of
Consensus.GetDRepStakeDistr{} -> stakeDistr'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryCommitteeMembersState{} q' committeeMembersState' =
case q' of
Consensus.GetCommitteeMembersState{} -> committeeMembersState'
_ -> fromConsensusQueryResultMismatch

fromConsensusQueryResultShelleyBased _ QueryStakeVoteDelegatees{} q' delegs' =
case q' of
Consensus.GetFilteredVoteDelegatees {}
-> Map.mapKeys fromShelleyStakeCredential delegs'
_ -> fromConsensusQueryResultMismatch
fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' =
case (sbeQuery, q') of
(QueryEpoch, Consensus.GetEpochNo) ->
r'
(QueryConstitution, Consensus.GetConstitution) ->
r'
(QueryGenesisParameters, Consensus.GetGenesisConfig) ->
fromShelleyGenesis (Consensus.getCompactGenesis r')
(QueryProtocolParameters, Consensus.GetCurrentPParams) ->
r'
(QueryProtocolParametersUpdate, Consensus.GetProposedPParamsUpdates) ->
fromLedgerProposedPPUpdates sbe r'
(QueryStakeDistribution, Consensus.GetStakeDistribution) ->
fromShelleyPoolDistr r'
(QueryUTxO QueryUTxOWhole, Consensus.GetUTxOWhole) ->
fromLedgerUTxO sbe r'
(QueryUTxO QueryUTxOByAddress{}, Consensus.GetUTxOByAddress{}) ->
fromLedgerUTxO sbe r'
(QueryUTxO QueryUTxOByTxIn{}, Consensus.GetUTxOByTxIn{}) ->
fromLedgerUTxO sbe r'
(QueryStakeAddresses _ nId, Consensus.GetFilteredDelegationsAndRewardAccounts{}) ->
let (delegs, rwaccs) = r'
in ( Map.mapKeys (makeStakeAddress nId) $ fromShelleyRewardAccounts rwaccs
, Map.mapKeys (makeStakeAddress nId) $ fromShelleyDelegations delegs
)
(QueryStakePools, Consensus.GetStakePools) ->
Set.map StakePoolKeyHash r'
(QueryStakePoolParameters{}, Consensus.GetStakePoolParams{}) ->
Map.map fromShelleyPoolParams
. Map.mapKeysMonotonic StakePoolKeyHash
$ r'
(QueryDebugLedgerState{}, Consensus.GetCBOR Consensus.DebugNewEpochState) ->
SerialisedDebugLedgerState r'
(QueryProtocolState, Consensus.GetCBOR Consensus.DebugChainDepState) ->
ProtocolState r'
(QueryCurrentEpochState, Consensus.GetCBOR Consensus.DebugEpochState) ->
SerialisedCurrentEpochState r'
(QueryPoolState{}, Consensus.GetCBOR Consensus.GetPoolState {}) ->
SerialisedPoolState r'
(QueryPoolDistribution{}, Consensus.GetCBOR Consensus.GetPoolDistr {}) ->
SerialisedPoolDistribution r'
(QueryStakeSnapshot{}, Consensus.GetCBOR Consensus.GetStakeSnapshots {}) ->
SerialisedStakeSnapshots r'
(QueryStakeDelegDeposits{}, Consensus.GetStakeDelegDeposits{}) ->
Map.mapKeysMonotonic fromShelleyStakeCredential r'
(QueryGovState{}, Consensus.GetGovState{}) ->
r'
(QueryDRepState{}, Consensus.GetDRepState{}) ->
r'
(QueryDRepStakeDistr{}, Consensus.GetDRepStakeDistr{}) ->
r'
(QueryCommitteeMembersState{}, Consensus.GetCommitteeMembersState{}) ->
r'
(QueryStakeVoteDelegatees{}, Consensus.GetFilteredVoteDelegatees {}) ->
Map.mapKeys fromShelleyStakeCredential r'
_ ->
fromConsensusQueryResultMismatch

-- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery'
-- and 'fromConsensusQueryResult' so they are inconsistent with each other.
Expand Down

0 comments on commit 97292c7

Please sign in to comment.