diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 5585aff263..04b3cde976 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -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