add more fix

IntersectMBO · Aug 2, 2024 · f26ebd5 · f26ebd5
1 parent c433c4d
commit f26ebd5
Show file tree

Hide file tree

Showing 6 changed files with 33 additions and 23 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -57,6 +57,7 @@ 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
@@ -97,8 +98,6 @@ import qualified Data.Text as Text
 import           GHC.Exts (IsList (..))
 import           Lens.Micro ((.~), (^.))
 
-{- HLINT ignore "Redundant return" -}
-
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
 -- for scripts in transactions.
 type EvalTxExecutionUnitsLog = [Text]
@@ -252,8 +251,9 @@ estimateBalancedTxBody
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
           maryEraOnwardsConstraints w $
-            maybe mempty (convProposalProcedures . unFeatured) $
-              txProposalProcedures txbodycontent1
+            fromList $
+              maybe [] (map (unProposal . fst) . toList) $
+                (getProposalProcedures . unFeatured) =<< txProposalProcedures txbodycontent1
 
         totalDeposits :: L.Coin
         totalDeposits =

diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs
@@ -123,6 +123,8 @@ newtype VotingProcedures era = VotingProcedures
 
 deriving instance Eq (VotingProcedures era)
 
+deriving instance Ord (VotingProcedures era)
+
 deriving instance Generic (VotingProcedures era)
 
 deriving instance Show (VotingProcedures era)

diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs
@@ -571,3 +571,8 @@ parsePlutusParamName t =
     Nothing -> fail $ "Cannot parse cost model parameter name: " <> T.unpack t
 
 deriving instance Show V2.ParamName
+
+-- needed to be able to use it as a map key
+deriving instance Ord (L.VotingProcedures ledgerera)
+
+deriving instance Ord (L.VotingProcedure ledgerera)
diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -55,7 +55,6 @@ module Cardano.Api.Tx.Body
   , setTxCertificates
   , setTxUpdateProposal
   , setTxProposalProcedures
-  , convProposalProcedures
   , setTxVotingProcedures
   , setTxMintValue
   , setTxScriptValidity
@@ -114,7 +113,8 @@ module Cardano.Api.Tx.Body
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , TxVotingProcedures (..)
-  , TxProposalProcedures
+  , mkTxVotingProcedures
+  , TxProposalProcedures (TxProposalProceduresNone)
   , mkTxProposalProcedures
   , getProposalProcedures
 
@@ -1222,7 +1222,6 @@ data TxVotingProcedures build era where
   TxVotingProceduresNone :: TxVotingProcedures build era
   TxVotingProcedures
     :: L.VotingProcedures (ShelleyLedgerEra era)
-    -- TODO possible bug
     -> BuildTxWith
         build
         (Map (Ledger.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era))
@@ -1234,27 +1233,27 @@ deriving instance Show (TxVotingProcedures build era)
 
 mkTxVotingProcedures
   :: Applicative (BuildTxWith build)
-  => [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
+  => OMap (VotingProcedures era) (Maybe (ScriptWitness WitCtxStake era))
   -> Either (VotesMergingConflict era) (TxVotingProcedures build era)
 mkTxVotingProcedures votingProcedures = do
   VotingProcedures procedure <-
-    foldM f emptyVotingProcedures votingProcedures
+    foldM f emptyVotingProcedures $ toList votingProcedures
   pure $ TxVotingProcedures procedure (pure votingScriptWitnessMap)
  where
   votingScriptWitnessMap =
     foldl
       (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next)
       Map.empty
-      votingProcedures
+      (toList votingProcedures)
   f acc (procedure, _witness) = mergeVotingProcedures acc procedure
 
   votingScriptWitnessSingleton
     :: VotingProcedures era
     -> Maybe (ScriptWitness WitCtxStake era)
     -> Map (L.Voter (L.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)
   votingScriptWitnessSingleton _ Nothing = Map.empty
-  votingScriptWitnessSingleton votingProcedures (Just scriptWitness) = do
-    let voter = fromJust $ getVotingScriptCredentials votingProcedures
+  votingScriptWitnessSingleton votingProcedures' (Just scriptWitness) = do
+    let voter = fromJust $ getVotingScriptCredentials votingProcedures'
     Map.singleton voter scriptWitness
 
   getVotingScriptCredentials
@@ -2459,13 +2458,14 @@ convReferenceInputs txInsReference =
     TxInsReferenceNone -> mempty
     TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins
 
--- REMOVE THIS, REPLACE WITH pattern
 convProposalProcedures
-  :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-convProposalProcedures TxProposalProceduresNone = OSet.empty
-convProposalProcedures (TxProposalProcedures procedures ViewTx) = procedures
-convProposalProcedures (TxProposalProcedures procedures (BuildTxWith proposalProceduresWithWitnesses)) =
-  procedures -- <> fromList (Map.keys proposalProceduresWithWitnesses)
+  :: forall era build
+   . IsShelleyBasedEra era
+  => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+convProposalProcedures pp =
+  shelleyBasedEraConstraints (shelleyBasedEra @era) $
+    fromList . maybe [] (map (unProposal . fst) . toList) $
+      getProposalProcedures pp
 
 convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era)
 convVotingProcedures txVotingProcedures =

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -357,7 +357,8 @@ module Cardano.Api
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , TxVotingProcedures (..)
-  , TxProposalProcedures
+  , mkTxVotingProcedures
+  , TxProposalProcedures (TxProposalProceduresNone)
   , mkTxProposalProcedures
   , getProposalProcedures
 

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
@@ -88,18 +88,20 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
 
   let proposals = getProposalProcedures . unFeatured <$> txProposalProcedures content
       proposals' = getProposalProcedures . unFeatured <$> txProposalProcedures content'
-      -- votes = getVotingProcedures . unFeatured <$> txVotingProcedures content
-      -- votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content'
+      votes = getVotingProcedures . unFeatured <$> txVotingProcedures content
+      votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content'
       currTreasury = unFeatured <$> txCurrentTreasuryValue content
       currTreasury' = unFeatured <$> txCurrentTreasuryValue content'
       treasuryDonation = unFeatured <$> txTreasuryDonation content
       treasuryDonation' = unFeatured <$> txTreasuryDonation content'
 
   proposals === proposals'
-  -- votes === votes'
+  votes === votes'
   currTreasury === currTreasury'
   treasuryDonation === treasuryDonation'
-  H.failure
+ where
+  getVotingProcedures TxVotingProceduresNone = Nothing
+  getVotingProcedures (TxVotingProcedures vps _) = Just vps
 
 tests :: TestTree
 tests =