From c29187d28d469d2734fffab779bc13e567711f50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 14 Oct 2025 16:16:14 +0300 Subject: [PATCH 1/3] Added DijkstraSubTxBody --- .../src/Cardano/Ledger/Dijkstra/TxBody.hs | 59 +++++++++++++++++-- .../Test/Cardano/Ledger/Dijkstra/Arbitrary.hs | 10 +++- .../Test/Cardano/Ledger/Dijkstra/Examples.hs | 1 + .../Test/Cardano/Ledger/Dijkstra/TreeDiff.hs | 6 +- libs/cardano-data/cardano-data.cabal | 1 - .../testlib/Test/Cardano/Data/Arbitrary.hs | 9 ++- .../src/Cardano/Ledger/Api/Era.hs | 1 + 7 files changed, 73 insertions(+), 14 deletions(-) diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs index c1278057f30..422df4557ea 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs @@ -13,6 +13,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -40,11 +41,13 @@ module Cardano.Ledger.Dijkstra.TxBody ( dtbProposalProcedures, dtbCurrentTreasuryValue, dtbTreasuryDonation, - dtbGuards + dtbGuards, + dtbSubTransactions ), upgradeProposals, upgradeGovAction, DijkstraTxBodyRaw (..), + DijkstraSubTxBodyRaw (..), ) where import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) @@ -110,10 +113,12 @@ import Cardano.Ledger.MemoBytes ( lensMemoRawType, mkMemoizedEra, ) -import Cardano.Ledger.TxIn (TxIn) +import Cardano.Ledger.TxIn (TxId, TxIn) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) import Data.Coerce (coerce) +import Data.Kind (Type) +import qualified Data.OMap.Strict as OMap import Data.OSet.Strict (OSet, decodeOSet) import qualified Data.OSet.Strict as OSet import Data.STRef (newSTRef, readSTRef, writeSTRef) @@ -121,7 +126,7 @@ import Data.Sequence.Strict (StrictSeq) import Data.Set (Set, foldr') import qualified Data.Set as Set import GHC.Generics (Generic) -import Lens.Micro (Lens', to, (^.)) +import Lens.Micro (Lens', lens, to, (^.)) import NoThunks.Class (NoThunks) data DijkstraTxBodyRaw = DijkstraTxBodyRaw @@ -144,6 +149,7 @@ data DijkstraTxBodyRaw = DijkstraTxBodyRaw , dtbrProposalProcedures :: !(OSet.OSet (ProposalProcedure DijkstraEra)) , dtbrCurrentTreasuryValue :: !(StrictMaybe Coin) , dtbrTreasuryDonation :: !Coin + , dtbrSubTransactions :: !(OMap.OMap TxId (SubTxBody DijkstraEra)) } deriving (Generic) @@ -179,6 +185,7 @@ basicDijkstraTxBodyRaw = OSet.empty SNothing mempty + mempty instance DecCBOR DijkstraTxBodyRaw where decCBOR = @@ -273,8 +280,8 @@ encodeTxBodyRaw :: encodeTxBodyRaw DijkstraTxBodyRaw {..} = let ValidityInterval bot top = dtbrVldt in Keyed - ( \i ci ri o cr tc f t c w b -> - DijkstraTxBodyRaw i ci ri o cr tc c w f (ValidityInterval b t) + ( \i ci ri o cr tc f t c w b stxs -> + DijkstraTxBodyRaw i ci ri o cr tc c w f (ValidityInterval b t) stxs ) !> Key 0 (To dtbrSpendInputs) !> Omit null (Key 13 (To dtbrCollateralInputs)) @@ -296,6 +303,7 @@ encodeTxBodyRaw DijkstraTxBodyRaw {..} = !> Omit OSet.null (Key 20 (To dtbrProposalProcedures)) !> encodeKeyedStrictMaybe 21 dtbrCurrentTreasuryValue !> Omit (== mempty) (Key 22 $ To dtbrTreasuryDonation) + !> undefined instance EncCBOR DijkstraTxBodyRaw where encCBOR = encode . encodeTxBodyRaw @@ -328,6 +336,7 @@ pattern DijkstraTxBody :: OSet.OSet (ProposalProcedure DijkstraEra) -> StrictMaybe Coin -> Coin -> + OMap.OMap TxId (SubTxBody DijkstraEra) -> TxBody DijkstraEra pattern DijkstraTxBody { dtbSpendInputs @@ -349,6 +358,7 @@ pattern DijkstraTxBody , dtbProposalProcedures , dtbCurrentTreasuryValue , dtbTreasuryDonation + , dtbSubTransactions } <- ( getMemoRawType -> DijkstraTxBodyRaw @@ -371,6 +381,7 @@ pattern DijkstraTxBody , dtbrProposalProcedures = dtbProposalProcedures , dtbrCurrentTreasuryValue = dtbCurrentTreasuryValue , dtbrTreasuryDonation = dtbTreasuryDonation + , dtbrSubTransactions = dtbSubTransactions } ) where @@ -393,7 +404,8 @@ pattern DijkstraTxBody votingProcedures proposalProcedures currentTreasuryValue - treasuryDonation = + treasuryDonation + subTransactions = mkMemoizedEra @DijkstraEra $ DijkstraTxBodyRaw inputsX @@ -415,6 +427,7 @@ pattern DijkstraTxBody proposalProcedures currentTreasuryValue treasuryDonation + subTransactions {-# COMPLETE DijkstraTxBody #-} @@ -650,9 +663,14 @@ instance ConwayEraTxBody DijkstraEra where {-# INLINE treasuryDonationTxBodyL #-} class ConwayEraTxBody era => DijkstraEraTxBody era where + data SubTxBody era :: Type + guardsTxBodyL :: Lens' (TxBody era) (OSet (Credential Guard)) instance DijkstraEraTxBody DijkstraEra where + newtype SubTxBody DijkstraEra = MkDijkstraSubTxBody DijkstraSubTxBodyRaw + deriving (Generic, Eq, NoThunks, NFData, Show) + {-# INLINE guardsTxBodyL #-} guardsTxBodyL = lensMemoRawType @DijkstraEra dtbrGuards $ @@ -679,3 +697,32 @@ decodeGuards = do Just True -> decCBOR Just False -> KeyHashObj <$> decCBOR decodeOSet decodeElement + +data DijkstraSubTxBodyRaw = DijkstraSubTxBodyRaw + { dstbrSpendInputs :: !(Set TxIn) + , dstbrCollateralInputs :: !(Set TxIn) + , dstbrReferenceInputs :: !(Set TxIn) + , dstbrOutputs :: !(StrictSeq (Sized (TxOut DijkstraEra))) + , dstbrCollateralReturn :: !(StrictMaybe (Sized (TxOut DijkstraEra))) + , dstbrTotalCollateral :: !(StrictMaybe Coin) + , dstbrCerts :: !(OSet.OSet (TxCert DijkstraEra)) + , dstbrWithdrawals :: !Withdrawals + , dstbrFee :: !Coin + , dstbrVldt :: !ValidityInterval + , dstbrMint :: !MultiAsset + , dstbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , dstbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , dstbrNetworkId :: !(StrictMaybe Network) + , dstbrVotingProcedures :: !(VotingProcedures DijkstraEra) + , dstbrProposalProcedures :: !(OSet.OSet (ProposalProcedure DijkstraEra)) + , dstbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , dstbrTreasuryDonation :: !Coin + } + deriving (Generic, Eq, Show) + +instance NoThunks DijkstraSubTxBodyRaw + +instance NFData DijkstraSubTxBodyRaw + +instance OMap.HasOKey TxId (SubTxBody DijkstraEra) where + okeyL = lens undefined undefined diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs index fbff5c155dc..a7d1bfd7f08 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs @@ -22,7 +22,7 @@ import Cardano.Ledger.Dijkstra.PParams (DijkstraPParams, UpgradeDijkstraPParams) import Cardano.Ledger.Dijkstra.Scripts import Cardano.Ledger.Dijkstra.Transition (TransitionConfig (..)) import Cardano.Ledger.Dijkstra.Tx (Tx (..)) -import Cardano.Ledger.Dijkstra.TxBody (TxBody (..)) +import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..), DijkstraSubTxBodyRaw, TxBody (..)) import Cardano.Ledger.Dijkstra.TxCert import Cardano.Ledger.Shelley.Scripts ( pattern RequireSignature, @@ -40,6 +40,13 @@ instance Arbitrary (DijkstraPParams Identity DijkstraEra) where instance Arbitrary (DijkstraPParams StrictMaybe DijkstraEra) where arbitrary = genericArbitraryU +-- TODO we probably want to scale the validity interval and multiasset here as well +instance Arbitrary DijkstraSubTxBodyRaw where + arbitrary = genericArbitraryU + +instance Arbitrary (SubTxBody DijkstraEra) where + arbitrary = genericArbitraryU + instance Arbitrary (TxBody DijkstraEra) where arbitrary = DijkstraTxBody @@ -62,6 +69,7 @@ instance Arbitrary (TxBody DijkstraEra) where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary (UpgradeDijkstraPParams Identity DijkstraEra) where arbitrary = genericArbitraryU diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs index 2b9d356ca8e..034f3fb6bb6 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs @@ -114,6 +114,7 @@ exampleTxBodyDijkstra = mempty (SJust $ Coin 867530900000) -- current treasury value mempty + mempty where MaryValue _ exampleMultiAsset = exampleMultiAssetValue 3 diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs index 3ea89a9febe..1aeeaffb32b 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs @@ -17,7 +17,7 @@ import Cardano.Ledger.Dijkstra.Scripts ( DijkstraNativeScriptRaw, DijkstraPlutusPurpose, ) -import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw) +import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw, DijkstraSubTxBodyRaw, SubTxBody) import Cardano.Ledger.Dijkstra.TxCert import Data.Functor.Identity (Identity) import Test.Cardano.Ledger.Conway.TreeDiff (ToExpr) @@ -38,10 +38,14 @@ instance ToExpr (DijkstraPParams StrictMaybe DijkstraEra) instance ToExpr DijkstraTxBodyRaw +instance ToExpr DijkstraSubTxBodyRaw + instance ToExpr (TxBody DijkstraEra) instance ToExpr (Tx DijkstraEra) +instance ToExpr (SubTxBody DijkstraEra) + instance ToExpr DijkstraDelegCert instance ToExpr (DijkstraTxCert era) diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal index a761ec8ea22..27cfef75e33 100644 --- a/libs/cardano-data/cardano-data.cabal +++ b/libs/cardano-data/cardano-data.cabal @@ -73,7 +73,6 @@ library testlib cardano-ledger-binary:testlib, containers, hspec, - microlens, test-suite cardano-data-tests type: exitcode-stdio-1.0 diff --git a/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs b/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs index c9398d2569e..2a4db0bf946 100644 --- a/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs +++ b/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs @@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Data.Arbitrary (genOSet) where -import Data.Map.Strict qualified as Map import Data.OMap.Strict qualified as OMap import Data.OSet.Strict qualified as OSet -import Lens.Micro (set) import Test.Cardano.Ledger.Binary.Arbitrary () import Test.QuickCheck @@ -17,6 +17,5 @@ instance (Arbitrary a, Ord a) => Arbitrary (OSet.OSet a) where genOSet :: Ord a => Gen a -> Gen (OSet.OSet a) genOSet = fmap OSet.fromFoldable . listOf -instance (Ord v, Arbitrary v, OMap.HasOKey k v, Arbitrary k) => Arbitrary (OMap.OMap k v) where - arbitrary = - fmap OMap.fromFoldable . shuffle . Map.elems . Map.mapWithKey (flip (set OMap.okeyL)) =<< arbitrary +instance (Arbitrary v, OMap.HasOKey k v, Arbitrary k) => Arbitrary (OMap.OMap k v) where + arbitrary = OMap.fromFoldable <$> arbitrary @[v] diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs index 9497d747f62..0833fa4d1f6 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs @@ -622,6 +622,7 @@ instance EraApi DijkstraEra where , dtbProposalProcedures = OSet.mapL upgradeProposals ctbProposalProcedures , dtbVotingProcedures = coerce ctbVotingProcedures , dtbTreasuryDonation = ctbTreasuryDonation + , dtbSubTransactions = mempty } upgradeTxWits atw = From d3ec26bbd541ea5db1eda6c81f6e0b98ee3a84b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 14 Oct 2025 16:29:29 +0300 Subject: [PATCH 2/3] Added EraTxBodyCommon --- .../impl/src/Cardano/Ledger/Allegra/TxBody.hs | 12 ++-- .../impl/src/Cardano/Ledger/Alonzo/TxBody.hs | 15 +++-- .../Cardano/Ledger/Alonzo/Imp/TxInfoSpec.hs | 2 +- .../impl/src/Cardano/Ledger/Babbage/TxBody.hs | 13 ++-- .../impl/src/Cardano/Ledger/Conway/TxBody.hs | 13 ++-- .../src/Cardano/Ledger/Dijkstra/TxBody.hs | 53 +++++++++++++-- .../impl/src/Cardano/Ledger/Mary/TxBody.hs | 13 ++-- .../impl/src/Cardano/Ledger/Shelley/TxBody.hs | 15 +++-- .../src/Cardano/Ledger/Core.hs | 66 ++++++++++--------- 9 files changed, 127 insertions(+), 75 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs index 1fe6c20a30d..abd11266dd9 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs @@ -285,11 +285,7 @@ pattern AllegraTxBody {-# COMPLETE AllegraTxBody #-} -instance EraTxBody AllegraEra where - newtype TxBody AllegraEra = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () AllegraEra)) - deriving newtype (SafeToHash, ToCBOR) - - mkBasicTxBody = mkMemoizedEra @AllegraEra emptyAllegraTxBodyRaw +instance EraTxBodyCommon AllegraEra TxBody where inputsTxBodyL = lensMemoRawType @AllegraEra atbrInputs $ @@ -326,6 +322,12 @@ instance EraTxBody AllegraEra where \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} +instance EraTxBody AllegraEra where + newtype TxBody AllegraEra = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () AllegraEra)) + deriving newtype (SafeToHash, ToCBOR) + + mkBasicTxBody = mkMemoizedEra @AllegraEra emptyAllegraTxBodyRaw + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody instance ShelleyEraTxBody AllegraEra where diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index 80b60e11916..5a2ac474bae 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -197,13 +197,7 @@ deriving instance Show AlonzoTxBodyRaw instance Memoized (TxBody AlonzoEra) where type RawType (TxBody AlonzoEra) = AlonzoTxBodyRaw -instance EraTxBody AlonzoEra where - newtype TxBody AlonzoEra = MkAlonzoTxBody (MemoBytes AlonzoTxBodyRaw) - deriving (ToCBOR, Generic) - deriving newtype (SafeToHash) - - mkBasicTxBody = mkMemoizedEra @AlonzoEra emptyAlonzoTxBodyRaw - +instance EraTxBodyCommon AlonzoEra TxBody where inputsTxBodyL = lensMemoRawType @AlonzoEra atbrInputs $ \txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_} @@ -241,6 +235,13 @@ instance EraTxBody AlonzoEra where \txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_} {-# INLINEABLE certsTxBodyL #-} +instance EraTxBody AlonzoEra where + newtype TxBody AlonzoEra = MkAlonzoTxBody (MemoBytes AlonzoTxBodyRaw) + deriving (ToCBOR, Generic) + deriving newtype (SafeToHash) + + mkBasicTxBody = mkMemoizedEra @AlonzoEra emptyAlonzoTxBodyRaw + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody instance ShelleyEraTxBody AlonzoEra where diff --git a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Imp/TxInfoSpec.hs b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Imp/TxInfoSpec.hs index 13db340d302..f822fa15302 100644 --- a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Imp/TxInfoSpec.hs +++ b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Imp/TxInfoSpec.hs @@ -8,7 +8,7 @@ import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Core ( EraTx (..), EraTxBody (..), - EraTxOut (..), + EraTxOut (..), EraTxBodyCommon (..), ) import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo (..), LedgerTxInfo (..)) import Cardano.Ledger.BaseTypes diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs index 2f0d1008573..21ba49a3871 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs @@ -238,12 +238,7 @@ allSizedOutputsBabbageTxBodyF = SJust collTxOut -> txOuts |> collTxOut {-# INLINEABLE allSizedOutputsBabbageTxBodyF #-} -instance EraTxBody BabbageEra where - newtype TxBody BabbageEra = MkBabbageTxBody (MemoBytes BabbageTxBodyRaw) - deriving newtype (Generic, SafeToHash, ToCBOR) - - mkBasicTxBody = mkMemoizedEra @BabbageEra basicBabbageTxBodyRaw - +instance EraTxBodyCommon BabbageEra TxBody where inputsTxBodyL = lensMemoRawType @BabbageEra btbrInputs $ \txBodyRaw inputs -> txBodyRaw {btbrInputs = inputs} {-# INLINE inputsTxBodyL #-} @@ -277,6 +272,12 @@ instance EraTxBody BabbageEra where lensMemoRawType @BabbageEra btbrCerts $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} {-# INLINE certsTxBodyL #-} +instance EraTxBody BabbageEra where + newtype TxBody BabbageEra = MkBabbageTxBody (MemoBytes BabbageTxBodyRaw) + deriving newtype (Generic, SafeToHash, ToCBOR) + + mkBasicTxBody = mkMemoizedEra @BabbageEra basicBabbageTxBodyRaw + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody instance ShelleyEraTxBody BabbageEra where diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs index 4b8331bf4f4..81c1fb0be44 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs @@ -282,12 +282,7 @@ basicConwayTxBodyRaw = SNothing mempty -instance EraTxBody ConwayEra where - newtype TxBody ConwayEra = MkConwayTxBody (MemoBytes ConwayTxBodyRaw) - deriving (Generic, SafeToHash, ToCBOR) - - mkBasicTxBody = mkConwayTxBody - +instance EraTxBodyCommon ConwayEra TxBody where inputsTxBodyL = lensMemoRawType @ConwayEra ctbrSpendInputs $ \txb x -> txb {ctbrSpendInputs = x} {-# INLINE inputsTxBodyL #-} @@ -324,6 +319,12 @@ instance EraTxBody ConwayEra where getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) +instance EraTxBody ConwayEra where + newtype TxBody ConwayEra = MkConwayTxBody (MemoBytes ConwayTxBodyRaw) + deriving (Generic, SafeToHash, ToCBOR) + + mkBasicTxBody = mkConwayTxBody + -- ========================================== -- Deposits and Refunds for Conway TxBody diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs index 422df4557ea..f32f98693c6 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs @@ -446,12 +446,44 @@ instance DecCBOR (Annotator DijkstraTxBodyRaw) where deriving via Mem DijkstraTxBodyRaw instance DecCBOR (Annotator (TxBody DijkstraEra)) -instance EraTxBody DijkstraEra where - newtype TxBody DijkstraEra = MkDijkstraTxBody (MemoBytes DijkstraTxBodyRaw) - deriving (Generic, SafeToHash, ToCBOR) +instance EraTxBodyCommon DijkstraEra TxBody where + inputsTxBodyL = lensMemoRawType @DijkstraEra dtbrSpendInputs $ + \txb x -> txb {dtbrSpendInputs = x} + {-# INLINE inputsTxBodyL #-} - mkBasicTxBody = mkMemoizedEra @DijkstraEra basicDijkstraTxBodyRaw + outputsTxBodyL = + lensMemoRawType @DijkstraEra (fmap sizedValue . dtbrOutputs) $ + \txb x -> txb {dtbrOutputs = mkSized (eraProtVerLow @DijkstraEra) <$> x} + {-# INLINE outputsTxBodyL #-} + feeTxBodyL = lensMemoRawType @DijkstraEra dtbrFee (\txb x -> txb {dtbrFee = x}) + {-# INLINE feeTxBodyL #-} + + auxDataHashTxBodyL = lensMemoRawType @DijkstraEra dtbrAuxDataHash $ + \txb x -> txb {dtbrAuxDataHash = x} + {-# INLINE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = babbageAllInputsTxBodyF + {-# INLINE allInputsTxBodyF #-} + + withdrawalsTxBodyL = lensMemoRawType @DijkstraEra dtbrWithdrawals $ + \txb x -> txb {dtbrWithdrawals = x} + {-# INLINE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType @DijkstraEra (OSet.toStrictSeq . dtbrCerts) $ + \txb x -> txb {dtbrCerts = OSet.fromStrictSeq x} + {-# INLINE certsTxBodyL #-} + + getTotalDepositsTxBody = dijkstraTotalDepositsTxBody + + getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = + getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) + +instance EraTxBodyCommon DijkstraEra SubTxBody where inputsTxBodyL = lensMemoRawType @DijkstraEra dtbrSpendInputs $ \txb x -> txb {dtbrSpendInputs = x} {-# INLINE inputsTxBodyL #-} @@ -488,6 +520,12 @@ instance EraTxBody DijkstraEra where getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) +instance EraTxBody DijkstraEra where + newtype TxBody DijkstraEra = MkDijkstraTxBody (MemoBytes DijkstraTxBodyRaw) + deriving (Generic, SafeToHash, ToCBOR) + + mkBasicTxBody = mkMemoizedEra @DijkstraEra basicDijkstraTxBodyRaw + upgradeGovAction :: forall era. (AlonzoEraPParams era, EraPParams (PreviousEra era)) => @@ -662,7 +700,12 @@ instance ConwayEraTxBody DijkstraEra where \txb x -> txb {dtbrTreasuryDonation = x} {-# INLINE treasuryDonationTxBodyL #-} -class ConwayEraTxBody era => DijkstraEraTxBody era where +class + ( ConwayEraTxBody era + , EraTxBodyCommon era SubTxBody + ) => + DijkstraEraTxBody era + where data SubTxBody era :: Type guardsTxBodyL :: Lens' (TxBody era) (OSet (Credential Guard)) diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs index f1a20014435..b71a2bcbdd3 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs @@ -171,12 +171,7 @@ pattern MaryTxBody {-# COMPLETE MaryTxBody #-} -instance EraTxBody MaryEra where - newtype TxBody MaryEra = MkMaryTxBody (MemoBytes MaryTxBodyRaw) - deriving newtype (SafeToHash, ToCBOR) - - mkBasicTxBody = mkMemoizedEra @MaryEra emptyAllegraTxBodyRaw - +instance EraTxBodyCommon MaryEra TxBody where inputsTxBodyL = lensMemoRawType @MaryEra atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} @@ -208,6 +203,12 @@ instance EraTxBody MaryEra where lensMemoRawType @MaryEra atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} +instance EraTxBody MaryEra where + newtype TxBody MaryEra = MkMaryTxBody (MemoBytes MaryTxBodyRaw) + deriving newtype (SafeToHash, ToCBOR) + + mkBasicTxBody = mkMemoizedEra @MaryEra emptyAllegraTxBodyRaw + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody instance ShelleyEraTxBody MaryEra where diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index 43992bdb97a..a722e83a735 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -190,13 +190,7 @@ instance Memoized (TxBody ShelleyEra) where instance EqRaw (TxBody ShelleyEra) -instance EraTxBody ShelleyEra where - newtype TxBody ShelleyEra = MkShelleyTxBody (MemoBytes ShelleyTxBodyRaw) - deriving (Generic) - deriving newtype (SafeToHash, ToCBOR) - - mkBasicTxBody = mkMemoizedEra @ShelleyEra basicShelleyTxBodyRaw - +instance EraTxBodyCommon ShelleyEra TxBody where spendableInputsTxBodyF = inputsTxBodyL {-# INLINE spendableInputsTxBodyF #-} @@ -233,6 +227,13 @@ instance EraTxBody ShelleyEra where \txBodyRaw certs -> txBodyRaw {stbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} +instance EraTxBody ShelleyEra where + newtype TxBody ShelleyEra = MkShelleyTxBody (MemoBytes ShelleyTxBodyRaw) + deriving (Generic) + deriving newtype (SafeToHash, ToCBOR) + + mkBasicTxBody = mkMemoizedEra @ShelleyEra basicShelleyTxBodyRaw + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody instance ShelleyEraTxBody ShelleyEra where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index c796470568b..403bc1ae110 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -1,9 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -32,6 +32,7 @@ module Cardano.Ledger.Core ( compactCoinTxOutL, isAdaOnlyTxOutF, EraTxBody (..), + EraTxBodyCommon (..), txIdTxBody, EraTxAuxData (..), hashTxAuxData, @@ -183,48 +184,28 @@ class Int -> Coin -class - ( EraTxOut era - , EraTxCert era - , EraPParams era - , HashAnnotated (TxBody era) EraIndependentTxBody - , DecCBOR (Annotator (TxBody era)) - , EncCBOR (TxBody era) - , ToCBOR (TxBody era) - , NoThunks (TxBody era) - , NFData (TxBody era) - , Show (TxBody era) - , Eq (TxBody era) - , EqRaw (TxBody era) - ) => - EraTxBody era - where - -- | The body of a transaction. - data TxBody era - - mkBasicTxBody :: TxBody era - - inputsTxBodyL :: Lens' (TxBody era) (Set TxIn) +class EraTxCert era => EraTxBodyCommon era tx where + inputsTxBodyL :: Lens' (tx era) (Set TxIn) - outputsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxOut era)) + outputsTxBodyL :: Lens' (tx era) (StrictSeq (TxOut era)) - feeTxBodyL :: Lens' (TxBody era) Coin + feeTxBodyL :: Lens' (tx era) Coin - withdrawalsTxBodyL :: Lens' (TxBody era) Withdrawals + withdrawalsTxBodyL :: Lens' (tx era) Withdrawals - auxDataHashTxBodyL :: Lens' (TxBody era) (StrictMaybe TxAuxDataHash) + auxDataHashTxBodyL :: Lens' (tx era) (StrictMaybe TxAuxDataHash) -- | This getter will produce all inputs from the UTxO map that this transaction might -- spend, which ones will depend on the validity of the transaction itself. Starting in -- Alonzo this will include collateral inputs. - spendableInputsTxBodyF :: SimpleGetter (TxBody era) (Set TxIn) + spendableInputsTxBodyF :: SimpleGetter (tx era) (Set TxIn) -- | This getter will produce all inputs from the UTxO map that this transaction is -- referencing, even if some of them cannot be spent by the transaction. For example -- starting with Babbage era it will also include reference inputs. - allInputsTxBodyF :: SimpleGetter (TxBody era) (Set TxIn) + allInputsTxBodyF :: SimpleGetter (tx era) (Set TxIn) - certsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxCert era)) + certsTxBodyL :: Lens' (tx era) (StrictSeq (TxCert era)) -- | Compute the total deposits from the certificates in a TxBody. -- @@ -233,7 +214,7 @@ class PParams era -> -- | Check whether stake pool is registered or not (KeyHash 'StakePool -> Bool) -> - TxBody era -> + tx era -> Coin getTotalDepositsTxBody pp isPoolRegisted txBody = getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) @@ -247,11 +228,32 @@ class (Credential 'Staking -> Maybe Coin) -> -- | Lookup current deposit for DRep credential if one is registered (Credential 'DRepRole -> Maybe Coin) -> - TxBody era -> + tx era -> Coin getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) +class + ( EraTxBodyCommon era TxBody + , EraTxOut era + , EraPParams era + , HashAnnotated (TxBody era) EraIndependentTxBody + , DecCBOR (Annotator (TxBody era)) + , EncCBOR (TxBody era) + , ToCBOR (TxBody era) + , NoThunks (TxBody era) + , NFData (TxBody era) + , Show (TxBody era) + , Eq (TxBody era) + , EqRaw (TxBody era) + ) => + EraTxBody era + where + -- | The body of a transaction. + data TxBody era + + mkBasicTxBody :: TxBody era + -- | This function is not used in the ledger rules. It is only used by the downstream -- tooling to figure out how many witnesses should be supplied for Genesis keys. getGenesisKeyHashCountTxBody :: TxBody era -> Int From 6bd2d1a3cbe1e4c487b1f43d59ed0f36559072d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 14 Oct 2025 16:58:40 +0300 Subject: [PATCH 3/3] Added EraTxBodyCommon instances --- .../Cardano/Ledger/Conway/Imp/UtxowSpec.hs | 1 + .../src/Cardano/Ledger/Dijkstra/TxBody.hs | 25 +++++++------------ .../src/Cardano/Ledger/Api/Tx/Body.hs | 1 + .../SpecTranslate/Conway/Ledger.hs | 1 + .../Test/Cardano/Ledger/Examples/AlonzoAPI.hs | 9 ++++++- 5 files changed, 20 insertions(+), 17 deletions(-) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxowSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxowSpec.hs index dabb64fc585..9eded6f5ca9 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxowSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxowSpec.hs @@ -25,6 +25,7 @@ import Cardano.Ledger.Conway.Core ( EraIndependentScriptIntegrity, EraTx (..), EraTxBody (..), + EraTxBodyCommon (..), EraTxOut (..), EraTxWits (..), InjectRuleFailure (..), diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs index f32f98693c6..98e2234949b 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs @@ -484,38 +484,31 @@ instance EraTxBodyCommon DijkstraEra TxBody where getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) instance EraTxBodyCommon DijkstraEra SubTxBody where - inputsTxBodyL = lensMemoRawType @DijkstraEra dtbrSpendInputs $ - \txb x -> txb {dtbrSpendInputs = x} + inputsTxBodyL = undefined {-# INLINE inputsTxBodyL #-} - outputsTxBodyL = - lensMemoRawType @DijkstraEra (fmap sizedValue . dtbrOutputs) $ - \txb x -> txb {dtbrOutputs = mkSized (eraProtVerLow @DijkstraEra) <$> x} + outputsTxBodyL = undefined {-# INLINE outputsTxBodyL #-} - feeTxBodyL = lensMemoRawType @DijkstraEra dtbrFee (\txb x -> txb {dtbrFee = x}) + feeTxBodyL = undefined {-# INLINE feeTxBodyL #-} - auxDataHashTxBodyL = lensMemoRawType @DijkstraEra dtbrAuxDataHash $ - \txb x -> txb {dtbrAuxDataHash = x} + auxDataHashTxBodyL = undefined {-# INLINE auxDataHashTxBodyL #-} - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + spendableInputsTxBodyF = undefined {-# INLINE spendableInputsTxBodyF #-} - allInputsTxBodyF = babbageAllInputsTxBodyF + allInputsTxBodyF = undefined {-# INLINE allInputsTxBodyF #-} - withdrawalsTxBodyL = lensMemoRawType @DijkstraEra dtbrWithdrawals $ - \txb x -> txb {dtbrWithdrawals = x} + withdrawalsTxBodyL = undefined {-# INLINE withdrawalsTxBodyL #-} - certsTxBodyL = - lensMemoRawType @DijkstraEra (OSet.toStrictSeq . dtbrCerts) $ - \txb x -> txb {dtbrCerts = OSet.fromStrictSeq x} + certsTxBodyL = undefined {-# INLINE certsTxBodyL #-} - getTotalDepositsTxBody = dijkstraTotalDepositsTxBody + getTotalDepositsTxBody = undefined getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Body.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Body.hs index 43d6d1d7fbc..5cdf50d867b 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Body.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Body.hs @@ -106,6 +106,7 @@ import Cardano.Ledger.Conway.Governance ( import Cardano.Ledger.Conway.TxBody (ConwayEraTxBody (..)) import Cardano.Ledger.Core ( EraTxBody (..), + EraTxBodyCommon (..), PParams, TxAuxDataHash (..), Value, diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Ledger.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Ledger.hs index a5f5f12d6d4..4f68738313e 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Ledger.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Ledger.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.Conway.Core ( EraPParams (..), EraTx (..), EraTxBody (..), + EraTxBodyCommon (..), ScriptHash, txIdTx, ) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoAPI.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoAPI.hs index 47e0c19ade0..5bc32a40a4d 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoAPI.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoAPI.hs @@ -38,7 +38,14 @@ import Cardano.Ledger.Conway.Core ( ppMinFeeAL, pattern SpendingPurpose, ) -import Cardano.Ledger.Core (EraScript (..), EraTx (..), EraTxBody (..), EraTxWits (..), hashScript) +import Cardano.Ledger.Core ( + EraScript (..), + EraTx (..), + EraTxBody (..), + EraTxBodyCommon (..), + EraTxWits (..), + hashScript, + ) import Cardano.Ledger.Plutus (ExUnits (..)) import Cardano.Ledger.Plutus.Data (Data (..)) import Cardano.Ledger.Plutus.Language (Language (..))