Fix argument type in TxProposalProcedures constructor

IntersectMBO · Aug 8, 2024 · 200b65c · 200b65c
1 parent af98dfd
commit 200b65c
Show file tree

Hide file tree

Showing 6 changed files with 64 additions and 87 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -282,7 +282,6 @@ library gen
     cardano-binary >=1.6 && <1.8,
     cardano-crypto-class ^>=2.1.2,
     cardano-crypto-test ^>=1.5,
-    cardano-data,
     cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.8.1,
     cardano-ledger-byron-test >=1.5,
     cardano-ledger-conway:testlib >=1.10.0,
@@ -328,6 +327,7 @@ test-suite cardano-api-test
     hedgehog-quickcheck,
     interpolatedstring-perl6,
     mtl,
+    ordered-containers,
     ouroboros-consensus,
     ouroboros-consensus-cardano,
     ouroboros-consensus-protocol,

diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
@@ -1126,11 +1126,12 @@ genProposals :: Applicative (BuildTxWith build)
              => ConwayEraOnwards era
              -> Gen (TxProposalProcedures build era)
 genProposals w = conwayEraOnwardsConstraints w $ do
-  proposals <- fmap Proposal <$> Gen.list (Range.constant 0 10) (genProposal w)
+  proposals <- Gen.list (Range.constant 0 10) (genProposal w)
   let sbe = conwayEraOnwardsToShelleyBasedEra w
-  proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal ->
-    (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
-  pure $ mkTxProposalProcedures proposalsWithWitnesses
+  proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> do
+    mWitness <- Gen.maybe (genScriptWitnessForStake sbe)
+    pure (proposal, pure mWitness)
+  pure $ TxProposalProcedures proposalsWithWitnesses
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =

diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -56,7 +56,6 @@ import           Cardano.Api.Eras.Case
 import           Cardano.Api.Eras.Core
 import           Cardano.Api.Error
 import           Cardano.Api.Feature
-import           Cardano.Api.Governance.Actions.ProposalProcedure
 import qualified Cardano.Api.Ledger.Lens as A
 import           Cardano.Api.Pretty
 import           Cardano.Api.ProtocolParameters
@@ -251,9 +250,11 @@ estimateBalancedTxBody
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
           maryEraOnwardsConstraints w $
-            fromList $
-              maybe [] (map (unProposal . fst) . toList) $
-                (getProposalProcedures . unFeatured) =<< txProposalProcedures txbodycontent1
+            case unFeatured <$> txProposalProcedures txbodycontent1 of
+              Nothing -> mempty
+              Just TxProposalProceduresNone -> mempty
+              Just (TxProposalProcedures pp) ->
+                fromList $ (map fst . toList) pp
 
         totalDeposits :: L.Coin
         totalDeposits =
@@ -1578,23 +1579,23 @@ substituteExecutionUnits
       -> Either
           (TxBodyErrorAutoBalance era)
           (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
-    mapScriptWitnessesProposals Nothing = return Nothing
-    mapScriptWitnessesProposals (Just (Featured era proposalProcedures)) = forM (getProposalProcedures proposalProcedures) $ \pp -> do
+    mapScriptWitnessesProposals Nothing = pure Nothing
+    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = pure Nothing
+    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures proposalProcedures))) = do
       let substitutedExecutionUnits =
             [ (proposal, mUpdatedWitness)
-            | (proposal, mScriptWitness) <- toList $ fmap (join . buildTxWithToMaybe) pp
-            , index <- maybeToList $ OMap.findIndex proposal pp
+            | (proposal, BuildTxWith mScriptWitness) <- toList proposalProcedures
+            , index <- maybeToList $ OMap.findIndex proposal proposalProcedures
             , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness
             ]
       final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) ->
         case meExecUnits of
-          Nothing -> pure (p, Nothing)
+          Nothing -> pure (p, pure Nothing)
           Just eExecUnits -> do
             -- TODO aggregate errors instead of shortcircuiting here
             execUnits <- eExecUnits
