From a87d137521fd220552afd43f9ad98b2c9d98cd98 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 14 Jan 2025 14:47:41 +0100 Subject: [PATCH] Replace TxProposalProcedures unsafe constructor with a pattern --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 40 +++-- .../internal/Cardano/Api/Experimental/Tx.hs | 10 +- cardano-api/internal/Cardano/Api/Fees.hs | 70 +++++---- cardano-api/internal/Cardano/Api/Tx/Body.hs | 144 ++++++++++-------- .../internal/Cardano/Api/Tx/Compatible.hs | 11 +- cardano-api/src/Cardano/Api.hs | 4 +- .../Test/Cardano/Api/TxBody.hs | 6 +- 7 files changed, 158 insertions(+), 127 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index fcaf932d0c..9341bb8859 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -260,38 +260,38 @@ genSimpleScript = -- plutus scripts as well as valid plutus scripts. genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genPlutusScript l = - case l of - PlutusScriptV1 -> do + case l of + PlutusScriptV1 -> do PlutusScript _ s <- genPlutusV1Script return s - PlutusScriptV2 -> do + PlutusScriptV2 -> do PlutusScript _ s <- genPlutusV2Script return s - PlutusScriptV3 -> do + PlutusScriptV3 -> do PlutusScript _ s <- genPlutusV3Script return s genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genValidPlutusScript l = - case l of - PlutusScriptV1 -> do + case l of + PlutusScriptV1 -> do PlutusScript _ s <- genValidPlutusV1Script return s - PlutusScriptV2 -> do + PlutusScriptV2 -> do PlutusScript _ s <- genValidPlutusV2Script return s - PlutusScriptV3 -> do + PlutusScriptV3 -> do PlutusScript _ s <- genValidPlutusV3Script return s genPlutusV1Script :: Gen (Script PlutusScriptV1) -genPlutusV1Script = do +genPlutusV1Script = do v1Script <- Gen.element [v1Loop2024PlutusScriptHexDoubleEncoded,v1Loop2024PlutusScriptHex] let v1ScriptBytes = Base16.decodeLenient v1Script return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes genValidPlutusV1Script :: Gen (Script PlutusScriptV1) -genValidPlutusV1Script = do +genValidPlutusV1Script = do v1Script <- Gen.element [v1Loop2024PlutusScriptHex] let v1ScriptBytes = Base16.decodeLenient v1Script return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes @@ -310,14 +310,14 @@ genValidPlutusV2Script = do genPlutusV3Script :: Gen (Script PlutusScriptV3) genPlutusV3Script = do - v3AlwaysSucceedsPlutusScriptHex + v3AlwaysSucceedsPlutusScriptHex <- Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript] let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes genValidPlutusV3Script :: Gen (Script PlutusScriptV3) genValidPlutusV3Script = do - v3AlwaysSucceedsPlutusScriptHex + v3AlwaysSucceedsPlutusScriptHex <- Gen.element [v3AlwaysSucceedsPlutusScript] let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes @@ -1341,18 +1341,12 @@ genProposals :: Applicative (BuildTxWith build) => ConwayEraOnwards era -> Gen (TxProposalProcedures build era) genProposals w = conwayEraOnwardsConstraints w $ do - proposals <- Gen.list (Range.constant 0 10) (genProposal w) - proposalsToBeWitnessed <- Gen.subsequence proposals - -- We're generating also some extra proposals, purposely not included in the proposals list, which results - -- in an invalid state of 'TxProposalProcedures'. - -- We're doing it for the complete representation of possible values space of TxProposalProcedures. - -- Proposal procedures code in cardano-api should handle such invalid values just fine. - extraProposals <- Gen.list (Range.constant 0 10) (genProposal w) + proposals <- Gen.list (Range.constant 0 15) (genProposal w) let sbe = convert w - proposalsWithWitnesses <- - forM (extraProposals <> proposalsToBeWitnessed) $ \proposal -> - (proposal,) <$> genScriptWitnessForStake sbe - pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) + proposalsWithMaybeWitnesses <- + forM proposals $ \proposal -> + (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe) + pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs index 9f4dfe972c..4ff146856f 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -41,6 +42,7 @@ import Cardano.Ledger.Hashes import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.SafeHash as L +import Data.Maybe import qualified Data.Set as Set import GHC.Exts (IsList (..)) import GHC.Stack @@ -153,7 +155,13 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc = in return $ ledgerbody & L.proposalProceduresTxBodyL - .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) + .~ fromMaybe + mempty + ( propProcedures + >>= \case + Featured _ TxProposalProceduresNone -> Nothing + Featured _ (TxProposalProcedures pp _) -> Just pp + ) & L.votingProceduresTxBodyL .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 81a1eedf12..a0f76578b0 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -250,7 +250,14 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = maryEraOnwardsConstraints w $ - maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) + maybe mempty (unTxProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) + where + unTxProposalProcedures + :: TxProposalProcedures BuildTx era + -> OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + unTxProposalProcedures = \case + TxProposalProceduresNone -> OSet.empty + TxProposalProcedures ps _ -> ps totalDeposits :: L.Coin totalDeposits = @@ -673,8 +680,8 @@ evaluateTransactionExecutionUnits -> UTxO era -> TxBody era -> Either - (TransactionValidityError era) - (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) + (TransactionValidityError era) + (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody = case makeSignedTransaction' era [] txbody of ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx' @@ -689,8 +696,8 @@ evaluateTransactionExecutionUnitsShelley -> UTxO era -> L.Tx (ShelleyLedgerEra era) -> Either - (TransactionValidityError era) - (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) + (TransactionValidityError era) + (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))) evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx = caseShelleyToMaryOrAlonzoEraOnwards (const (Right Map.empty)) @@ -707,8 +714,8 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) => AlonzoEraOnwards era -> Map - (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) - (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits)) + (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits)) -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)) fromLedgerScriptExUnitsMap aOnwards exmap = fromList @@ -1502,15 +1509,15 @@ substituteExecutionUnits let mappedScriptWitnesses :: [ ( Certificate era , Either - (TxBodyErrorAutoBalance era) - ( BuildTxWith - BuildTx - ( Maybe - ( StakeCredential - , Witness WitCtxStake era - ) - ) - ) + (TxBodyErrorAutoBalance era) + ( BuildTxWith + BuildTx + ( Maybe + ( StakeCredential + , Witness WitCtxStake era + ) + ) + ) ) ] mappedScriptWitnesses = @@ -1523,8 +1530,8 @@ substituteExecutionUnits mapScriptWitnessesVotes :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) -> Either - (TxBodyErrorAutoBalance era) - (Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))) + (TxBodyErrorAutoBalance era) + (Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))) mapScriptWitnessesVotes Nothing = return Nothing mapScriptWitnessesVotes (Just (Featured _ TxVotingProceduresNone)) = return Nothing mapScriptWitnessesVotes (Just (Featured _ (TxVotingProcedures _ ViewTx))) = return Nothing @@ -1542,13 +1549,14 @@ substituteExecutionUnits (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits))) mapScriptWitnessesProposals - :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + :: Applicative (BuildTxWith build) + => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) -> Either - (TxBodyErrorAutoBalance era) - (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) + (TxBodyErrorAutoBalance era) + (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) mapScriptWitnessesProposals Nothing = return Nothing mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing - mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing + mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing -- TODO why it's not returning the original proposal? mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do let eSubstitutedExecutionUnits = [ (proposal, updatedWitness) @@ -1557,13 +1565,19 @@ substituteExecutionUnits ] substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits + -- join again with osetProposalProcedures, just in case anything was left there + let allUpdatedProposals = + [ (proposal, mWitness) + | proposal <- toList osetProposalProcedures + , -- substituteExecUnits has only distinct proposals, so we can safely use lookup to find the first match + let mWitness = lookup proposal substitutedExecutionUnits + ] - return $ - Just - ( Featured - era - (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits)) - ) + pure $ + Just $ + Featured era $ + conwayEraOnwardsConstraints era $ + mkTxProposalProcedures allUpdatedProposals mapScriptWitnessesMinting :: TxMintValue BuildTx era diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 15e36019d5..4781f5bbc5 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -145,10 +145,10 @@ module Cardano.Api.Tx.Body , TxVotingProcedures (..) , mkTxVotingProcedures , indexTxVotingProcedures - , TxProposalProcedures (..) + , TxProposalProcedures (TxProposalProceduresNone) + , pattern TxProposalProcedures , mkTxProposalProcedures , indexTxProposalProcedures - , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) @@ -287,6 +287,7 @@ import Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlon StandardConway, StandardMary, StandardShelley) import Control.Applicative +import Control.Arrow ((&&&)) import Control.Monad import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson @@ -324,6 +325,7 @@ import Data.Typeable import Data.Word (Word16, Word32, Word64) import GHC.Exts (IsList (..)) import GHC.Stack +import GHC.TypeNats (type (<=)) import Lens.Micro hiding (ix) import Lens.Micro.Extras (view) import qualified Text.Parsec as Parsec @@ -1291,11 +1293,11 @@ data TxCertificates build era where TxCertificates :: ShelleyBasedEra era -> OMap - (Certificate era) - ( BuildTxWith - build - (Maybe (StakeCredential, Witness WitCtxStake era)) - ) + (Certificate era) + ( BuildTxWith + build + (Maybe (StakeCredential, Witness WitCtxStake era)) + ) -> TxCertificates build era deriving instance Eq (TxCertificates build era) @@ -1356,12 +1358,12 @@ data TxMintValue build era where TxMintValue :: MaryEraOnwards era -> Map - PolicyId - [ ( AssetName - , Quantity - , BuildTxWith build (ScriptWitness WitCtxMint era) - ) - ] + PolicyId + [ ( AssetName + , Quantity + , BuildTxWith build (ScriptWitness WitCtxMint era) + ) + ] -> TxMintValue build era deriving instance Eq (TxMintValue build era) @@ -1405,8 +1407,8 @@ data TxVotingProcedures build era where TxVotingProcedures :: L.VotingProcedures (ShelleyLedgerEra era) -> BuildTxWith - build - (Map (Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)) + build + (Map (Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)) -> TxVotingProcedures build era deriving instance Eq (TxVotingProcedures build era) @@ -1471,7 +1473,7 @@ data TxProposalProcedures build era where TxProposalProceduresNone :: TxProposalProcedures build era -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor -- directly. - TxProposalProcedures + UnsafeTxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) -- ^ a set of proposals @@ -1484,6 +1486,17 @@ deriving instance Eq (TxProposalProcedures build era) deriving instance Show (TxProposalProcedures build era) +{-# COMPLETE TxProposalProceduresNone, TxProposalProcedures #-} + +pattern TxProposalProcedures + :: Applicative (BuildTxWith build) + => Ledger.EraPParams (ShelleyLedgerEra era) + => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) + -> TxProposalProcedures build era +pattern TxProposalProcedures oset wits <- + (convProposalProcedures &&& id -> (oset, UnsafeTxProposalProcedures _ wits)) + -- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the -- witnessed proposals are also present in the first constructor parameter. mkTxProposalProcedures @@ -1497,7 +1510,7 @@ mkTxProposalProcedures proposalsWithWitnessesList = do bimap toList toList $ Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList shelleyBasedEraConstraints (shelleyBasedEra @era) $ - TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) + UnsafeTxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) where partitionProposals (ps, pws) (p, Nothing) = (DList.snoc ps p, pws) -- add a proposal to the list @@ -1509,7 +1522,7 @@ indexTxProposalProcedures :: TxProposalProcedures BuildTx era -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)] indexTxProposalProcedures TxProposalProceduresNone = [] -indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do +indexTxProposalProcedures txpp@(UnsafeTxProposalProcedures _ (BuildTxWith witnesses)) = do let allProposalsList = toList $ convProposalProcedures txpp [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness) | (proposal, scriptWitness) <- toList witnesses @@ -2227,9 +2240,8 @@ fromLedgerProposalProcedures sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> conwayEraOnwardsConstraints w $ Featured w $ - TxProposalProcedures - (body ^. L.proposalProceduresTxBodyL) - ViewTx + mkTxProposalProcedures + (fmap (,Nothing) . toList $ body ^. L.proposalProceduresTxBodyL) fromLedgerVotingProcedures :: () @@ -2774,17 +2786,17 @@ convScriptData sbe txOuts scriptWitnesses = [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOuts] ++ [ d | ( _ - , AnyScriptWitness - ( PlutusScriptWitness - _ - _ - _ - (ScriptDatumForTxIn (Just d)) - _ - _ - ) - ) <- - scriptWitnesses + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn (Just d)) + _ + _ + ) + ) <- + scriptWitnesses ] in TxBodyScriptData w datums redeemers ) @@ -2825,7 +2837,7 @@ convReferenceInputs txInsReference = convProposalProcedures :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures pp bWits) = do +convProposalProcedures (UnsafeTxProposalProcedures pp bWits) = do let wits = fromMaybe mempty $ buildTxWithToMaybe bWits pp |>< fromList (Map.keys wits) @@ -3077,17 +3089,17 @@ makeShelleyTransactionBody [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOuts] ++ [ d | ( _ - , AnyScriptWitness - ( PlutusScriptWitness - _ - _ - _ - (ScriptDatumForTxIn (Just d)) - _ - _ - ) - ) <- - witnesses + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn (Just d)) + _ + _ + ) + ) <- + witnesses ] redeemers :: Alonzo.Redeemers StandardAlonzo @@ -3200,17 +3212,17 @@ makeShelleyTransactionBody [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOuts] ++ [ d | ( _ - , AnyScriptWitness - ( PlutusScriptWitness - _ - _ - _ - (ScriptDatumForTxIn (Just d)) - _ - _ - ) - ) <- - witnesses + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn (Just d)) + _ + _ + ) + ) <- + witnesses ] redeemers :: Alonzo.Redeemers StandardBabbage @@ -3338,17 +3350,17 @@ makeShelleyTransactionBody [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOuts] ++ [ d | ( _ - , AnyScriptWitness - ( PlutusScriptWitness - _ - _ - _ - (ScriptDatumForTxIn (Just d)) - _ - _ - ) - ) <- - witnesses + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn (Just d)) + _ + _ + ) + ) <- + witnesses ] redeemers :: Alonzo.Redeemers StandardConway diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 4928309b99..bf1da1a65b 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -83,13 +83,14 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate pure (updateTxBody, []) - NoPParamsUpdate _ -> do + NoPParamsUpdate _ -> pure (mempty, []) - ProposalProcedures conwayOnwards proposalProcedures -> do - let proposals = convProposalProcedures proposalProcedures - proposalWitnesses = + ProposalProcedures _ TxProposalProceduresNone -> + pure (mempty, []) + ProposalProcedures conwayOnwards tpp@(TxProposalProcedures proposals _) -> do + let proposalWitnesses = [ (ix, AnyScriptWitness witness) - | (ix, _, witness) <- indexTxProposalProcedures proposalProcedures + | (ix, _, witness) <- indexTxProposalProcedures tpp ] referenceInputs = [ toShelleyTxIn txIn diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 02498e5324..680c2e93ae 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -399,9 +399,9 @@ module Cardano.Api , indexTxMintValue , TxVotingProcedures (..) , mkTxVotingProcedures - , TxProposalProcedures (..) + , TxProposalProcedures (TxProposalProceduresNone) + , pattern TxProposalProcedures , mkTxProposalProcedures - , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs index f2a2a994d6..ea2cc1d34f 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} @@ -102,10 +103,11 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do getVotingProcedures TxVotingProceduresNone = Nothing getVotingProcedures (TxVotingProcedures vps _) = Just vps getProposalProcedures - :: TxProposalProcedures build era + :: Applicative (BuildTxWith build) + => TxProposalProcedures build era -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)] getProposalProcedures TxProposalProceduresNone = Nothing - getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp + getProposalProcedures (TxProposalProcedures pp _) = Just $ toList pp tests :: TestTree tests =