Revert to using an ill-defined TxProposalProcedures constructor

cardano-api/cardano-api.cabal

@@ -184,6 +184,7 @@ library internal
     data-default-class,
     deepseq,
     directory,
+    dlist,
     either,
     errors,
     filepath,
@@ -196,7 +197,6 @@ library internal
     mtl,
     network,
     optparse-applicative-fork,
-    ordered-containers,
     ouroboros-consensus ^>=0.20,
     ouroboros-consensus-cardano ^>=0.18,
     ouroboros-consensus-diffusion ^>=0.17,
@@ -327,7 +327,6 @@ test-suite cardano-api-test
     hedgehog-quickcheck,
     interpolatedstring-perl6,
     mtl,
-    ordered-containers,
     ouroboros-consensus,
     ouroboros-consensus-cardano,
     ouroboros-consensus-protocol,

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -86,6 +86,7 @@ module Test.Gen.Cardano.Api.Typed
   , genTxAuxScripts
   , genTxBody
   , genTxBodyContent
+  , genValidTxBody
   , genTxCertificates
   , genTxFee
   , genTxIndex
@@ -160,6 +161,7 @@ import           Data.Ratio (Ratio, (%))
 import           Data.String
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Exts (IsList(..))
+import           GHC.Stack
 import           Numeric.Natural (Natural)
 
 import           Test.Gen.Cardano.Api.Era
@@ -446,7 +448,7 @@ genOperationalCertificateIssueCounter :: Gen OperationalCertificateIssueCounter
 genOperationalCertificateIssueCounter = snd <$> genOperationalCertificateWithCounter
 
 genOperationalCertificateWithCounter
-  :: Gen (OperationalCertificate, OperationalCertificateIssueCounter)
+  :: HasCallStack => Gen (OperationalCertificate, OperationalCertificateIssueCounter)
 genOperationalCertificateWithCounter = do
   kesVKey <- genVerificationKey AsKesKey
   stkPoolOrGenDelExtSign <-
@@ -459,7 +461,7 @@ genOperationalCertificateWithCounter = do
   case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of
     -- This case should be impossible as we clearly derive the verification
     -- key from the generated signing key.
-    Left err -> fail $ docToString $ prettyError err
+    Left err -> error $ docToString $ prettyError err
     Right pair -> return pair
  where
   convert
@@ -760,23 +762,37 @@ genTxOutByron =
     <*> pure TxOutDatumNone
     <*> pure ReferenceScriptNone
 
-genTxBodyByron :: Gen (L.Annotated L.Tx ByteString)
+-- | Partial! It will throw if the generated transaction body is invalid.
+genTxBodyByron :: HasCallStack => Gen (L.Annotated L.Tx ByteString)
 genTxBodyByron = do
   txIns <-
     map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn
   txOuts <- Gen.list (Range.constant 1 10) genTxOutByron
   case Api.makeByronTransactionBody txIns txOuts of
-    Left err -> fail (displayError err)
+    Left err -> error (displayError err)
     Right txBody -> pure txBody
 
 genWitnessesByron :: Gen [KeyWitness ByronEra]
 genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness
 
-genTxBody :: ShelleyBasedEra era -> Gen (TxBody era)
+-- | This generator validates generated 'TxBodyContent' and backtracks when the generated body
+-- fails the validation. That also means that it is quite slow.
+genValidTxBody :: ShelleyBasedEra era
+               -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent'
+genValidTxBody sbe =
+  Gen.mapMaybe
+    (\content ->
+        either (const Nothing) (Just . (, content)) $
+          createAndValidateTransactionBody sbe content
+    )
+    (genTxBodyContent sbe)
+
+-- | Partial! This function will throw an error when the generated transaction is invalid.
+genTxBody :: HasCallStack => ShelleyBasedEra era -> Gen (TxBody era)
 genTxBody era = do
   res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era
   case res of
-    Left err -> fail (docToString (prettyError err))
+    Left err -> error (docToString (prettyError err))
     Right txBody -> pure txBody
 
 -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator.
@@ -799,7 +815,7 @@ genMaybeFeaturedInEra
   -> f (Maybe (Featured eon era a))
 genMaybeFeaturedInEra f =
   inEonForEra (pure Nothing) $ \w ->
-    pure Nothing <|> fmap Just (genFeaturedInEra w (f w))
+    Just <$> genFeaturedInEra w (f w)
 
 genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era)
 genTxScriptValidity =
@@ -817,7 +833,7 @@ genTx
 genTx era =
   makeSignedTransaction
     <$> genWitnesses era
-    <*> genTxBody era
+    <*> (fst <$> genValidTxBody era)
 
 genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era]
 genWitnesses sbe = do
@@ -870,16 +886,16 @@ genShelleyBootstrapWitness
 genShelleyBootstrapWitness sbe =
   makeShelleyBootstrapWitness sbe
     <$> genWitnessNetworkIdOrByronAddress
-    <*> genTxBody sbe
+    <*> (fst <$> genValidTxBody sbe)
     <*> genSigningKey AsByronKey
 
 genShelleyKeyWitness
   :: ()
   => ShelleyBasedEra era
   -> Gen (KeyWitness era)
 genShelleyKeyWitness sbe =
