add more fix

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

@@ -156,8 +156,6 @@ import qualified Data.ByteString.Short as SBS
 import           Data.Coerce
 import           Data.Int (Int64)
 import           Data.Maybe
-import           Data.OSet.Strict (OSet)
-import qualified Data.OSet.Strict as OSet
 import           Data.Ratio (Ratio, (%))
 import           Data.String
 import           Data.Word (Word16, Word32, Word64)
@@ -721,7 +719,7 @@ genTxInsCollateral =
           ]
     )
 
-genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era)
+genTxInsReference :: CardanoEra era -> Gen (TxInsReference era)
 genTxInsReference =
   caseByronToAlonzoOrBabbageEraOnwards
     (const (pure TxInsReferenceNone))

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 =

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)

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)

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
 
@@ -865,16 +865,16 @@ deriving instance Eq (TxInsCollateral era)
 
 deriving instance Show (TxInsCollateral era)
 
-data TxInsReference build era where
-  TxInsReferenceNone :: TxInsReference build era
+data TxInsReference era where
+  TxInsReferenceNone :: TxInsReference era
   TxInsReference
     :: BabbageEraOnwards era
     -> [TxIn]
-    -> TxInsReference build era
+    -> TxInsReference era
 
-deriving instance Eq (TxInsReference build era)
+deriving instance Eq (TxInsReference era)
 
-deriving instance Show (TxInsReference build era)
+deriving instance Show (TxInsReference era)
 
 -- ----------------------------------------------------------------------------
 -- Transaction output values (era-dependent)
@@ -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
@@ -1318,7 +1317,7 @@ data TxBodyContent build era
   = TxBodyContent
   { txIns :: TxIns build era
   , txInsCollateral :: TxInsCollateral era
-  , txInsReference :: TxInsReference build era
+  , txInsReference :: TxInsReference era
   , txOuts :: [TxOut CtxTx era]
   , txTotalCollateral :: TxTotalCollateral era
   , txReturnCollateral :: TxReturnCollateral CtxTx era
@@ -1389,7 +1388,7 @@ addTxIn txIn = modTxIns (txIn :)
 setTxInsCollateral :: TxInsCollateral era -> TxBodyContent build era -> TxBodyContent build era
 setTxInsCollateral v txBodyContent = txBodyContent{txInsCollateral = v}
 
-setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era
+setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era
 setTxInsReference v txBodyContent = txBodyContent{txInsReference = v}
 
 setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era
@@ -1953,7 +1952,7 @@ fromLedgerTxInsCollateral sbe body =
     sbe
 
 fromLedgerTxInsReference
-  :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era
+  :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era
 fromLedgerTxInsReference sbe txBody =
   caseShelleyToAlonzoOrBabbageEraOnwards
     (const TxInsReferenceNone)
@@ -2453,19 +2452,20 @@ convLanguages witnesses =
     | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
     ]
 
-convReferenceInputs :: TxInsReference build era -> Set (Ledger.TxIn StandardCrypto)
+convReferenceInputs :: TxInsReference era -> Set (Ledger.TxIn StandardCrypto)
 convReferenceInputs txInsReference =
   case txInsReference of
     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 =

cardano-api/src/Cardano/Api.hs

@@ -357,7 +357,8 @@ module Cardano.Api
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , TxVotingProcedures (..)
-  , TxProposalProcedures
+  , mkTxVotingProcedures
+  , TxProposalProcedures (TxProposalProceduresNone)
   , mkTxProposalProcedures
   , getProposalProcedures
 

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 =