-            pure (p, pure execUnits)
-
-      pure . Featured era $ mkTxProposalProcedures final
+            pure (p, pure $ pure execUnits)
+      pure . mkFeatured $ TxProposalProcedures final
 
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -114,9 +114,7 @@ module Cardano.Api.Tx.Body
   , TxMintValue (..)
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
-  , TxProposalProcedures (TxProposalProceduresNone)
-  , mkTxProposalProcedures
-  , getProposalProcedures
+  , TxProposalProcedures (..)
 
     -- ** Building vs viewing transactions
   , BuildTxWith (..)
@@ -180,7 +178,6 @@ import           Cardano.Api.Eras.Case
 import           Cardano.Api.Eras.Core
 import           Cardano.Api.Error (Error (..), displayError)
 import           Cardano.Api.Feature
-import           Cardano.Api.Governance.Actions.ProposalProcedure
 import           Cardano.Api.Governance.Actions.VotingProcedure
 import           Cardano.Api.Hash
 import           Cardano.Api.Keys.Byron
@@ -258,7 +255,6 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Monoid
 import           Data.OSet.Strict (OSet)
-import qualified Data.OSet.Strict as OSet
 import           Data.Scientific (toBoundedInteger)
 import qualified Data.Sequence.Strict as Seq
 import           Data.Set (Set)
@@ -1278,55 +1274,15 @@ data TxProposalProcedures build era where
   TxProposalProceduresNone :: TxProposalProcedures build era
   TxProposalProcedures
     :: Ledger.EraPParams (ShelleyLedgerEra era)
-    => OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-    -> BuildTxWith
-        build
-        (OMap (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era))
+    => OMap
+        (L.ProposalProcedure (ShelleyLedgerEra era))
+        (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))
     -> TxProposalProcedures build era
 
 deriving instance Eq (TxProposalProcedures build era)
 
 deriving instance Show (TxProposalProcedures build era)
 
--- | Create a 'TxProposalProcedures' value
-mkTxProposalProcedures
-  :: forall era build
-   . IsShelleyBasedEra era
-  => Applicative (BuildTxWith build)
-  => OMap (Proposal era) (Maybe (ScriptWitness WitCtxStake era))
-  -- ^ a map with proposals, with optional witnesses
-  -> TxProposalProcedures build era
-mkTxProposalProcedures proposalProcedures = shelleyBasedEraConstraints (shelleyBasedEra @era) $ do
-  let proposalsList = toList proposalProcedures
-      proposals = fromList $ map (unProposal . fst) proposalsList
-      sWitMap = fromList $ mapMaybe (\(p, mw) -> (unProposal p,) <$> mw) proposalsList
-  TxProposalProcedures proposals (pure sWitMap)
-
--- | Get map of the proposals with optional witnesses.
---
--- You can understand the return type as:
--- @
--- Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))))
---   ▲             ▲               ▲                ▲
---   │             │               │                └─ Witness if it was provided
---   │             │               └─ Witnesses are only present for 'BuildTx'
---   │             └─ A proposal which might have a witness
---   └─ 'Just' if there were provided any proposals
--- @
-getProposalProcedures
-  :: IsShelleyBasedEra era
-  => TxProposalProcedures build era
-  -> Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))))
-getProposalProcedures TxProposalProceduresNone = Nothing
-getProposalProcedures (TxProposalProcedures procedures ViewTx) =
-  Just . fromList $ map (,pure Nothing) (Proposal <$> toList procedures)
-getProposalProcedures (TxProposalProcedures procedures (BuildTxWith proposalProceduresWithWitnesses)) = do
-  Just $
-    OMap.unionWithL
-      (const (liftA2 (<|>)))
-      (fromList $ map (,pure Nothing) (Proposal <$> toList procedures))
-      (fromList $ map (bimap Proposal (pure . Just)) (toList proposalProceduresWithWitnesses))
-
 -- ----------------------------------------------------------------------------
 -- Transaction body content
 --
@@ -1896,16 +1852,26 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux =
   (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux
 
 fromLedgerProposalProcedures
-  :: ShelleyBasedEra era
+  :: forall era
+   . ShelleyBasedEra era
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era))
 fromLedgerProposalProcedures sbe body =
