Replace TxProposalProcedures unsafe constructor with a pattern

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 =

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

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 =
@@ -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)))
     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

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
@@ -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
   :: ()
@@ -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)
 

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

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 (..)

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 =