-  makeShelleyKeyWitness sbe
-    <$> genTxBody sbe
+  makeShelleyKeyWitness sbe . fst
+    <$> genValidTxBody sbe
     <*> genShelleyWitnessSigningKey
 
 genShelleyWitness
@@ -1127,11 +1143,17 @@ genProposals :: Applicative (BuildTxWith build)
              -> 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)
   let sbe = conwayEraOnwardsToShelleyBasedEra w
-  proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> do
-    mWitness <- Gen.maybe (genScriptWitnessForStake sbe)
-    pure (proposal, pure mWitness)
-  pure $ TxProposalProcedures proposalsWithWitnesses
+  proposalsWithWitnesses <-
+    forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
+      (proposal,) <$> genScriptWitnessForStake sbe
+  pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =

cardano-api/internal/Cardano/Api/Fees.hs

@@ -84,7 +84,6 @@ import           Data.Bifunctor (bimap, first, second)
 import           Data.ByteString.Short (ShortByteString)
 import           Data.Function ((&))
 import qualified Data.List as List
-import qualified Data.Map.Ordered as OMap
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -250,11 +249,7 @@ estimateBalancedTxBody
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
           maryEraOnwardsConstraints w $
-            case unFeatured <$> txProposalProcedures txbodycontent1 of
-              Nothing -> mempty
-              Just TxProposalProceduresNone -> mempty
-              Just (TxProposalProcedures pp) ->
-                fromList $ (map fst . toList) pp
+            maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1)
 
         totalDeposits :: L.Coin
         totalDeposits =
@@ -1394,8 +1389,7 @@ maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txRetu
 
 substituteExecutionUnits
   :: forall era
-   . IsShelleyBasedEra era
-  => Map ScriptWitnessIndex ExecutionUnits
+   . Map ScriptWitnessIndex ExecutionUnits
   -> TxBodyContent BuildTx era
   -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
 substituteExecutionUnits
@@ -1573,29 +1567,30 @@ substituteExecutionUnits
           (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits)))
 
     mapScriptWitnessesProposals
-      :: forall build
-       . Applicative (BuildTxWith build)
-      => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
       -> Either
           (TxBodyErrorAutoBalance era)
           (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
-    mapScriptWitnessesProposals Nothing = pure Nothing
-    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = pure Nothing
-    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures proposalProcedures))) = do
-      let substitutedExecutionUnits =
-            [ (proposal, mUpdatedWitness)
-            | (proposal, BuildTxWith mScriptWitness) <- toList proposalProcedures
-            , index <- maybeToList $ OMap.findIndex proposal proposalProcedures
-            , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness
+    mapScriptWitnessesProposals Nothing = return Nothing
+    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing
+    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing
+    mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do
+      let allProposalsList = toList $ convProposalProcedures txpp
+          eSubstitutedExecutionUnits =
+            [ (proposal, updatedWitness)
+            | (proposal, scriptWitness) <- toList sWitMap
+            , index <- maybeToList $ List.elemIndex proposal allProposalsList
+            , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness
             ]
-      final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) ->
-        case meExecUnits of
-          Nothing -> pure (p, pure Nothing)
-          Just eExecUnits -> do
-            -- TODO aggregate errors instead of shortcircuiting here
-            execUnits <- eExecUnits
-            pure (p, pure $ pure execUnits)
-      pure . mkFeatured $ TxProposalProcedures final
+
+      substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits
+
+      return $
+        Just
+          ( Featured
+              era
+              (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits))
+          )
 
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era
@@ -1624,8 +1619,8 @@ substituteExecutionUnits
                 fromList final
 
 traverseScriptWitnesses
-  :: [(a, Either l r)]
-  -> Either l [(a, r)]
+  :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
+  -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
 traverseScriptWitnesses =
   traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
 

cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs

@@ -155,9 +155,6 @@ instance IsShelleyBasedEra era => Show (Proposal era) where
 instance IsShelleyBasedEra era => Eq (Proposal era) where
   (Proposal pp1) == (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ pp1 == pp2
 
-instance IsShelleyBasedEra era => Ord (Proposal era) where
-  compare (Proposal pp1) (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ compare pp1 pp2
-
 instance IsShelleyBasedEra era => ToCBOR (Proposal era) where
   toCBOR (Proposal vp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp
 

cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs

@@ -123,8 +123,6 @@ newtype VotingProcedures era = VotingProcedures
 
 deriving instance Eq (VotingProcedures era)
 
-deriving instance Ord (VotingProcedures era)
-
 deriving instance Generic (VotingProcedures era)
 
 deriving instance Show (VotingProcedures era)

cardano-api/internal/Cardano/Api/Orphans.hs

@@ -575,12 +575,6 @@ parsePlutusParamName t =
 
 deriving instance Show V2.ParamName
 
--- Required instance, to be able to use the type as the map key
--- TODO upstream to cardano-ledger
-deriving instance Ord (L.VotingProcedures ledgerera)
-
-deriving instance Ord (L.VotingProcedure ledgerera)
-
 -- TODO upstream to cardano-ledger
 instance IsList (ListMap k a) where
   type Item (ListMap k a) = (k, a)