-  forShelleyBasedEraInEonMaybe sbe $ \w ->
-    conwayEraOnwardsConstraints w $
-      Featured w $
-        TxProposalProcedures
-          (body ^. L.proposalProceduresTxBodyL)
-          ViewTx
+  forShelleyBasedEraInEonMaybe sbe $ \w -> do
+    let lpp
+          :: [ ( L.ProposalProcedure (ShelleyLedgerEra era)
+               , BuildTxWith ViewTx (Maybe (ScriptWitness WitCtxStake era))
+               )
+             ]
+        lpp =
+          conwayEraOnwardsConstraints w $
+            map (,ViewTx) $
+              toList $
+                body ^. L.proposalProceduresTxBodyL
+    Featured w $
+      conwayEraOnwardsConstraints w $
+        TxProposalProcedures $
+          fromList lpp
 
 fromLedgerVotingProcedures
   :: ()
@@ -2483,10 +2449,12 @@ convProposalProcedures
   :: forall era build
    . IsShelleyBasedEra era
   => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-convProposalProcedures pp =
+convProposalProcedures TxProposalProceduresNone =
+  shelleyBasedEraConstraints (shelleyBasedEra @era) mempty
+convProposalProcedures (TxProposalProcedures pp) =
   shelleyBasedEraConstraints (shelleyBasedEra @era) $
-    fromList . maybe [] (map (unProposal . fst) . toList) $
-      getProposalProcedures pp
+    fromList $
+      fst <$> toList pp
 
 convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era)
 convVotingProcedures txVotingProcedures =
@@ -3310,14 +3278,11 @@ collectTxBodyScriptWitnesses
       :: TxProposalProcedures BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesProposing TxProposalProceduresNone = []
-    scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses))
-      | OMap.null mScriptWitnesses = []
-      | otherwise =
-          [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness)
-          | let proposalsList = toList $ OSet.toSet proposalProcedures
-          , (ix, proposal) <- zip [0 ..] proposalsList
-          , witness <- maybeToList (OMap.lookup proposal mScriptWitnesses)
-          ]
+    scriptWitnessesProposing (TxProposalProcedures proposalProcedures) =
+      [ (ScriptWitnessIndexProposing (fromIntegral ix), AnyScriptWitness witness)
+      | (p, BuildTxWith (Just witness)) <- toList proposalProcedures
+      , ix <- maybeToList $ OMap.findIndex p proposalProcedures
+      ]
 
 -- This relies on the TxId Ord instance being consistent with the
 -- Ledger.TxId Ord instance via the toShelleyTxId conversion

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -361,9 +361,7 @@ module Cardano.Api
   , TxMintValue (..)
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
-  , TxProposalProcedures (TxProposalProceduresNone)
-  , mkTxProposalProcedures
-  , getProposalProcedures
+  , TxProposalProcedures (..)
 
     -- ** Building vs viewing transactions
   , BuildTxWith (..)

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs
@@ -6,8 +6,11 @@ module Test.Cardano.Api.Typed.TxBody
 where
 
 import           Cardano.Api
-import           Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleyScript)
+import qualified Cardano.Api.Ledger as L
+import           Cardano.Api.Shelley (ReferenceScript (..), ShelleyLedgerEra,
+                   refScriptToShelleyScript)
 
+import           Data.Map.Ordered.Strict (OMap)
 import           Data.Maybe (isJust)
 import           Data.Type.Equality (TestEquality (testEquality))
 import           GHC.Exts (IsList (..))
@@ -103,6 +106,15 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
  where
   getVotingProcedures TxVotingProceduresNone = Nothing
   getVotingProcedures (TxVotingProcedures vps _) = Just vps
+  getProposalProcedures
+    :: TxProposalProcedures build era
+    -> Maybe
+        ( OMap
+            (L.ProposalProcedure (ShelleyLedgerEra era))
+            (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))
+        )
+  getProposalProcedures TxProposalProceduresNone = Nothing
+  getProposalProcedures (TxProposalProcedures pps) = Just pps
 
 tests :: TestTree
 tests =