From 061ebe1b6e0df87f31d90f2d22dc34e03abc4cc8 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 2 Aug 2024 15:08:38 +0200 Subject: [PATCH] add more fix --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 4 +- cardano-api/internal/Cardano/Api/Fees.hs | 8 ++-- .../Api/Governance/Actions/VotingProcedure.hs | 2 + cardano-api/internal/Cardano/Api/Orphans.hs | 5 ++ cardano-api/internal/Cardano/Api/Tx/Body.hs | 46 +++++++++---------- cardano-api/src/Cardano/Api.hs | 3 +- .../Test/Cardano/Api/Typed/TxBody.hs | 10 ++-- 7 files changed, 43 insertions(+), 35 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index bfcdab915f..6f847275c1 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/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)) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index dc9d7f66e5..3b0cf4378c 100644 --- 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 index dba360230a..62bde7f0e9 100644 --- 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 index 4898ec6df2..49d0b3897d 100644 --- 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 index 12a6468543..6998094ce0 100644 --- 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 @@ -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,18 +1233,18 @@ 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 @@ -1253,8 +1252,8 @@ mkTxVotingProcedures votingProcedures = do -> 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 = diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 7f013e8949..ed963ae2f1 100644 --- 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 index b9f7d33622..60adb27e09 100644 --- 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 =