Skip to content

Commit

Permalink
Adapt to removal/deprecation of patterns (IntersectMBO/cardano-api#728)
Browse files Browse the repository at this point in the history
  • Loading branch information
smelc authored and CarlosLopezDeLara committed Jan 29, 2025
1 parent f065eb3 commit 34ca5d7
Showing 1 changed file with 86 additions and 91 deletions.
177 changes: 86 additions & 91 deletions cardano-cli/src/Cardano/CLI/Json/Friendly.hs
Original file line number Diff line number Diff line change
Expand Up @@ -198,97 +198,92 @@ friendlyTxBodyImpl
=> CardanoEra era
-> TxBody era
-> m [Aeson.Pair]
friendlyTxBodyImpl
era
tb@( TxBody
-- Enumerating the fields, so that we are warned by GHC when we add a new one
( TxBodyContent
txIns
txInsCollateral
txInsReference
txOuts
txTotalCollateral
txReturnCollateral
txFee
txValidityLowerBound
txValidityUpperBound
txMetadata
txAuxScripts
txExtraKeyWits
_txProtocolParams
txWithdrawals
txCertificates
txUpdateProposal
txMintValue
_txScriptValidity
txProposalProcedures
txVotingProcedures
txCurrentTreasuryValue
txTreasuryDonation
)
) =
do
return $
cardanoEraConstraints
era
( [ "auxiliary scripts" .= friendlyAuxScripts txAuxScripts
, "certificates" .= forEraInEon era Null (`friendlyCertificates` txCertificates)
, "collateral inputs" .= friendlyCollateralInputs txInsCollateral
, "era" .= era
, "fee" .= friendlyFee txFee
, "inputs" .= friendlyInputs txIns
, "metadata" .= friendlyMetadata txMetadata
, "mint" .= friendlyMintValue txMintValue
, "outputs" .= map (friendlyTxOut era) txOuts
, "reference inputs" .= friendlyReferenceInputs txInsReference
, "total collateral" .= friendlyTotalCollateral txTotalCollateral
, "return collateral" .= friendlyReturnCollateral era txReturnCollateral
, "required signers (payment key hashes needed for scripts)"
.= friendlyExtraKeyWits txExtraKeyWits
, "update proposal" .= friendlyUpdateProposal txUpdateProposal
, "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound)
, "withdrawals" .= friendlyWithdrawals txWithdrawals
]
++ ( monoidForEraInEon @AlonzoEraOnwards
era
(`getScriptWitnessDetails` tb)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
conwayEraOnwardsConstraints cOnwards $
case txProposalProcedures of
Nothing -> []
Just (Featured _ TxProposalProceduresNone) -> []
Just (Featured _ pp) -> do
let lProposals = toList $ convProposalProcedures pp
["governance actions" .= (friendlyLedgerProposals cOnwards lProposals)]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
case txVotingProcedures of
Nothing -> []
Just (Featured _ TxVotingProceduresNone) -> []
Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
["voters" .= friendlyVotingProcedures cOnwards votes]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
)
)
where
friendlyLedgerProposals
:: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value
friendlyLedgerProposals cOnwards proposalProcedures =
Array $ fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures
friendlyTxBodyImpl era tb = do
return $
cardanoEraConstraints
era
( [ "auxiliary scripts" .= friendlyAuxScripts txAuxScripts
, "certificates" .= forEraInEon era Null (`friendlyCertificates` txCertificates)
, "collateral inputs" .= friendlyCollateralInputs txInsCollateral
, "era" .= era
, "fee" .= friendlyFee txFee
, "inputs" .= friendlyInputs txIns
, "metadata" .= friendlyMetadata txMetadata
, "mint" .= friendlyMintValue txMintValue
, "outputs" .= map (friendlyTxOut era) txOuts
, "reference inputs" .= friendlyReferenceInputs txInsReference
, "total collateral" .= friendlyTotalCollateral txTotalCollateral
, "return collateral" .= friendlyReturnCollateral era txReturnCollateral
, "required signers (payment key hashes needed for scripts)"
.= friendlyExtraKeyWits txExtraKeyWits
, "update proposal" .= friendlyUpdateProposal txUpdateProposal
, "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound)
, "withdrawals" .= friendlyWithdrawals txWithdrawals
]
++ ( monoidForEraInEon @AlonzoEraOnwards
era
(`getScriptWitnessDetails` tb)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
conwayEraOnwardsConstraints cOnwards $
case txProposalProcedures of
Nothing -> []
Just (Featured _ TxProposalProceduresNone) -> []
Just (Featured _ pp) -> do
let lProposals = toList $ convProposalProcedures pp
["governance actions" .= (friendlyLedgerProposals cOnwards lProposals)]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
( \cOnwards ->
case txVotingProcedures of
Nothing -> []
Just (Featured _ TxVotingProceduresNone) -> []
Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
["voters" .= friendlyVotingProcedures cOnwards votes]
)
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
)
++ ( monoidForEraInEon @ConwayEraOnwards
era
(const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
)
)
where
-- Enumerating the fields, so that we are warned by GHC when we add a new one
TxBodyContent
txIns
txInsCollateral
txInsReference
txOuts
txTotalCollateral
txReturnCollateral
txFee
txValidityLowerBound
txValidityUpperBound
txMetadata
txAuxScripts
txExtraKeyWits
_txProtocolParams
txWithdrawals
txCertificates
txUpdateProposal
txMintValue
_txScriptValidity
txProposalProcedures
txVotingProcedures
txCurrentTreasuryValue
txTreasuryDonation = getTxBodyContent tb
friendlyLedgerProposals
:: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value
friendlyLedgerProposals cOnwards proposalProcedures =
Array $ fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures

friendlyLedgerProposal
:: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value
Expand Down

0 comments on commit 34ca5d7

Please sign in to comment.