diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index d8177d8bdf9..c39c5e47121 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -2,6 +2,11 @@ ## 1.9.0.0 +* Add `invalidBeforeL`, `invalidHereAfterL` +* Add `basicAllegraTxBody` +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Remove deprecated `timelockScriptsTxAuxDataL` ### `testlib` diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 62bf7fe40d7..8360cc832b7 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -127,6 +127,7 @@ library testlib microlens, small-steps, text, + tree-diff, executable huddle-cddl main-is: Main.hs diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs index 511203e23b5..27e00f0036d 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs @@ -24,6 +24,9 @@ import Cardano.Ledger.Shelley.Rules instance EraGenesis AllegraEra +instance EraTxLevel AllegraEra where + type STxLevel l AllegraEra = STxTopLevel l AllegraEra + -------------------------------------------------------------------------------- -- Core instances -------------------------------------------------------------------------------- diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs index 200b86becd4..dcd587bc302 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs @@ -242,7 +242,7 @@ utxoTransition = do validateOutsideValidityIntervalUTxO :: AllegraEraTxBody era => SlotNo -> - TxBody era -> + TxBody l era -> Test (AllegraUtxoPredFailure era) validateOutsideValidityIntervalUTxO slot txb = failureUnless (inInterval slot (txb ^. vldtTxBodyL)) $ @@ -314,7 +314,7 @@ instance STS (AllegraUTXO era) where type State (AllegraUTXO era) = Shelley.UTxOState era - type Signal (AllegraUTXO era) = Tx era + type Signal (AllegraUTXO era) = Tx TopTx era type Environment (AllegraUTXO era) = Shelley.UtxoEnv era type BaseM (AllegraUTXO era) = ShelleyBase type PredicateFailure (AllegraUTXO era) = AllegraUtxoPredFailure era diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxow.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxow.hs index 2051565c8cd..11df4d27a61 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxow.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxow.hs @@ -58,7 +58,7 @@ instance Embed (EraRule "UTXO" era) (AllegraUTXOW era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , EraRule "UTXOW" era ~ AllegraUTXOW era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , EraCertState era @@ -66,7 +66,7 @@ instance STS (AllegraUTXOW era) where type State (AllegraUTXOW era) = UTxOState era - type Signal (AllegraUTXOW era) = Tx era + type Signal (AllegraUTXOW era) = Tx TopTx era type Environment (AllegraUTXOW era) = UtxoEnv era type BaseM (AllegraUTXOW era) = ShelleyBase type PredicateFailure (AllegraUTXOW era) = ShelleyUtxowPredFailure era diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs index a96c8153d49..d1be2094a6a 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs @@ -55,6 +55,8 @@ module Cardano.Ledger.Allegra.Scripts ( upgradeMultiSig, lteNegInfty, ltePosInfty, + invalidBeforeL, + invalidHereAfterL, ) where import Cardano.Ledger.Allegra.Era (AllegraEra) @@ -109,6 +111,7 @@ import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|))) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set (Set, member) import GHC.Generics (Generic) +import Lens.Micro (Lens', lens) import NoThunks.Class (NoThunks (..)) -- | ValidityInterval is a half open interval. Closed on the bottom, open on the top. @@ -119,6 +122,14 @@ data ValidityInterval = ValidityInterval } deriving (Ord, Eq, Generic, Show, NoThunks, NFData) +-- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. +invalidBeforeL :: Lens' ValidityInterval (StrictMaybe SlotNo) +invalidBeforeL = lens invalidBefore (\vi before -> vi {invalidBefore = before}) + +-- | Lens to access the 'invalidHereAfter' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. +invalidHereAfterL :: Lens' ValidityInterval (StrictMaybe SlotNo) +invalidHereAfterL = lens invalidHereafter (\vi hereAfter -> vi {invalidHereafter = hereAfter}) + encodeVI :: ValidityInterval -> Encode ('Closed 'Dense) ValidityInterval encodeVI (ValidityInterval f t) = Rec ValidityInterval !> To f !> To t diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs index 25bea060c8f..43a8f602885 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -71,8 +71,8 @@ instance TranslateEra AllegraEra NewEpochState where stashedAVVMAddresses = () } -instance TranslateEra AllegraEra Tx where - type TranslationError AllegraEra Tx = DecoderError +instance TranslateEra AllegraEra (Tx TopTx) where + type TranslationError AllegraEra (Tx TopTx) = DecoderError translateEra _ctx = translateEraThroughCBOR "ShelleyTx" -------------------------------------------------------------------------------- diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs index 493ea65cb4b..85a8b3c09d4 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs @@ -3,7 +3,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -24,7 +26,9 @@ import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR, ToCBOR) import Cardano.Ledger.Core ( EraTx (..), EraTxWits (..), + HasEraTxLevel (..), NativeScript, + STxTopLevel (..), ) import Cardano.Ledger.Keys.WitVKey (witVKeyHash) import Cardano.Ledger.MemoBytes (EqRaw (..)) @@ -41,6 +45,7 @@ import Cardano.Ledger.Shelley.Tx ( ) import Control.DeepSeq (NFData) import qualified Data.Set as Set (map) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro (Lens', lens, (^.)) import NoThunks.Class (NoThunks) @@ -48,7 +53,7 @@ import NoThunks.Class (NoThunks) -- ======================================== instance EraTx AllegraEra where - newtype Tx AllegraEra = MkAllegraTx {unAllegraTx :: ShelleyTx AllegraEra} + newtype Tx t AllegraEra = MkAllegraTx {unAllegraTx :: ShelleyTx t AllegraEra} deriving newtype (Eq, NFData, NoThunks, Show, ToCBOR, EncCBOR) deriving (Generic) @@ -71,13 +76,16 @@ instance EraTx AllegraEra where getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx -instance EqRaw (Tx AllegraEra) where +instance HasEraTxLevel Tx AllegraEra where + toSTxLevel (MkAllegraTx ShelleyTx {}) = STopTxOnly @AllegraEra + +instance EqRaw (Tx t AllegraEra) where eqRaw = shelleyTxEqRaw -instance DecCBOR (Annotator (Tx AllegraEra)) where +instance Typeable t => DecCBOR (Annotator (Tx t AllegraEra)) where decCBOR = fmap MkAllegraTx <$> decCBOR -allegraTxL :: Lens' (Tx AllegraEra) (ShelleyTx AllegraEra) +allegraTxL :: Lens' (Tx t AllegraEra) (ShelleyTx t AllegraEra) allegraTxL = lens unAllegraTx (\x y -> x {unAllegraTx = y}) -- ======================================================= @@ -87,7 +95,7 @@ allegraTxL = lens unAllegraTx (\x y -> x {unAllegraTx = y}) validateTimelock :: (EraTx era, AllegraEraTxBody era, AllegraEraScript era, NativeScript era ~ Timelock era) => - Tx era -> NativeScript era -> Bool + Tx t era -> NativeScript era -> Bool validateTimelock tx timelock = evalTimelock vhks (tx ^. bodyTxL . vldtTxBodyL) timelock where vhks = Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs index 1fe6c20a30d..4c18ee5053c 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs @@ -4,14 +4,18 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} @@ -31,6 +35,7 @@ module Cardano.Ledger.Allegra.TxBody ( atbValidityInterval, atbWithdrawals ), + basicAllegraTxBody, emptyAllegraTxBodyRaw, AllegraTxBodyRaw (..), StrictMaybe (..), @@ -72,71 +77,102 @@ import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.PParams (Update (..)) import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) import Cardano.Ledger.TxIn (TxIn (..)) -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..), deepseq) import qualified Data.Map.Strict as Map import Data.Sequence.Strict (StrictSeq, fromList) import Data.Set (Set, empty) +import Data.Typeable import GHC.Generics (Generic) import Lens.Micro -import NoThunks.Class (NoThunks (..)) +import NoThunks.Class (InspectHeap (..), NoThunks (..)) class EraTxBody era => AllegraEraTxBody era where - vldtTxBodyL :: Lens' (TxBody era) ValidityInterval + vldtTxBodyL :: Lens' (TxBody l era) ValidityInterval -- ======================================================= -data AllegraTxBodyRaw ma era = AllegraTxBodyRaw - { atbrInputs :: !(Set TxIn) - , atbrOutputs :: !(StrictSeq (TxOut era)) - , atbrCerts :: !(StrictSeq (TxCert era)) - , atbrWithdrawals :: !Withdrawals - , atbrFee :: !Coin - , atbrValidityInterval :: !ValidityInterval - , atbrUpdate :: !(StrictMaybe (Update era)) - , atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - , atbrMint :: !ma - } - -deriving instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era), NFData ma) => - NFData (AllegraTxBodyRaw ma era) +data AllegraTxBodyRaw ma l era where + AllegraTxBodyRaw :: + { atbrInputs :: !(Set TxIn) + , atbrOutputs :: !(StrictSeq (TxOut era)) + , atbrCerts :: !(StrictSeq (TxCert era)) + , atbrWithdrawals :: !Withdrawals + , atbrFee :: !Coin + , atbrValidityInterval :: !ValidityInterval + , atbrUpdate :: !(StrictMaybe (Update era)) + , atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , atbrMint :: !ma + } -> + AllegraTxBodyRaw ma TopTx era deriving instance (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era), Eq ma) => - Eq (AllegraTxBodyRaw ma era) + Eq (AllegraTxBodyRaw ma l era) deriving instance (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era), Show ma) => - Show (AllegraTxBodyRaw ma era) + Show (AllegraTxBodyRaw ma l era) -deriving instance Generic (AllegraTxBodyRaw ma era) +instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era), NFData ma) => + NFData (AllegraTxBodyRaw ma l era) + where + rnf AllegraTxBodyRaw {..} = + atbrInputs `deepseq` + atbrOutputs `deepseq` + atbrCerts `deepseq` + atbrWithdrawals `deepseq` + atbrFee `deepseq` + atbrValidityInterval `deepseq` + atbrUpdate `deepseq` + atbrAuxDataHash `deepseq` + rnf atbrMint -deriving instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era), NoThunks ma) => - NoThunks (AllegraTxBodyRaw ma era) +deriving via + InspectHeap (AllegraTxBodyRaw ma l era) + instance + (Typeable era, Typeable ma, Typeable l) => NoThunks (AllegraTxBodyRaw ma l era) -instance (DecCBOR ma, Monoid ma, AllegraEraTxBody era) => DecCBOR (AllegraTxBodyRaw ma era) where +instance + ( DecCBOR ma + , Monoid ma + , AllegraEraTxBody era + , HasEraTxLevel (AllegraTxBodyRaw ma) era + , STxLevel l era ~ STxTopLevel l era + , Typeable l + ) => + DecCBOR (AllegraTxBodyRaw ma l era) + where decCBOR = - decode - ( SparseKeyed + mkSTxTopLevelM @l $ + decode $ + SparseKeyed "AllegraTxBodyRaw" emptyAllegraTxBodyRaw bodyFields [(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrFee")] - ) instance - (DecCBOR m, Monoid m, AllegraEraTxBody era) => - DecCBOR (Annotator (AllegraTxBodyRaw m era)) + ( DecCBOR ma + , Monoid ma + , AllegraEraTxBody era + , HasEraTxLevel (AllegraTxBodyRaw ma) era + , STxLevel l era ~ STxTopLevel l era + , Typeable l + ) => + DecCBOR (Annotator (AllegraTxBodyRaw ma l era)) where decCBOR = pure <$> decCBOR +instance HasEraTxLevel (AllegraTxBodyRaw m) AllegraEra where + toSTxLevel AllegraTxBodyRaw {} = STopTxOnly @AllegraEra + -- Sparse encodings of AllegraTxBodyRaw, the key values are fixed by backward compatibility -- concerns as we want the ShelleyTxBody to deserialise as AllegraTxBody. -- txXparse and bodyFields should be Duals, visual inspection helps ensure this. instance (EraTxOut era, EraTxCert era, Eq ma, EncCBOR ma, Monoid ma) => - EncCBOR (AllegraTxBodyRaw ma era) + EncCBOR (AllegraTxBodyRaw ma l era) where encCBOR (AllegraTxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frge) = encode $ @@ -155,7 +191,8 @@ instance !> encodeKeyedStrictMaybe 8 bot !> Omit (== mempty) (Key 9 (To frge)) -bodyFields :: (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma era) +bodyFields :: + (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma TopTx era) bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From bodyFields 2 = field (\x tx -> tx {atbrFee = x}) From @@ -184,48 +221,58 @@ bodyFields 8 = bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From bodyFields n = invalidField n -emptyAllegraTxBodyRaw :: Monoid ma => AllegraTxBodyRaw ma era +basicAllegraTxBody :: + forall era l ma. + ( EraTxBody era + , Memoized (TxBody l era) + , RawType (TxBody l era) ~ AllegraTxBodyRaw ma l era + , HasEraTxLevel (AllegraTxBodyRaw ma) era + , STxLevel l era ~ STxTopLevel l era + , Typeable l + , EncCBOR ma + , Monoid ma + , Eq ma + ) => + TxBody l era +basicAllegraTxBody = + mkMemoizedEra @era $ asSTxTopLevel (emptyAllegraTxBodyRaw @ma @era) + +emptyAllegraTxBodyRaw :: Monoid ma => AllegraTxBodyRaw ma TopTx era emptyAllegraTxBodyRaw = AllegraTxBodyRaw - empty - (fromList []) - (fromList []) - (Withdrawals Map.empty) - (Coin 0) - (ValidityInterval SNothing SNothing) - SNothing - SNothing - mempty - --- =========================================================================== --- Wrap it all up in a newtype, hiding the insides with a pattern construtor. - -instance Memoized (TxBody AllegraEra) where - type RawType (TxBody AllegraEra) = AllegraTxBodyRaw () AllegraEra + { atbrInputs = empty + , atbrOutputs = fromList [] + , atbrCerts = fromList [] + , atbrWithdrawals = Withdrawals Map.empty + , atbrFee = Coin 0 + , atbrValidityInterval = ValidityInterval SNothing SNothing + , atbrUpdate = SNothing + , atbrAuxDataHash = SNothing + , atbrMint = mempty + } + +instance Memoized (TxBody l AllegraEra) where + type RawType (TxBody l AllegraEra) = AllegraTxBodyRaw () l AllegraEra deriving via - Mem (AllegraTxBodyRaw () AllegraEra) + Mem (AllegraTxBodyRaw () l AllegraEra) instance - DecCBOR (Annotator (TxBody AllegraEra)) + Typeable l => DecCBOR (Annotator (TxBody l AllegraEra)) -deriving instance Eq (TxBody AllegraEra) +deriving instance Eq (TxBody l AllegraEra) -deriving instance Show (TxBody AllegraEra) +deriving instance Show (TxBody l AllegraEra) -deriving instance Generic (TxBody AllegraEra) +deriving instance Generic (TxBody l AllegraEra) -deriving newtype instance NoThunks (TxBody AllegraEra) +type instance MemoHashIndex (AllegraTxBodyRaw c l era) = EraIndependentTxBody -deriving newtype instance NFData (TxBody AllegraEra) - --- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody AllegraEra) - -type instance MemoHashIndex (AllegraTxBodyRaw c era) = EraIndependentTxBody - -instance HashAnnotated (TxBody AllegraEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l AllegraEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash +instance HasEraTxLevel TxBody AllegraEra where + toSTxLevel = toSTxLevel . getMemoRawType + -- | A pattern to keep the newtype and the MemoBytes hidden pattern AllegraTxBody :: (EraTxOut AllegraEra, EraTxCert AllegraEra) => @@ -237,7 +284,7 @@ pattern AllegraTxBody :: ValidityInterval -> StrictMaybe (Update AllegraEra) -> StrictMaybe TxAuxDataHash -> - TxBody AllegraEra + TxBody TopTx AllegraEra pattern AllegraTxBody { atbInputs , atbOutputs @@ -286,19 +333,19 @@ pattern AllegraTxBody {-# COMPLETE AllegraTxBody #-} instance EraTxBody AllegraEra where - newtype TxBody AllegraEra = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () AllegraEra)) - deriving newtype (SafeToHash, ToCBOR) + newtype TxBody l AllegraEra = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () l AllegraEra)) + deriving newtype (SafeToHash, ToCBOR, EncCBOR, NoThunks, NFData) - mkBasicTxBody = mkMemoizedEra @AllegraEra emptyAllegraTxBodyRaw + mkBasicTxBody = basicAllegraTxBody @AllegraEra inputsTxBodyL = - lensMemoRawType @AllegraEra atbrInputs $ - \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrInputs} -> atbrInputs) $ + \txBodyRaw@AllegraTxBodyRaw {} inputs -> txBodyRaw {atbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @AllegraEra atbrOutputs $ - \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrOutputs} -> atbrOutputs) $ + \txBodyRaw@AllegraTxBodyRaw {} outputs -> txBodyRaw {atbrOutputs = outputs} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = @@ -306,8 +353,8 @@ instance EraTxBody AllegraEra where {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType @AllegraEra atbrAuxDataHash $ - \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrAuxDataHash} -> atbrAuxDataHash) $ + \txBodyRaw@AllegraTxBodyRaw {} auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} spendableInputsTxBodyF = inputsTxBodyL @@ -317,13 +364,13 @@ instance EraTxBody AllegraEra where {-# INLINEABLE allInputsTxBodyF #-} withdrawalsTxBodyL = - lensMemoRawType @AllegraEra atbrWithdrawals $ - \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrWithdrawals} -> atbrWithdrawals) $ + \txBodyRaw@AllegraTxBodyRaw {} withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @AllegraEra atbrCerts $ - \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrCerts} -> atbrCerts) $ + \txBodyRaw@AllegraTxBodyRaw {} certs -> txBodyRaw {atbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -339,8 +386,8 @@ instance ShelleyEraTxBody AllegraEra where instance AllegraEraTxBody AllegraEra where vldtTxBodyL = - lensMemoRawType @AllegraEra atbrValidityInterval $ - \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} + lensMemoRawType @AllegraEra (\AllegraTxBodyRaw {atbrValidityInterval} -> atbrValidityInterval) $ + \txBodyRaw@AllegraTxBodyRaw {} vldt -> txBodyRaw {atbrValidityInterval = vldt} {-# INLINEABLE vldtTxBodyL #-} -instance EqRaw (TxBody AllegraEra) +instance EqRaw (TxBody l AllegraEra) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/UTxO.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/UTxO.hs index 71d4869934c..75b3319647e 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/UTxO.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/UTxO.hs @@ -28,7 +28,8 @@ instance EraUTxO AllegraEra where getConsumedValue pp lookupKeyDeposit _ = getConsumedCoin pp lookupKeyDeposit - getProducedValue = shelleyProducedValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (shelleyProducedValue pp isRegPoolId) getScriptsProvided _ tx = ScriptsProvided (tx ^. witsTxL . scriptTxWitsL) diff --git a/eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/Binary/CddlSpec.hs b/eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/Binary/CddlSpec.hs index 04f51e9daaa..741d1e31d84 100644 --- a/eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/Binary/CddlSpec.hs +++ b/eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/Binary/CddlSpec.hs @@ -23,21 +23,21 @@ spec = let v = eraProtVerLow @AllegraEra describe "Ruby-based" $ beforeAllCddlFile 3 readAllegraCddlFiles $ do cddlRoundTripCborSpec @(Value AllegraEra) v "coin" - cddlRoundTripAnnCborSpec @(TxBody AllegraEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody AllegraEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx AllegraEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx AllegraEra) v "transaction_body" cddlRoundTripAnnCborSpec @(Script AllegraEra) v "native_script" cddlRoundTripCborSpec @(Script AllegraEra) v "native_script" cddlRoundTripAnnCborSpec @(TxAuxData AllegraEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData AllegraEra) v "auxiliary_data" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody AllegraEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx AllegraEra) v "transaction_body" cddlDecoderEquivalenceSpec @(Script AllegraEra) v "native_script" cddlDecoderEquivalenceSpec @(TxAuxData AllegraEra) v "auxiliary_data" describe "Huddle" $ specWithHuddle allegraCDDL 100 $ do huddleRoundTripCborSpec @(Value AllegraEra) v "coin" - huddleRoundTripAnnCborSpec @(TxBody AllegraEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody AllegraEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx AllegraEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx AllegraEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData AllegraEra) v "auxiliary_data" huddleRoundTripCborSpec @(TxAuxData AllegraEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Script AllegraEra) v "native_script" diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs index 9a0382fe2ba..a65de14b582 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs @@ -105,7 +105,7 @@ instance where arbitrary = genericArbitraryU -instance Arbitrary (TxBody AllegraEra) where +instance Arbitrary (TxBody TopTx AllegraEra) where arbitrary = AllegraTxBody <$> arbitrary @@ -131,4 +131,4 @@ instance Arbitrary ValidityInterval where deriving newtype instance Arbitrary (TransitionConfig AllegraEra) -deriving newtype instance Arbitrary (Tx AllegraEra) +deriving newtype instance Arbitrary (Tx TopTx AllegraEra) diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Binary/Annotator.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Binary/Annotator.hs index d8130f3a40f..dc268c6916d 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Binary/Annotator.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Binary/Annotator.hs @@ -27,7 +27,7 @@ import qualified Data.Sequence.Strict as StrictSeq import Test.Cardano.Ledger.Allegra.Arbitrary () import Test.Cardano.Ledger.Shelley.Binary.Annotator -deriving newtype instance DecCBOR (TxBody AllegraEra) +deriving newtype instance DecCBOR (TxBody TopTx AllegraEra) instance ( Era era @@ -75,4 +75,4 @@ instance Era era => DecCBOR (TimelockRaw era) where instance Era era => DecCBOR (Timelock era) where decCBOR = MkTimelock <$> decodeMemoized decCBOR -deriving newtype instance DecCBOR (Tx AllegraEra) +deriving newtype instance DecCBOR (Tx TopTx AllegraEra) diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs index 10dfba767d7..c88dce8c217 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs @@ -56,7 +56,7 @@ exampleAllegraTxBody :: , ShelleyEraTxBody era ) => Value era -> - TxBody era + TxBody TopTx era exampleAllegraTxBody value = mkBasicTxBody & inputsTxBodyL .~ exampleTxIns diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs index 6bfc2eb6d86..2c95184ef39 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs @@ -52,7 +52,7 @@ impAllegraSatisfyNativeScript :: , NativeScript era ~ Timelock era ) => Set.Set (KeyHash 'Witness) -> - TxBody era -> + TxBody l era -> NativeScript era -> ImpTestM era (Maybe (Map.Map (KeyHash 'Witness) (KeyPair 'Witness))) impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/TreeDiff.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/TreeDiff.hs index be9e41a48e9..9d6080524b7 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/TreeDiff.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/TreeDiff.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -20,6 +21,7 @@ import Cardano.Ledger.Allegra.TxBody import Cardano.Ledger.Core import Cardano.Ledger.Shelley.PParams import Control.State.Transition.Extended (STS (..)) +import qualified Data.TreeDiff.OMap as OMap import Test.Cardano.Ledger.Shelley.TreeDiff -- Scripts @@ -41,9 +43,24 @@ instance , ToExpr (TxCert era) , ToExpr (Update era) ) => - ToExpr (AllegraTxBodyRaw ma era) + ToExpr (AllegraTxBodyRaw ma TopTx era) + where + toExpr AllegraTxBodyRaw {..} = + Rec + "AllegraTxBodyRaw" + $ OMap.fromList + [ ("atbrInputs", toExpr atbrInputs) + , ("atbrOutputs", toExpr atbrOutputs) + , ("atbrCerts", toExpr atbrCerts) + , ("atbrWithdrawals", toExpr atbrWithdrawals) + , ("atbrFee", toExpr atbrFee) + , ("atbrValidityInterval", toExpr atbrValidityInterval) + , ("atbrUpdate", toExpr atbrUpdate) + , ("atbrAuxDataHash", toExpr atbrAuxDataHash) + , ("atbrMint", toExpr atbrMint) + ] -instance ToExpr (TxBody AllegraEra) +instance ToExpr (TxBody TopTx AllegraEra) -- Rules/Utxo instance @@ -60,4 +77,4 @@ instance ) => ToExpr (AllegraUtxoEvent era) -deriving newtype instance ToExpr (Tx AllegraEra) +deriving newtype instance ToExpr (Tx TopTx AllegraEra) diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 41c5fea539f..f42c26074c9 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,23 @@ ## 1.15.0.0 +* Remove deprecated accessor functions: + - `inputs'` + - `collateral'` + - `outputs'` + - `certs'` + - `txfee'` + - `withdrawals'` + - `vldt'` + - `update'` + - `reqSignerHashes'` + - `adHash'` + - `mint'` + - `scriptIntegrityHash'` + - `txnetworkid'` +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Change `reqSignerHashesTxBodyL` and `reqSignerHashesTxBodyG` to return a set of `Guard` instead of `Witness` * Add `PlutusTxInInfo` type family * Add `toPlutusTxInInfo` method to `EraPlutusTxInfo` diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index e1953677503..0676eee6b83 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -88,7 +88,7 @@ library cardano-ledger-allegra ^>=1.9, cardano-ledger-binary ^>=1.8, cardano-ledger-core:{cardano-ledger-core, internal} ^>=1.19, - cardano-ledger-mary ^>=1.9, + cardano-ledger-mary ^>=1.10, cardano-ledger-shelley ^>=1.18, cardano-slotting, cardano-strict-containers, diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody.hs index 5a38f4018ff..ee25462e2ac 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody.hs @@ -8,11 +8,11 @@ module Cardano.Ledger.Alonzo.BlockBody ( import Cardano.Crypto.Hash (Hash) import Cardano.Ledger.Alonzo.BlockBody.Internal -import Cardano.Ledger.Core (EraIndependentBlockBody, HASH, Tx) +import Cardano.Ledger.Core (EraIndependentBlockBody, HASH, Tx, TxLevel (..)) import Data.Sequence.Strict (StrictSeq) alonzoBlockBodyHash :: AlonzoBlockBody era -> Hash HASH EraIndependentBlockBody alonzoBlockBodyHash = abbHash -alonzoBlockBodyTxs :: AlonzoBlockBody era -> StrictSeq (Tx era) +alonzoBlockBodyTxs :: AlonzoBlockBody era -> StrictSeq (Tx TopTx era) alonzoBlockBodyTxs = abbTxs diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs index c096867e26c..f9fa4f5d769 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs @@ -72,7 +72,7 @@ import NoThunks.Class (AllowThunksIn (..), NoThunks) -- order to support segregated witnessing. data AlonzoBlockBody era = AlonzoBlockBodyInternal - { abbTxs :: !(StrictSeq (Tx era)) + { abbTxs :: !(StrictSeq (Tx TopTx era)) , abbHash :: Hash.Hash HASH EraIndependentBlockBody -- ^ Memoized hash to avoid recomputation. Lazy on purpose. , abbTxsBodyBytes :: BSL.ByteString @@ -109,7 +109,7 @@ txSeqBlockBodyAlonzoL :: , BlockBody era ~ AlonzoBlockBody era , AlonzoEraTx era ) => - Lens' (BlockBody era) (StrictSeq (Tx era)) + Lens' (BlockBody era) (StrictSeq (Tx TopTx era)) txSeqBlockBodyAlonzoL = lens abbTxs (\_ s -> AlonzoBlockBody s) {-# INLINEABLE txSeqBlockBodyAlonzoL #-} @@ -118,7 +118,7 @@ pattern AlonzoBlockBody :: ( AlonzoEraTx era , SafeToHash (TxWits era) ) => - StrictSeq (Tx era) -> + StrictSeq (Tx TopTx era) -> AlonzoBlockBody era pattern AlonzoBlockBody xs <- AlonzoBlockBodyInternal xs _ _ _ _ _ @@ -161,11 +161,11 @@ deriving via ] (AlonzoBlockBody era) instance - (Typeable era, NoThunks (Tx era)) => NoThunks (AlonzoBlockBody era) + (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (AlonzoBlockBody era) -deriving stock instance Show (Tx era) => Show (AlonzoBlockBody era) +deriving stock instance Show (Tx TopTx era) => Show (AlonzoBlockBody era) -deriving stock instance Eq (Tx era) => Eq (AlonzoBlockBody era) +deriving stock instance Eq (Tx TopTx era) => Eq (AlonzoBlockBody era) -------------------------------------------------------------------------------- -- Serialisation and hashing @@ -207,7 +207,7 @@ hashAlonzoSegWits txSeqBodies txSeqWits txAuxData txSeqIsValids = instance ( AlonzoEraTx era , DecCBOR (Annotator (TxAuxData era)) - , DecCBOR (Annotator (TxBody era)) + , DecCBOR (Annotator (TxBody TopTx era)) , DecCBOR (Annotator (TxWits era)) ) => DecCBOR (Annotator (AlonzoBlockBody era)) @@ -258,7 +258,7 @@ instance -- | Given a sequence of transactions, return the indices of those which do not -- validate. We store the indices of the non-validating transactions because we -- expect this to be a much smaller set than the validating transactions. -nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx era) -> [Int] +nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx TopTx era) -> [Int] nonValidatingIndices (StrictSeq.fromStrict -> xs) = Seq.foldrWithIndex ( \idx tx acc -> @@ -286,17 +286,17 @@ alignedValidFlags = alignedValidFlags' (-1) -- | Construct an annotated Alonzo style transaction. alonzoSegwitTx :: AlonzoEraTx era => - Annotator (TxBody era) -> + Annotator (TxBody TopTx era) -> Annotator (TxWits era) -> IsValid -> Maybe (Annotator (TxAuxData era)) -> - Annotator (Tx era) -alonzoSegwitTx txBodyAnn txWitsAnn isValid auxDataAnn = Annotator $ \bytes -> do + Annotator (Tx TopTx era) +alonzoSegwitTx txBodyAnn txWitsAnn txIsValid txAuxDataAnn = Annotator $ \bytes -> do txBody <- runAnnotator txBodyAnn bytes txWits <- runAnnotator txWitsAnn bytes - txAuxData <- mapM (`runAnnotator` bytes) auxDataAnn + txAuxData <- mapM (`runAnnotator` bytes) txAuxDataAnn pure $ mkBasicTx txBody & witsTxL .~ txWits & auxDataTxL .~ maybeToStrictMaybe txAuxData - & isValidTxL .~ isValid + & isValidTxL .~ txIsValid diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs index ae6f8179be2..052974cbed7 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs @@ -23,6 +23,9 @@ import Cardano.Ledger.Shelley.Rules -- ===================================================== +instance EraTxLevel AlonzoEra where + type STxLevel l AlonzoEra = STxTopLevel l AlonzoEra + type instance Value AlonzoEra = MaryValue ------------------------------------------------------------------------------- diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs index 36e170a51a0..e5eb4e9ac07 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs @@ -86,7 +86,7 @@ data LedgerTxInfo era = LedgerTxInfo , ltiEpochInfo :: !(EpochInfo (Either Text)) , ltiSystemStart :: !SystemStart , ltiUTxO :: !(UTxO era) - , ltiTx :: !(Tx era) + , ltiTx :: !(Tx TopTx era) } class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language) era where diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs index 46e849b8a6d..501621f65bb 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs @@ -148,7 +148,7 @@ collectPlutusScriptsWithContext :: EpochInfo (Either Text) -> SystemStart -> PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Either [CollectError era] [PlutusWithContext] collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo = @@ -314,7 +314,7 @@ evalTxExUnits :: ) => PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | The current UTxO set (or the relevant portion for the transaction). UTxO era -> -- | The epoch info, used to translate slots to POSIX time for plutus. @@ -341,7 +341,7 @@ evalTxExUnitsWithLogs :: ) => PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | The current UTxO set (or the relevant portion for the transaction). UTxO era -> -- | The epoch info, used to translate slots to POSIX time for plutus. diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs index f791c747851..45b49962de5 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs @@ -252,15 +252,15 @@ transTxOut txOut = do address <- transAddr (txOut ^. addrTxOutL) pure $ PV1.TxOut address (transValue val) (transDataHash <$> strictMaybeToMaybe dataHash) -transTxBodyId :: EraTxBody era => TxBody era -> PV1.TxId -transTxBodyId txBody = PV1.TxId (transSafeHash (hashAnnotated txBody)) +transTxBodyId :: EraTxBody era => TxBody l era -> PV1.TxId +transTxBodyId txBody = PV1.TxId (transSafeHash (hashAnnotated @_ @EraIndependentTxBody txBody)) -- | Translate all `TxCert`s from within a `TxBody` transTxBodyCerts :: (EraPlutusTxInfo l era, EraTxBody era) => proxy l -> ProtVer -> - TxBody era -> + TxBody t era -> Either (ContextError era) [PlutusTxCert l] transTxBodyCerts proxy pv txBody = mapM (toPlutusTxCert proxy pv) $ F.toList (txBody ^. certsTxBodyL) @@ -272,12 +272,12 @@ transWithdrawals (Withdrawals mp) = Map.foldlWithKey' accum Map.empty mp Map.insert (PV1.StakingHash (transRewardAccount rewardAccount)) n ans -- | Translate all `Withdrawal`s from within a `TxBody` -transTxBodyWithdrawals :: EraTxBody era => TxBody era -> [(PV1.StakingCredential, Integer)] +transTxBodyWithdrawals :: EraTxBody era => TxBody t era -> [(PV1.StakingCredential, Integer)] transTxBodyWithdrawals txBody = Map.toList (transWithdrawals (txBody ^. withdrawalsTxBodyL)) -- | Translate all required signers produced by `reqSignerHashesTxBodyL`s from within a -- `TxBody` -transTxBodyReqSignerHashes :: AlonzoEraTxBody era => TxBody era -> [PV1.PubKeyHash] +transTxBodyReqSignerHashes :: AlonzoEraTxBody era => TxBody t era -> [PV1.PubKeyHash] transTxBodyReqSignerHashes txBody = transKeyHash <$> Set.toList (txBody ^. reqSignerHashesTxBodyG) -- | Translate all `TxDats`s from within `TxWits` diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index fddf8e4ead8..8600263c49e 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -176,7 +176,7 @@ alonzoBbodyTransition :: , Embed (EraRule "LEDGERS" era) (EraRule "BBODY" era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , EraBlockBody era , AlonzoEraTxWits era , BlockBody era ~ AlonzoBlockBody era @@ -260,7 +260,7 @@ instance , Embed (EraRule "LEDGERS" era) (AlonzoBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , AlonzoEraTxWits era , BlockBody era ~ AlonzoBlockBody era , EraBlockBody era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs index 0b7bea211b4..5a811bce2fc 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs @@ -114,7 +114,7 @@ ledgerTransition :: forall (someLEDGER :: Type -> Type) era. ( STS (someLEDGER era) , BaseM (someLEDGER era) ~ ShelleyBase - , Signal (someLEDGER era) ~ Tx era + , Signal (someLEDGER era) ~ Tx TopTx era , State (someLEDGER era) ~ LedgerState era , Environment (someLEDGER era) ~ LedgerEnv era , Embed (EraRule "UTXOW" era) (someLEDGER era) @@ -124,7 +124,7 @@ ledgerTransition :: , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , AlonzoEraTx era , EraCertState era , EraRule "LEDGER" era ~ someLEDGER era @@ -167,7 +167,7 @@ instance , Embed (EraRule "UTXOW" era) (AlonzoLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Environment (EraRule "DELEGS" era) ~ DelegsEnv era , State (EraRule "DELEGS" era) ~ CertState era , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) @@ -180,7 +180,7 @@ instance STS (AlonzoLEDGER era) where type State (AlonzoLEDGER era) = LedgerState era - type Signal (AlonzoLEDGER era) = Tx era + type Signal (AlonzoLEDGER era) = Tx TopTx era type Environment (AlonzoLEDGER era) = LedgerEnv era type BaseM (AlonzoLEDGER era) = ShelleyBase type PredicateFailure (AlonzoLEDGER era) = ShelleyLedgerPredFailure era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs index b8e679e3b47..51c71dec208 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs @@ -193,7 +193,7 @@ deriving stock instance ( Era era , Show (Value era) , Show (TxOut era) - , Show (TxBody era) + , Show (TxBody TopTx era) , Show (PredicateFailure (EraRule "UTXOS" era)) ) => Show (AlonzoUtxoPredFailure era) @@ -267,7 +267,7 @@ feesOK :: , EraUTxO era ) => PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Test (AlonzoUtxoPredFailure era) feesOK pp tx u@(UTxO utxo) = @@ -292,7 +292,7 @@ validateCollateral :: , AlonzoEraPParams era ) => PParams era -> - TxBody era -> + TxBody TopTx era -> Map.Map TxIn (TxOut era) -> Test (AlonzoUtxoPredFailure era) validateCollateral pp txb utxoCollateral = @@ -324,7 +324,7 @@ validateInsufficientCollateral :: , AlonzoEraPParams era ) => PParams era -> - TxBody era -> + TxBody TopTx era -> DeltaCoin -> Test (AlonzoUtxoPredFailure era) validateInsufficientCollateral pp txBody bal = @@ -359,7 +359,7 @@ validateOutsideForecast :: -- | Current slot number SlotNo -> SystemStart -> - Tx era -> + Tx l era -> Test (AlonzoUtxoPredFailure era) validateOutsideForecast ei slotNo sysSt tx = {- (_,i_f) := txvldt tx -} @@ -423,7 +423,7 @@ validateOutputTooBigUTxO pp outputs = validateWrongNetworkInTxBody :: AlonzoEraTxBody era => Network -> - TxBody era -> + TxBody l era -> Test (AlonzoUtxoPredFailure era) validateWrongNetworkInTxBody netId txBody = case txBody ^. networkIdTxBodyL of @@ -441,7 +441,7 @@ validateExUnitsTooBigUTxO :: , AlonzoEraPParams era ) => PParams era -> - Tx era -> + Tx l era -> Test (AlonzoUtxoPredFailure era) validateExUnitsTooBigUTxO pp tx = failureUnless (pointWiseExUnits (<=) totalExUnits maxTxExUnits) $ @@ -457,7 +457,7 @@ validateExUnitsTooBigUTxO pp tx = validateTooManyCollateralInputs :: AlonzoEraTxBody era => PParams era -> - TxBody era -> + TxBody TopTx era -> Test (AlonzoUtxoPredFailure era) validateTooManyCollateralInputs pp txBody = failureUnless (numColl <= maxColl) $ @@ -482,7 +482,7 @@ utxoTransition :: , Embed (EraRule "UTXOS" era) (AlonzoUTXO era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , State (EraRule "UTXOS" era) ~ UTxOState era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , EraCertState era , SafeToHash (TxWits era) ) => @@ -566,7 +566,7 @@ instance , Embed (EraRule "UTXOS" era) (AlonzoUTXO era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , State (EraRule "UTXOS" era) ~ UTxOState era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , EraRule "UTXO" era ~ AlonzoUTXO era , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era @@ -578,7 +578,7 @@ instance STS (AlonzoUTXO era) where type State (AlonzoUTXO era) = UTxOState era - type Signal (AlonzoUTXO era) = Tx era + type Signal (AlonzoUTXO era) = Tx TopTx era type Environment (AlonzoUTXO era) = UtxoEnv era type BaseM (AlonzoUTXO era) = ShelleyBase type PredicateFailure (AlonzoUTXO era) = AlonzoUtxoPredFailure era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index 811868dbfda..49d5b558034 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -125,7 +125,7 @@ instance type BaseM (AlonzoUTXOS era) = ShelleyBase type Environment (AlonzoUTXOS era) = UtxoEnv era type State (AlonzoUTXOS era) = UTxOState era - type Signal (AlonzoUTXOS era) = Tx era + type Signal (AlonzoUTXOS era) = Tx TopTx era type PredicateFailure (AlonzoUTXOS era) = AlonzoUtxosPredFailure era type Event (AlonzoUTXOS era) = AlonzoUtxosEvent era transitionRules = [utxosTransition] @@ -211,7 +211,7 @@ scriptsTransition :: ) => SlotNo -> PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> (ScriptResult -> Rule sts ctx ()) -> Rule sts ctx () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index e8a4124701e..dd8f3487234 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -228,12 +228,12 @@ instance {- { h | (_ → (a,_,h)) ∈ txins tx ◁ utxo, isTwoPhaseScriptAddress tx a} ⊆ dom(txdats txw) -} {- dom(txdats txw) ⊆ inputHashes ∪ {h | ( , , h, ) ∈ txouts tx ∪ utxo (refInputs tx) } -} missingRequiredDatums :: - forall era. + forall era l. ( AlonzoEraTx era , AlonzoEraUTxO era ) => UTxO era -> - Tx era -> + Tx l era -> Test (AlonzoUtxowPredFailure era) missingRequiredDatums utxo tx = do let txBody = tx ^. bodyTxL @@ -261,9 +261,9 @@ missingRequiredDatums utxo tx = do {- dom (txrdmrs tx) = { rdptr txb sp | (sp, h) ∈ scriptsNeeded utxo tx, h ↦ s ∈ txscripts txw, s ∈ Scriptph2} -} hasExactSetOfRedeemers :: - forall era. + forall era l. AlonzoEraTx era => - Tx era -> + Tx l era -> ScriptsProvided era -> AlonzoScriptsNeeded era -> Test (AlonzoUtxowPredFailure era) @@ -288,9 +288,9 @@ hasExactSetOfRedeemers tx (ScriptsProvided scriptsProvided) (AlonzoScriptsNeeded -- ======================= {- scriptIntegrityHash txb = hashScriptIntegrity pp (languages txw) (txrdmrs txw) -} checkScriptIntegrityHash :: - forall era. + forall era l. AlonzoEraTx era => - Tx era -> + Tx l era -> PParams era -> StrictMaybe (ScriptIntegrity era) -> Test (AlonzoUtxowPredFailure era) @@ -328,7 +328,7 @@ alonzoStyleWitness :: Embed (EraRule "UTXO" era) (AlonzoUTXOW era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , EraCertState era ) => TransitionRule (EraRule "UTXOW" era) @@ -422,13 +422,13 @@ instance Embed (EraRule "UTXO" era) (AlonzoUTXOW era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , EraCertState era ) => STS (AlonzoUTXOW era) where type State (AlonzoUTXOW era) = UTxOState era - type Signal (AlonzoUTXOW era) = Tx era + type Signal (AlonzoUTXOW era) = Tx TopTx era type Environment (AlonzoUTXOW era) = UtxoEnv era type BaseM (AlonzoUTXOW era) = ShelleyBase type PredicateFailure (AlonzoUTXOW era) = AlonzoUtxowPredFailure era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index b3207d417bf..b2dbb2440aa 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -69,8 +70,8 @@ instance TranslateEra AlonzoEra FuturePParams where DefinitePParamsUpdate pp -> DefinitePParamsUpdate <$> translateEra ctxt pp PotentialPParamsUpdate mpp -> PotentialPParamsUpdate <$> mapM (translateEra ctxt) mpp -instance TranslateEra AlonzoEra Tx where - type TranslationError AlonzoEra Tx = DecoderError +instance TranslateEra AlonzoEra (Tx TopTx) where + type TranslationError AlonzoEra (Tx TopTx) = DecoderError translateEra _ctxt tx = do -- Note that this does not preserve the hidden bytes field of the transaction. -- This is under the premise that this is irrelevant for TxInBlocks, which are diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 9586853089b..616a10bf455 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -7,8 +7,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -101,9 +103,9 @@ import Cardano.Ledger.Binary ( EncCBOR (encCBOR), Encoding, ToCBOR (..), - decodeNullMaybe, + decodeNullStrictMaybe, encodeListLen, - encodeNullMaybe, + encodeNullStrictMaybe, serialize, serialize', ) @@ -118,18 +120,14 @@ import Cardano.Ledger.Shelley.Tx (shelleyTxEqRaw) import Cardano.Ledger.State (EraUTxO, ScriptsProvided (..)) import qualified Cardano.Ledger.State as Shelley import Cardano.Ledger.Val (Val ((<+>), (<×>))) -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..), deepseq) import Control.Monad.Trans.Fail.String (errorFail) import Data.Aeson (ToJSON (..)) import qualified Data.ByteString.Lazy as LBS import Data.Int (Int64) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) -import Data.Maybe.Strict ( - StrictMaybe (..), - maybeToStrictMaybe, - strictMaybeToMaybe, - ) +import Data.Maybe.Strict (StrictMaybe (..)) import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) @@ -137,7 +135,7 @@ import Data.Word (Word32) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Lens.Micro hiding (set) -import NoThunks.Class (NoThunks) +import NoThunks.Class (InspectHeap (..), NoThunks) -- =================================================== @@ -147,16 +145,20 @@ newtype IsValid = IsValid Bool deriving (Eq, Show, Generic) deriving newtype (NoThunks, NFData, ToCBOR, EncCBOR, DecCBOR, ToJSON) -data AlonzoTx era = AlonzoTx - { atBody :: !(TxBody era) - , atWits :: !(TxWits era) - , atIsValid :: !IsValid - , atAuxData :: !(StrictMaybe (TxAuxData era)) - } - deriving (Generic) +data AlonzoTx l era where + AlonzoTx :: + { atBody :: !(TxBody TopTx era) + , atWits :: !(TxWits era) + , atIsValid :: !IsValid + , atAuxData :: !(StrictMaybe (TxAuxData era)) + } -> + AlonzoTx TopTx era + +instance HasEraTxLevel Tx AlonzoEra where + toSTxLevel (MkAlonzoTx AlonzoTx {}) = STopTxOnly @AlonzoEra instance EraTx AlonzoEra where - newtype Tx AlonzoEra = MkAlonzoTx {unAlonzoTx :: AlonzoTx AlonzoEra} + newtype Tx l AlonzoEra = MkAlonzoTx {unAlonzoTx :: AlonzoTx l AlonzoEra} deriving newtype (Eq, NFData, EncCBOR, ToCBOR, NoThunks, Show) deriving (Generic) @@ -180,49 +182,71 @@ instance EraTx AlonzoEra where getMinFeeTx pp tx _ = alonzoMinFeeTx pp tx {-# INLINE getMinFeeTx #-} -alonzoTxEqRaw :: AlonzoEraTx era => Tx era -> Tx era -> Bool +alonzoTxEqRaw :: + ( AlonzoEraTx era + , STxLevel l era ~ STxTopLevel l era + ) => + Tx l era -> Tx l era -> Bool alonzoTxEqRaw tx1 tx2 = - shelleyTxEqRaw tx1 tx2 && (tx1 ^. isValidTxL == tx2 ^. isValidTxL) + withTopTxLevelOnly tx1 $ \tx1' -> + withTopTxLevelOnly tx2 $ \tx2' -> + shelleyTxEqRaw tx1 tx2 && (tx1' ^. isValidTxL == tx2' ^. isValidTxL) -instance EqRaw (Tx AlonzoEra) where +instance EqRaw (Tx l AlonzoEra) where eqRaw = alonzoTxEqRaw -alonzoTxL :: Lens' (Tx AlonzoEra) (AlonzoTx AlonzoEra) +alonzoTxL :: Lens' (Tx l AlonzoEra) (AlonzoTx l AlonzoEra) alonzoTxL = lens unAlonzoTx $ const MkAlonzoTx class (EraTx era, AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraScript era) => AlonzoEraTx era where - isValidTxL :: Lens' (Tx era) IsValid + isValidTxL :: Lens' (Tx TopTx era) IsValid -instance DecCBOR (Annotator (Tx AlonzoEra)) where +instance Typeable l => DecCBOR (Annotator (Tx l AlonzoEra)) where decCBOR = fmap MkAlonzoTx <$> decCBOR instance AlonzoEraTx AlonzoEra where isValidTxL = alonzoTxL . isValidAlonzoTxL {-# INLINE isValidTxL #-} -mkBasicAlonzoTx :: Monoid (TxWits era) => TxBody era -> AlonzoTx era -mkBasicAlonzoTx txBody = AlonzoTx txBody mempty (IsValid True) SNothing +mkBasicAlonzoTx :: + ( EraTx era + , STxLevel l era ~ STxTopLevel l era + ) => + TxBody l era -> AlonzoTx l era +mkBasicAlonzoTx txBody = + case toSTxLevel txBody of + STopTxOnly -> + AlonzoTx txBody mempty (IsValid True) SNothing -- | `TxBody` setter and getter for `AlonzoTx`. -bodyAlonzoTxL :: Lens' (AlonzoTx era) (TxBody era) -bodyAlonzoTxL = lens atBody (\tx txBody -> tx {atBody = txBody}) +bodyAlonzoTxL :: Lens' (AlonzoTx l era) (TxBody l era) +bodyAlonzoTxL = + lens (\AlonzoTx {atBody} -> atBody) $ \tx txBody -> + case tx of + AlonzoTx {} -> tx {atBody = txBody} {-# INLINEABLE bodyAlonzoTxL #-} -- | `TxWits` setter and getter for `AlonzoTx`. -witsAlonzoTxL :: Lens' (AlonzoTx era) (TxWits era) -witsAlonzoTxL = lens atWits (\tx txWits -> tx {atWits = txWits}) +witsAlonzoTxL :: Lens' (AlonzoTx l era) (TxWits era) +witsAlonzoTxL = + lens (\AlonzoTx {atWits} -> atWits) $ \tx txWits -> + case tx of + AlonzoTx {} -> tx {atWits = txWits} {-# INLINEABLE witsAlonzoTxL #-} -- | `TxAuxData` setter and getter for `AlonzoTx`. -auxDataAlonzoTxL :: Lens' (AlonzoTx era) (StrictMaybe (TxAuxData era)) -auxDataAlonzoTxL = lens atAuxData (\tx txTxAuxData -> tx {atAuxData = txTxAuxData}) +auxDataAlonzoTxL :: Lens' (AlonzoTx l era) (StrictMaybe (TxAuxData era)) +auxDataAlonzoTxL = + lens (\AlonzoTx {atAuxData} -> atAuxData) $ \tx txAuxData -> + case tx of + AlonzoTx {} -> tx {atAuxData = txAuxData} {-# INLINEABLE auxDataAlonzoTxL #-} -- | txsize computes the length of the serialised bytes (for estimations) -sizeAlonzoTxF :: forall era. (HasCallStack, EraTx era) => SimpleGetter (AlonzoTx era) Word32 +sizeAlonzoTxF :: forall era l. (HasCallStack, EraTx era) => SimpleGetter (AlonzoTx l era) Word32 sizeAlonzoTxF = to $ errorFail @@ -232,32 +256,38 @@ sizeAlonzoTxF = . toCBORForSizeComputation {-# INLINEABLE sizeAlonzoTxF #-} -isValidAlonzoTxL :: Lens' (AlonzoTx era) IsValid -isValidAlonzoTxL = lens atIsValid (\tx valid -> tx {atIsValid = valid}) +isValidAlonzoTxL :: Lens' (AlonzoTx l era) IsValid +isValidAlonzoTxL = + lens (\AlonzoTx {atIsValid} -> atIsValid) $ \tx txIsValid -> + case tx of + AlonzoTx {} -> tx {atIsValid = txIsValid} {-# INLINEABLE isValidAlonzoTxL #-} deriving instance - (Era era, Eq (TxBody era), Eq (TxWits era), Eq (TxAuxData era)) => Eq (AlonzoTx era) + (Era era, Eq (TxBody l era), Eq (TxWits era), Eq (TxAuxData era)) => Eq (AlonzoTx l era) deriving instance - (Era era, Show (TxBody era), Show (TxAuxData era), Show (Script era), Show (TxWits era)) => - Show (AlonzoTx era) + (Era era, Show (TxBody l era), Show (TxAuxData era), Show (Script era), Show (TxWits era)) => + Show (AlonzoTx l era) -instance - ( Era era - , NoThunks (TxWits era) - , NoThunks (TxAuxData era) - , NoThunks (TxBody era) - ) => - NoThunks (AlonzoTx era) +deriving via + InspectHeap (AlonzoTx l era) + instance + (Typeable era, Typeable l) => NoThunks (AlonzoTx l era) instance ( Era era , NFData (TxWits era) , NFData (TxAuxData era) - , NFData (TxBody era) + , NFData (TxBody l era) ) => - NFData (AlonzoTx era) + NFData (AlonzoTx l era) + where + rnf AlonzoTx {..} = + atBody `deepseq` + atWits `deepseq` + atAuxData `deepseq` + rnf atIsValid -- | A ScriptIntegrityHash is the hash of three things. The first two come -- from the witnesses and the last comes from the Protocol Parameters. @@ -294,7 +324,7 @@ mkScriptIntegrity :: , EraUTxO era ) => PParams era -> - Tx era -> + Tx l era -> ScriptsProvided era -> Set ScriptHash -> StrictMaybe (ScriptIntegrity era) @@ -320,17 +350,17 @@ mkScriptIntegrity pp tx (ScriptsProvided scriptsProvided) scriptsNeeded -- The individual components all store their bytes; the only work we do in this -- function is concatenating toCBORForSizeComputation :: - ( EncCBOR (TxBody era) + ( EncCBOR (TxBody l era) , EncCBOR (TxWits era) , EncCBOR (TxAuxData era) ) => - AlonzoTx era -> + AlonzoTx l era -> Encoding toCBORForSizeComputation AlonzoTx {atBody, atWits, atAuxData} = encodeListLen 3 <> encCBOR atBody <> encCBOR atWits - <> encodeNullMaybe encCBOR (strictMaybeToMaybe atAuxData) + <> encodeNullStrictMaybe encCBOR atAuxData alonzoMinFeeTx :: ( EraTx era @@ -338,7 +368,7 @@ alonzoMinFeeTx :: , AlonzoEraPParams era ) => PParams era -> - Tx era -> + Tx l era -> Coin alonzoMinFeeTx pp tx = (tx ^. sizeTxF <×> pp ^. ppMinFeeAL) @@ -349,7 +379,7 @@ alonzoMinFeeTx pp tx = totExUnits :: (EraTx era, AlonzoEraTxWits era) => - Tx era -> + Tx l era -> ExUnits totExUnits tx = foldMap snd $ tx ^. witsTxL . rdmrsTxWitsL . unRedeemersL @@ -377,11 +407,11 @@ totExUnits tx = foldMap snd $ tx ^. witsTxL . rdmrsTxWitsL . unRedeemersL -- computing the transaction size (which omits the `IsValid` field for -- compatibility with Mary - see 'toCBORForSizeComputation'). toCBORForMempoolSubmission :: - ( EncCBOR (TxBody era) + ( EncCBOR (TxBody l era) , EncCBOR (TxWits era) , EncCBOR (TxAuxData era) ) => - AlonzoTx era -> + AlonzoTx l era -> Encoding toCBORForMempoolSubmission AlonzoTx {atBody, atWits, atAuxData, atIsValid} = @@ -390,47 +420,48 @@ toCBORForMempoolSubmission !> To atBody !> To atWits !> To atIsValid - !> E (encodeNullMaybe encCBOR . strictMaybeToMaybe) atAuxData + !> E (encodeNullStrictMaybe encCBOR) atAuxData instance ( Era era - , EncCBOR (TxBody era) + , EncCBOR (TxBody l era) , EncCBOR (TxAuxData era) , EncCBOR (TxWits era) ) => - EncCBOR (AlonzoTx era) + EncCBOR (AlonzoTx l era) where encCBOR = toCBORForMempoolSubmission instance ( Era era - , EncCBOR (TxBody era) + , EncCBOR (TxBody l era) , EncCBOR (TxAuxData era) , EncCBOR (TxWits era) + , Typeable l ) => - ToCBOR (AlonzoTx era) + ToCBOR (AlonzoTx l era) where toCBOR = toEraCBOR @era instance - ( Typeable era - , Typeable (TxBody era) + ( Typeable l + , Era era + , Typeable (TxBody l era) , Typeable (TxWits era) , Typeable (TxAuxData era) - , DecCBOR (Annotator (TxBody era)) + , DecCBOR (Annotator (TxBody l era)) , DecCBOR (Annotator (TxWits era)) , DecCBOR (Annotator (TxAuxData era)) ) => - DecCBOR (Annotator (AlonzoTx era)) + DecCBOR (Annotator (AlonzoTx l era)) where decCBOR = - decode $ - Ann (RecD AlonzoTx) - <*! From - <*! From - <*! Ann From - <*! D - ( sequence . maybeToStrictMaybe - <$> decodeNullMaybe decCBOR - ) + withSTxTopLevelM @l @era $ \case + STopTxOnly -> + decode $ + Ann (RecD AlonzoTx) + <*! From + <*! From + <*! Ann From + <*! D (sequence <$> decodeNullStrictMaybe decCBOR) {-# INLINE decCBOR #-} diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index cb289286494..cb5a0dea633 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -13,10 +13,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} @@ -51,19 +53,6 @@ module Cardano.Ledger.Alonzo.TxBody ( AllegraEraTxBody (..), MaryEraTxBody (..), Indexable (..), - inputs', - collateral', - outputs', - certs', - withdrawals', - txfee', - vldt', - update', - reqSignerHashes', - mint', - scriptIntegrityHash', - adHash', - txnetworkid', getAdaOnly, decodeDataHash32, encodeDataHash32, @@ -104,11 +93,7 @@ import Cardano.Ledger.Binary ( import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Mary.Core -import Cardano.Ledger.Mary.Value ( - MultiAsset (..), - PolicyID (..), - policies, - ) +import Cardano.Ledger.Mary.Value (MultiAsset (..), PolicyID (..)) import Cardano.Ledger.MemoBytes ( EqRaw, Mem, @@ -123,7 +108,7 @@ import Cardano.Ledger.MemoBytes ( import Cardano.Ledger.Shelley.PParams (Update (..)) import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) import Cardano.Ledger.TxIn (TxIn (..)) -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..), deepseq) import qualified Data.Map.Strict as Map import Data.OSet.Strict (OSet) import qualified Data.OSet.Strict as OSet @@ -131,100 +116,131 @@ import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import Data.Word (Word32) import GHC.Generics (Generic) import Lens.Micro -import NoThunks.Class (NoThunks) +import NoThunks.Class (InspectHeap (..), NoThunks (..)) type ScriptIntegrityHash = SafeHash EraIndependentScriptIntegrity class (MaryEraTxBody era, AlonzoEraTxOut era) => AlonzoEraTxBody era where - collateralInputsTxBodyL :: Lens' (TxBody era) (Set TxIn) + collateralInputsTxBodyL :: Lens' (TxBody TopTx era) (Set TxIn) - reqSignerHashesTxBodyL :: AtMostEra "Conway" era => Lens' (TxBody era) (Set (KeyHash 'Guard)) + reqSignerHashesTxBodyL :: AtMostEra "Conway" era => Lens' (TxBody l era) (Set (KeyHash 'Guard)) reqSignerHashesTxBodyG :: - SimpleGetter (TxBody era) (Set (KeyHash Guard)) + SimpleGetter (TxBody l era) (Set (KeyHash Guard)) default reqSignerHashesTxBodyG :: - AtMostEra "Conway" era => SimpleGetter (TxBody era) (Set (KeyHash Guard)) + AtMostEra "Conway" era => SimpleGetter (TxBody l era) (Set (KeyHash Guard)) reqSignerHashesTxBodyG = reqSignerHashesTxBodyL scriptIntegrityHashTxBodyL :: - Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash) + Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash) - networkIdTxBodyL :: Lens' (TxBody era) (StrictMaybe Network) + networkIdTxBodyL :: Lens' (TxBody l era) (StrictMaybe Network) -- | This function is called @rdptr@ in the spec. Given a `TxBody` and a plutus -- purpose with an item, we should be able to find the plutus purpose as in index redeemerPointer :: - TxBody era -> + TxBody l era -> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era) -- | This is an inverse of `redeemerPointer`. Given purpose as an index return it as an item. redeemerPointerInverse :: - TxBody era -> + TxBody l era -> PlutusPurpose AsIx era -> StrictMaybe (PlutusPurpose AsIxItem era) -- ====================================== -data AlonzoTxBodyRaw = AlonzoTxBodyRaw - { atbrInputs :: !(Set TxIn) - , atbrCollateral :: !(Set TxIn) - , atbrOutputs :: !(StrictSeq (TxOut AlonzoEra)) - , atbrCerts :: !(StrictSeq (TxCert AlonzoEra)) - , atbrWithdrawals :: !Withdrawals - , atbrTxFee :: !Coin - , atbrValidityInterval :: !ValidityInterval - , atbrUpdate :: !(StrictMaybe (Update AlonzoEra)) - , atbrReqSignerHashes :: Set (KeyHash 'Guard) - , atbrMint :: !MultiAsset - , atbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) - , atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - , atbrTxNetworkId :: !(StrictMaybe Network) - } - deriving (Generic) - -deriving instance Eq AlonzoTxBodyRaw - -instance NoThunks AlonzoTxBodyRaw - -instance NFData AlonzoTxBodyRaw - -deriving instance Show AlonzoTxBodyRaw - -instance Memoized (TxBody AlonzoEra) where - type RawType (TxBody AlonzoEra) = AlonzoTxBodyRaw +data AlonzoTxBodyRaw l era where + AlonzoTxBodyRaw :: + { atbrInputs :: !(Set TxIn) + , atbrCollateral :: !(Set TxIn) + , atbrOutputs :: !(StrictSeq (TxOut era)) + , atbrCerts :: !(StrictSeq (TxCert era)) + , atbrWithdrawals :: !Withdrawals + , atbrTxFee :: !Coin + , atbrValidityInterval :: !ValidityInterval + , atbrUpdate :: !(StrictMaybe (Update era)) + , atbrReqSignerHashes :: Set (KeyHash 'Guard) + , atbrMint :: !MultiAsset + , atbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , atbrTxNetworkId :: !(StrictMaybe Network) + } -> + AlonzoTxBodyRaw TopTx era + +deriving instance Eq (AlonzoTxBodyRaw l AlonzoEra) + +deriving via + InspectHeap (AlonzoTxBodyRaw l AlonzoEra) + instance + Typeable l => NoThunks (AlonzoTxBodyRaw l AlonzoEra) + +instance + ( NFData (TxOut era) + , NFData (TxCert era) + , NFData (PParamsHKD StrictMaybe era) + ) => + NFData (AlonzoTxBodyRaw l era) + where + rnf AlonzoTxBodyRaw {..} = + atbrInputs `deepseq` + atbrCollateral `deepseq` + atbrOutputs `deepseq` + atbrCerts `deepseq` + atbrWithdrawals `deepseq` + atbrTxFee `deepseq` + atbrValidityInterval `deepseq` + atbrUpdate `deepseq` + atbrReqSignerHashes `deepseq` + atbrMint `deepseq` + atbrScriptIntegrityHash `deepseq` + atbrAuxDataHash `deepseq` + rnf atbrTxNetworkId + +deriving instance Show (AlonzoTxBodyRaw l AlonzoEra) + +instance Memoized (TxBody l AlonzoEra) where + type RawType (TxBody l AlonzoEra) = AlonzoTxBodyRaw l AlonzoEra + +instance HasEraTxLevel AlonzoTxBodyRaw AlonzoEra where + toSTxLevel AlonzoTxBodyRaw {} = STopTxOnly + +instance HasEraTxLevel TxBody AlonzoEra where + toSTxLevel = toSTxLevel . getMemoRawType instance EraTxBody AlonzoEra where - newtype TxBody AlonzoEra = MkAlonzoTxBody (MemoBytes AlonzoTxBodyRaw) + newtype TxBody l AlonzoEra = MkAlonzoTxBody (MemoBytes (AlonzoTxBodyRaw l AlonzoEra)) deriving (ToCBOR, Generic) deriving newtype (SafeToHash) - mkBasicTxBody = mkMemoizedEra @AlonzoEra emptyAlonzoTxBodyRaw + mkBasicTxBody = emptyAlonzoTxBody inputsTxBodyL = - lensMemoRawType @AlonzoEra atbrInputs $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrInputs} -> atbrInputs) $ \txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @AlonzoEra atbrOutputs $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrOutputs} -> atbrOutputs) $ \txBodyRaw outputs_ -> txBodyRaw {atbrOutputs = outputs_} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = - lensMemoRawType @AlonzoEra atbrTxFee $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrTxFee} -> atbrTxFee) $ \txBodyRaw fee_ -> txBodyRaw {atbrTxFee = fee_} {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType @AlonzoEra atbrAuxDataHash $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrAuxDataHash} -> atbrAuxDataHash) $ \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} - spendableInputsTxBodyF = allInputsTxBodyF + spendableInputsTxBodyF = to (`withTopTxLevelOnly` (^. allInputsTxBodyF)) {-# INLINE spendableInputsTxBodyF #-} allInputsTxBodyF = @@ -232,12 +248,12 @@ instance EraTxBody AlonzoEra where {-# INLINEABLE allInputsTxBodyF #-} withdrawalsTxBodyL = - lensMemoRawType @AlonzoEra atbrWithdrawals $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrWithdrawals} -> atbrWithdrawals) $ \txBodyRaw withdrawals_ -> txBodyRaw {atbrWithdrawals = withdrawals_} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @AlonzoEra atbrCerts $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrCerts} -> atbrCerts) $ \txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_} {-# INLINEABLE certsTxBodyL #-} @@ -253,37 +269,34 @@ instance ShelleyEraTxBody AlonzoEra where instance AllegraEraTxBody AlonzoEra where vldtTxBodyL = - lensMemoRawType @AlonzoEra atbrValidityInterval $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrValidityInterval} -> atbrValidityInterval) $ \txBodyRaw vldt_ -> txBodyRaw {atbrValidityInterval = vldt_} {-# INLINEABLE vldtTxBodyL #-} instance MaryEraTxBody AlonzoEra where mintTxBodyL = - lensMemoRawType @AlonzoEra atbrMint $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrMint} -> atbrMint) $ \txBodyRaw mint_ -> txBodyRaw {atbrMint = mint_} {-# INLINEABLE mintTxBodyL #-} - mintedTxBodyF = to (policies . atbrMint . getMemoRawType) - {-# INLINEABLE mintedTxBodyF #-} - instance AlonzoEraTxBody AlonzoEra where collateralInputsTxBodyL = - lensMemoRawType @AlonzoEra atbrCollateral $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrCollateral} -> atbrCollateral) $ \txBodyRaw collateral_ -> txBodyRaw {atbrCollateral = collateral_} {-# INLINEABLE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = - lensMemoRawType @AlonzoEra atbrReqSignerHashes $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrReqSignerHashes} -> atbrReqSignerHashes) $ \txBodyRaw reqSignerHashes_ -> txBodyRaw {atbrReqSignerHashes = reqSignerHashes_} {-# INLINEABLE reqSignerHashesTxBodyL #-} scriptIntegrityHashTxBodyL = - lensMemoRawType @AlonzoEra atbrScriptIntegrityHash $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrScriptIntegrityHash} -> atbrScriptIntegrityHash) $ \txBodyRaw scriptIntegrityHash_ -> txBodyRaw {atbrScriptIntegrityHash = scriptIntegrityHash_} {-# INLINEABLE scriptIntegrityHashTxBodyL #-} networkIdTxBodyL = - lensMemoRawType @AlonzoEra atbrTxNetworkId $ + lensMemoRawType @AlonzoEra (\AlonzoTxBodyRaw {atbrTxNetworkId} -> atbrTxNetworkId) $ \txBodyRaw networkId -> txBodyRaw {atbrTxNetworkId = networkId} {-# INLINEABLE networkIdTxBodyL #-} @@ -291,15 +304,18 @@ instance AlonzoEraTxBody AlonzoEra where redeemerPointerInverse = alonzoRedeemerPointerInverse -deriving newtype instance Eq (TxBody AlonzoEra) +deriving newtype instance Eq (TxBody l AlonzoEra) -deriving instance NoThunks (TxBody AlonzoEra) +deriving instance Typeable l => NoThunks (TxBody l AlonzoEra) -deriving instance NFData (TxBody AlonzoEra) +deriving instance NFData (TxBody l AlonzoEra) -deriving instance Show (TxBody AlonzoEra) +deriving instance Show (TxBody l AlonzoEra) -deriving via Mem AlonzoTxBodyRaw instance DecCBOR (Annotator (TxBody AlonzoEra)) +deriving via + Mem (AlonzoTxBodyRaw l AlonzoEra) + instance + Typeable l => DecCBOR (Annotator (TxBody l AlonzoEra)) pattern AlonzoTxBody :: Set TxIn -> @@ -315,7 +331,7 @@ pattern AlonzoTxBody :: StrictMaybe ScriptIntegrityHash -> StrictMaybe TxAuxDataHash -> StrictMaybe Network -> - TxBody AlonzoEra + TxBody TopTx AlonzoEra pattern AlonzoTxBody { atbInputs , atbCollateral @@ -382,79 +398,21 @@ pattern AlonzoTxBody {-# COMPLETE AlonzoTxBody #-} -type instance MemoHashIndex AlonzoTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (AlonzoTxBodyRaw l era) = EraIndependentTxBody -instance HashAnnotated (TxBody AlonzoEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l AlonzoEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash --- ============================================================================== --- We define these accessor functions manually, because if we define them using --- the record syntax in the TxBody pattern, they inherit the (AlonzoBody era) --- constraint as a precondition. This is unnecessary, as one can see below --- they need not be constrained at all. This should be fixed in the GHC compiler. - -inputs' :: TxBody AlonzoEra -> Set TxIn -collateral' :: TxBody AlonzoEra -> Set TxIn -outputs' :: TxBody AlonzoEra -> StrictSeq (TxOut AlonzoEra) -certs' :: TxBody AlonzoEra -> StrictSeq (TxCert AlonzoEra) -txfee' :: TxBody AlonzoEra -> Coin -withdrawals' :: TxBody AlonzoEra -> Withdrawals -vldt' :: TxBody AlonzoEra -> ValidityInterval -update' :: TxBody AlonzoEra -> StrictMaybe (Update AlonzoEra) -reqSignerHashes' :: TxBody AlonzoEra -> Set (KeyHash 'Guard) -adHash' :: TxBody AlonzoEra -> StrictMaybe TxAuxDataHash -mint' :: TxBody AlonzoEra -> MultiAsset -scriptIntegrityHash' :: TxBody AlonzoEra -> StrictMaybe ScriptIntegrityHash -txnetworkid' :: TxBody AlonzoEra -> StrictMaybe Network -inputs' = atbrInputs . getMemoRawType -{-# DEPRECATED inputs' "In favor of inputsTxBodyL" #-} - -collateral' = atbrCollateral . getMemoRawType -{-# DEPRECATED collateral' "In favor of collateralInputsTxBodyL" #-} - -outputs' = atbrOutputs . getMemoRawType -{-# DEPRECATED outputs' "In favor of outputsTxBodyL" #-} - -certs' = atbrCerts . getMemoRawType -{-# DEPRECATED certs' "In favor of certsTxBodyL" #-} - -withdrawals' = atbrWithdrawals . getMemoRawType -{-# DEPRECATED withdrawals' "In favor of withdrawalsTxBodyL" #-} - -txfee' = atbrTxFee . getMemoRawType -{-# DEPRECATED txfee' "In favor of feeTxBodyL" #-} - -vldt' = atbrValidityInterval . getMemoRawType -{-# DEPRECATED vldt' "In favor of vldtTxBodyL" #-} - -update' = atbrUpdate . getMemoRawType -{-# DEPRECATED update' "In favor of updateTxBodyL" #-} - -reqSignerHashes' = atbrReqSignerHashes . getMemoRawType -{-# DEPRECATED reqSignerHashes' "In favor of reqSignerHashesTxBodyL" #-} - -adHash' = atbrAuxDataHash . getMemoRawType -{-# DEPRECATED adHash' "In favor of auxDataHashTxBodyL" #-} - -mint' = atbrMint . getMemoRawType -{-# DEPRECATED mint' "In favor of mintTxBodyL" #-} - -scriptIntegrityHash' = atbrScriptIntegrityHash . getMemoRawType -{-# DEPRECATED scriptIntegrityHash' "In favor of scriptIntegrityHashTxBodyL" #-} - -txnetworkid' = atbrTxNetworkId . getMemoRawType -{-# DEPRECATED txnetworkid' "In favor of networkIdTxBodyL" #-} - -instance EqRaw (TxBody AlonzoEra) +instance EqRaw (TxBody l AlonzoEra) -------------------------------------------------------------------------------- -- Serialisation -------------------------------------------------------------------------------- -- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody AlonzoEra) +deriving newtype instance EncCBOR (TxBody l AlonzoEra) -instance EncCBOR AlonzoTxBodyRaw where +instance EncCBOR (AlonzoTxBodyRaw l AlonzoEra) where encCBOR AlonzoTxBodyRaw { atbrInputs @@ -491,16 +449,19 @@ instance EncCBOR AlonzoTxBodyRaw where !> encodeKeyedStrictMaybe 7 atbrAuxDataHash !> encodeKeyedStrictMaybe 15 atbrTxNetworkId -instance DecCBOR AlonzoTxBodyRaw where +instance + Typeable l => + DecCBOR (AlonzoTxBodyRaw l AlonzoEra) + where decCBOR = - decode $ + fmap asSTxTopLevel . decode $ SparseKeyed "AlonzoTxBodyRaw" - emptyAlonzoTxBodyRaw + (asSTxTopLevel emptyAlonzoTxBodyRaw) bodyFields requiredFields where - bodyFields :: Word -> Field AlonzoTxBodyRaw + bodyFields :: Word -> Field (AlonzoTxBodyRaw TopTx AlonzoEra) bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From @@ -528,10 +489,10 @@ instance DecCBOR AlonzoTxBodyRaw where , (2, "fee") ] -instance DecCBOR (Annotator AlonzoTxBodyRaw) where +instance Typeable l => DecCBOR (Annotator (AlonzoTxBodyRaw l AlonzoEra)) where decCBOR = pure <$> decCBOR -emptyAlonzoTxBodyRaw :: AlonzoTxBodyRaw +emptyAlonzoTxBodyRaw :: AlonzoTxBodyRaw TopTx era emptyAlonzoTxBodyRaw = AlonzoTxBodyRaw mempty @@ -548,10 +509,13 @@ emptyAlonzoTxBodyRaw = SNothing SNothing +emptyAlonzoTxBody :: Typeable l => TxBody l AlonzoEra +emptyAlonzoTxBody = asSTxTopLevel $ mkMemoizedEra @AlonzoEra emptyAlonzoTxBodyRaw + alonzoRedeemerPointer :: - forall era. + forall era l. MaryEraTxBody era => - TxBody era -> + TxBody l era -> AlonzoPlutusPurpose AsItem era -> StrictMaybe (AlonzoPlutusPurpose AsIx era) alonzoRedeemerPointer txBody = \case @@ -566,7 +530,7 @@ alonzoRedeemerPointer txBody = \case alonzoRedeemerPointerInverse :: MaryEraTxBody era => - TxBody era -> + TxBody l era -> AlonzoPlutusPurpose AsIx era -> StrictMaybe (AlonzoPlutusPurpose AsIxItem era) alonzoRedeemerPointerInverse txBody = \case diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs index 5abca1ad7cf..b4b48ee34cc 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs @@ -21,10 +21,10 @@ pattern AlonzoTxSeq :: ( AlonzoEraTx era , SafeToHash (TxWits era) ) => - StrictSeq (Tx era) -> AlonzoBlockBody era + StrictSeq (Tx TopTx era) -> AlonzoBlockBody era pattern AlonzoTxSeq s = AlonzoBlockBody s -txSeqTxns :: AlonzoBlockBody era -> StrictSeq (Tx era) +txSeqTxns :: AlonzoBlockBody era -> StrictSeq (Tx TopTx era) txSeqTxns = alonzoBlockBodyTxs hashAlonzoTxSeq :: AlonzoBlockBody era -> Hash HASH EraIndependentBlockBody diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs index 3ca427ddab6..daba8c60c3b 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -85,7 +86,8 @@ instance EraUTxO AlonzoEra where getConsumedValue = getConsumedMaryValue - getProducedValue = getProducedMaryValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (getProducedMaryValue pp isRegPoolId) getScriptsProvided _ tx = ScriptsProvided (tx ^. witsTxL . scriptTxWitsL) @@ -104,7 +106,7 @@ class EraUTxO era => AlonzoEraUTxO era where -- to the outputs and reference inputs are the supplemental datums. getSupplementalDataHashes :: UTxO era -> - TxBody era -> + TxBody l era -> Set.Set DataHash -- | Lookup the TxIn from the `Spending` ScriptPurpose and find the datum needed for @@ -118,7 +120,7 @@ class EraUTxO era => AlonzoEraUTxO era where -- @ getSpendingDatum :: UTxO era -> - Tx era -> + Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era) @@ -129,7 +131,7 @@ instance AlonzoEraUTxO AlonzoEra where getAlonzoSupplementalDataHashes :: (EraTxBody era, AlonzoEraTxOut era) => - TxBody era -> + TxBody l era -> Set.Set DataHash getAlonzoSupplementalDataHashes txBody = Set.fromList @@ -143,7 +145,7 @@ getAlonzoSupplementalDataHashes txBody = getAlonzoSpendingDatum :: (AlonzoEraTxWits era, AlonzoEraTxOut era, EraTx era) => UTxO era -> - Tx era -> + Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era) getAlonzoSpendingDatum (UTxO m) tx sp = do @@ -164,7 +166,7 @@ getAlonzoScriptsHashesNeeded (AlonzoScriptsNeeded sn) = Set.fromList (map snd sn getInputDataHashesTxBody :: (EraTxBody era, AlonzoEraTxOut era, AlonzoEraScript era) => UTxO era -> - TxBody era -> + TxBody l era -> ScriptsProvided era -> (Set.Set DataHash, Set.Set TxIn) getInputDataHashesTxBody (UTxO utxo) txBody (ScriptsProvided scriptsProvided) = @@ -227,7 +229,7 @@ getInputDataHashesTxBody (UTxO utxo) txBody (ScriptsProvided scriptsProvided) = getAlonzoScriptsNeeded :: (MaryEraTxBody era, AlonzoEraScript era) => UTxO era -> - TxBody era -> + TxBody l era -> AlonzoScriptsNeeded era getAlonzoScriptsNeeded utxo txBody = getSpendingScriptsNeeded utxo txBody @@ -284,7 +286,7 @@ zipAsIxItem xs f = getSpendingScriptsNeeded :: (AlonzoEraScript era, EraTxBody era) => UTxO era -> - TxBody era -> + TxBody l era -> AlonzoScriptsNeeded era getSpendingScriptsNeeded (UTxO utxo) txBody = AlonzoScriptsNeeded $ @@ -298,7 +300,7 @@ getSpendingScriptsNeeded (UTxO utxo) txBody = getRewardingScriptsNeeded :: (AlonzoEraScript era, EraTxBody era) => - TxBody era -> + TxBody l era -> AlonzoScriptsNeeded era getRewardingScriptsNeeded txBody = AlonzoScriptsNeeded $ @@ -310,7 +312,7 @@ getRewardingScriptsNeeded txBody = getMintingScriptsNeeded :: (AlonzoEraScript era, MaryEraTxBody era) => - TxBody era -> + TxBody l era -> AlonzoScriptsNeeded era getMintingScriptsNeeded txBody = AlonzoScriptsNeeded $ @@ -320,11 +322,16 @@ getMintingScriptsNeeded txBody = -- | Just like `getShelleyWitsVKeyNeeded`, but also requires `reqSignerHashesTxBodyL`. getAlonzoWitsVKeyNeeded :: - forall era. - (EraTx era, AlonzoEraTxBody era, ShelleyEraTxBody era, EraCertState era) => + forall era l. + ( EraTx era + , AlonzoEraTxBody era + , ShelleyEraTxBody era + , EraCertState era + , STxLevel l era ~ STxTopLevel l era + ) => CertState era -> UTxO era -> - TxBody era -> + TxBody l era -> Set.Set (KeyHash 'Witness) getAlonzoWitsVKeyNeeded certState utxo txBody = getShelleyWitsVKeyNeeded certState utxo txBody diff --git a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs index 111f8c4b7cd..1959a507d8e 100644 --- a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs +++ b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs @@ -32,8 +32,8 @@ spec = let v = eraProtVerHigh @AlonzoEra describe "Ruby-based" $ beforeAllCddlFile 3 readAlonzoCddlFiles $ do cddlRoundTripCborSpec @(Value AlonzoEra) v "coin" - cddlRoundTripAnnCborSpec @(TxBody AlonzoEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody AlonzoEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx AlonzoEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx AlonzoEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock AlonzoEra) v "native_script" @@ -46,21 +46,21 @@ spec = cddlRoundTripCborSpec @(PParamsUpdate AlonzoEra) v "protocol_param_update" cddlRoundTripAnnCborSpec @(Redeemers AlonzoEra) v "[* redeemer]" cddlRoundTripCborSpec @(Redeemers AlonzoEra) v "[* redeemer]" - cddlRoundTripAnnCborSpec @(Tx AlonzoEra) v "transaction" - cddlRoundTripCborSpec @(Tx AlonzoEra) v "transaction" + cddlRoundTripAnnCborSpec @(Tx TopTx AlonzoEra) v "transaction" + cddlRoundTripCborSpec @(Tx TopTx AlonzoEra) v "transaction" cddlRoundTripCborSpec @CostModels v "cost_models" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody AlonzoEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx AlonzoEra) v "transaction_body" cddlDecoderEquivalenceSpec @(TxAuxData AlonzoEra) v "auxiliary_data" cddlDecoderEquivalenceSpec @(Timelock AlonzoEra) v "native_script" cddlDecoderEquivalenceSpec @(Data AlonzoEra) v "plutus_data" cddlDecoderEquivalenceSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" cddlDecoderEquivalenceSpec @(Redeemers AlonzoEra) v "[* redeemer]" - cddlDecoderEquivalenceSpec @(Tx AlonzoEra) v "transaction" + cddlDecoderEquivalenceSpec @(Tx TopTx AlonzoEra) v "transaction" describe "Huddle" $ specWithHuddle alonzoCDDL 100 $ do huddleRoundTripCborSpec @(Value AlonzoEra) v "coin" - huddleRoundTripAnnCborSpec @(TxBody AlonzoEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody AlonzoEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx AlonzoEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx AlonzoEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" huddleRoundTripCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Timelock AlonzoEra) v "native_script" @@ -73,14 +73,14 @@ spec = huddleRoundTripCborSpec @(PParamsUpdate AlonzoEra) v "protocol_param_update" huddleRoundTripAnnCborSpec @(Redeemers AlonzoEra) v "redeemers" huddleRoundTripCborSpec @(Redeemers AlonzoEra) v "redeemers" - huddleRoundTripAnnCborSpec @(Tx AlonzoEra) v "transaction" - huddleRoundTripCborSpec @(Tx AlonzoEra) v "transaction" + huddleRoundTripAnnCborSpec @(Tx TopTx AlonzoEra) v "transaction" + huddleRoundTripCborSpec @(Tx TopTx AlonzoEra) v "transaction" huddleRoundTripCborSpec @CostModels v "cost_models" describe "DecCBOR instances equivalence via CDDL" $ do - huddleDecoderEquivalenceSpec @(TxBody AlonzoEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx AlonzoEra) v "transaction_body" huddleDecoderEquivalenceSpec @(TxAuxData AlonzoEra) v "auxiliary_data" huddleDecoderEquivalenceSpec @(Timelock AlonzoEra) v "native_script" huddleDecoderEquivalenceSpec @(Data AlonzoEra) v "plutus_data" huddleDecoderEquivalenceSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" huddleDecoderEquivalenceSpec @(Redeemers AlonzoEra) v "redeemers" - huddleDecoderEquivalenceSpec @(Tx AlonzoEra) v "transaction" + huddleDecoderEquivalenceSpec @(Tx TopTx AlonzoEra) v "transaction" diff --git a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs index 385b2407a76..0578acb37c5 100644 --- a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs +++ b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs @@ -36,7 +36,7 @@ spec = do prop "Script" $ roundTripAnnTwiddledProperty @(Script AlonzoEra) eqAlonzoScriptRaw prop "Data" $ roundTripAnnTwiddledProperty @(Data AlonzoEra) (zipMemoRawType (===)) prop "BinaryData" $ roundTripTwiddledProperty @(BinaryData AlonzoEra) - prop "TxBody" $ roundTripAnnTwiddledProperty @(TxBody AlonzoEra) (zipMemoRawType (===)) + prop "TxBody" $ roundTripAnnTwiddledProperty @(TxBody TopTx AlonzoEra) (zipMemoRawType (===)) describe "DecCBOR instances equivalence" $ do Binary.decoderEquivalenceCoreEraTypesSpec @AlonzoEra decoderEquivalenceEraSpec @AlonzoEra @(TxDats AlonzoEra) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs index 7e8119a6f8c..7e467db8975 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs @@ -177,7 +177,7 @@ instance <*> scale (`div` 15) arbitrary <*> arbitrary -instance Arbitrary (TxBody AlonzoEra) where +instance Arbitrary (TxBody TopTx AlonzoEra) where arbitrary = AlonzoTxBody <$> arbitrary @@ -197,11 +197,11 @@ instance Arbitrary (TxBody AlonzoEra) where deriving newtype instance Arbitrary IsValid instance - ( Arbitrary (TxBody era) - , Arbitrary (TxWits era) + ( Arbitrary (TxWits era) , Arbitrary (TxAuxData era) + , Arbitrary (TxBody TopTx era) ) => - Arbitrary (AlonzoTx era) + Arbitrary (AlonzoTx TopTx era) where arbitrary = AlonzoTx @@ -479,12 +479,12 @@ mkPlutusScript' = either error fromPlutusScript . runFail . mkPlutusScript instance Arbitrary (TransitionConfig AlonzoEra) where arbitrary = AlonzoTransitionConfig <$> arbitrary <*> arbitrary -deriving newtype instance Arbitrary (Tx AlonzoEra) +deriving newtype instance Arbitrary (Tx TopTx AlonzoEra) instance ( EraBlockBody era , AlonzoEraTx era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , SafeToHash (TxWits era) ) => Arbitrary (AlonzoBlockBody era) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs index cc5995164c4..5cfc9414f84 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs @@ -45,7 +45,7 @@ import Test.Cardano.Ledger.Shelley.Arbitrary () instance ( AlonzoEraTx era - , DecCBOR (TxBody era) + , DecCBOR (TxBody TopTx era) , DecCBOR (TxAuxData era) , DecCBOR (TxWits era) , DecCBOR (NativeScript era) @@ -93,15 +93,15 @@ instance auxDataBytes isValidBytes -deriving newtype instance DecCBOR (TxBody AlonzoEra) +deriving newtype instance DecCBOR (TxBody TopTx AlonzoEra) instance ( Typeable era - , DecCBOR (TxBody era) + , DecCBOR (TxBody TopTx era) , DecCBOR (TxWits era) , DecCBOR (TxAuxData era) ) => - DecCBOR (AlonzoTx era) + DecCBOR (AlonzoTx TopTx era) where decCBOR = decode $ @@ -265,4 +265,4 @@ instance Era era => DecCBOR (TxDatsRaw era) where deriving newtype instance Era era => DecCBOR (TxDats era) -deriving newtype instance DecCBOR (Tx AlonzoEra) +deriving newtype instance DecCBOR (Tx TopTx AlonzoEra) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Twiddle.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Twiddle.hs index 17772698248..cc9ce9ac929 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Twiddle.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Twiddle.hs @@ -61,7 +61,7 @@ instance Twiddle TxIn where instance Twiddle Coin where twiddle v = twiddle v . toTerm v -instance Twiddle (TxBody AlonzoEra) where +instance Twiddle (TxBody TopTx AlonzoEra) where twiddle v txBody = do inputs' <- twiddle v $ atbInputs txBody outputs' <- twiddle v $ atbOutputs txBody diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs index 7243cb16449..a1402629940 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs @@ -90,7 +90,7 @@ mkLedgerExamples :: AlonzoEraPParams era => ApplyTxError era -> NewEpochState era -> - Tx era -> + Tx TopTx era -> TranslationContext era -> LedgerExamples era mkLedgerExamples @@ -127,7 +127,7 @@ exampleAlonzoNewEpochState = emptyPParams (emptyPParams & ppCoinsPerUTxOWordL .~ CoinPerWord (Coin 1)) -exampleTxAlonzo :: Tx AlonzoEra +exampleTxAlonzo :: Tx TopTx AlonzoEra exampleTxAlonzo = exampleTx exampleTxBodyAlonzo @@ -141,7 +141,7 @@ exampleTx :: , TxAuxData era ~ AlonzoTxAuxData era , Script era ~ AlonzoScript era ) => - TxBody era -> PlutusPurpose AsIx era -> NativeScript era -> Tx era + TxBody TopTx era -> PlutusPurpose AsIx era -> NativeScript era -> Tx TopTx era exampleTx txBody scriptPurpose nativeScript = mkBasicTx @era txBody & witsTxL @@ -164,7 +164,7 @@ exampleTx txBody scriptPurpose nativeScript = [alwaysFails @'PlutusV1 2, NativeScript nativeScript] ) -exampleTxBodyAlonzo :: TxBody AlonzoEra +exampleTxBodyAlonzo :: TxBody TopTx AlonzoEra exampleTxBodyAlonzo = AlonzoTxBody (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash 1)) 0]) -- inputs diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs index 139f7a0b18e..4106112910e 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -141,8 +141,8 @@ makeCollateralInput = do addCollateralInput :: AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) addCollateralInput tx | not (null (tx ^. bodyTxL . collateralInputsTxBodyL)) = pure tx | otherwise = do @@ -164,9 +164,9 @@ impLookupPlutusScript sh = do mkPlutusScript plutus impGetPlutusContexts :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> + Tx l era -> ImpTestM era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)] impGetPlutusContexts tx = do let txBody = tx ^. bodyTxL @@ -177,10 +177,10 @@ impGetPlutusContexts tx = do pure $ catMaybes mbyContexts fixupRedeemerIndices :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) fixupRedeemerIndices tx = impAnn "fixupRedeemerIndices" $ do (rootTxIn, _) <- getImpRootTxOut let @@ -194,8 +194,8 @@ fixupRedeemerIndices tx = impAnn "fixupRedeemerIndices" $ do fixupRedeemers :: forall era. (AlonzoEraImp era, HasCallStack) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) fixupRedeemers tx = impAnn "fixupRedeemers" $ do contexts <- impGetPlutusContexts tx pp <- getsNES $ nesEsL . curPParamsEpochStateL @@ -230,10 +230,10 @@ fixupRedeemers tx = impAnn "fixupRedeemers" $ do & witsTxL . rdmrsTxWitsL . unRedeemersL .~ Map.unions [oldRedeemers, newRedeemers, newMaxRedeemers] txWithMaxRedeemers :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) txWithMaxRedeemers tx = do contexts <- impGetPlutusContexts tx pp <- getsNES $ nesEsL . curPParamsEpochStateL @@ -245,10 +245,10 @@ txWithMaxRedeemers tx = do pure $ tx & witsTxL . rdmrsTxWitsL . unRedeemersL .~ newMaxRedeemers fixupScriptWits :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) fixupScriptWits tx = impAnn "fixupScriptWits" $ do contexts <- impGetPlutusContexts tx utxo <- getUTxO @@ -261,12 +261,12 @@ fixupScriptWits tx = impAnn "fixupScriptWits" $ do & witsTxL . scriptTxWitsL <>~ Map.fromList scriptWits fixupDatums :: - forall era. + forall era l. ( HasCallStack , AlonzoEraImp era ) => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) fixupDatums tx = impAnn "fixupDatums" $ do contexts <- impGetPlutusContexts tx let purposes = (^. _1) <$> contexts @@ -306,10 +306,10 @@ fixupDatums tx = impAnn "fixupDatums" $ do spendDatum _ = error "Context does not have a spending datum" fixupPPHash :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) fixupPPHash tx = impAnn "fixupPPHash" $ do integrityHash <- computeScriptIntegrityHash tx pure $ @@ -317,10 +317,10 @@ fixupPPHash tx = impAnn "fixupPPHash" $ do & bodyTxL . scriptIntegrityHashTxBodyL .~ integrityHash fixupOutputDatums :: - forall era. + forall era l. AlonzoEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) fixupOutputDatums tx = impAnn "fixupOutputDatums" $ do let addDatum txOut = @@ -336,8 +336,8 @@ alonzoFixupTx :: ( HasCallStack , AlonzoEraImp era ) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) alonzoFixupTx = addNativeScriptTxWits >=> fixupAuxDataHash @@ -355,7 +355,8 @@ alonzoFixupTx = >=> fixupPPHash >=> updateAddrTxWits -alonzoFixupFees :: forall era. (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (Tx era) +alonzoFixupFees :: + forall era. (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era (Tx TopTx era) alonzoFixupFees tx = do let originalRedeemers = tx ^. witsTxL . rdmrsTxWitsL txWithMax <- txWithMaxRedeemers tx @@ -464,7 +465,7 @@ impGetScriptContext sh = $ impLookupScriptContext @era sh impPlutusWithContexts :: - (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era [PlutusWithContext] + (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era [PlutusWithContext] impPlutusWithContexts tx = do globals <- use impGlobalsL pp <- getsNES $ nesEsL . curPParamsEpochStateL @@ -475,7 +476,7 @@ impPlutusWithContexts tx = do Right pwcs -> pure pwcs impScriptPredicateFailure :: - (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (AlonzoUtxosPredFailure era) + (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era (AlonzoUtxosPredFailure era) impScriptPredicateFailure tx = do plutusWithContexts <- impPlutusWithContexts tx when (null plutusWithContexts) $ @@ -497,7 +498,7 @@ submitPhase2Invalid_ :: ( HasCallStack , AlonzoEraImp era ) => - Tx era -> + Tx TopTx era -> ImpTestM era () submitPhase2Invalid_ = void . submitPhase2Invalid @@ -505,8 +506,8 @@ submitPhase2Invalid :: ( HasCallStack , AlonzoEraImp era ) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) submitPhase2Invalid tx = do fixedUpTx <- impAnn "Check that tx fails with IsValid True" $ do @@ -522,7 +523,7 @@ impAlonzoExpectTxSuccess :: ( HasCallStack , AlonzoEraImp era ) => - Tx era -> ImpTestM era () + Tx TopTx era -> ImpTestM era () impAlonzoExpectTxSuccess tx = do utxo <- getsNES utxoL let inputs = tx ^. bodyTxL . inputsTxBodyL @@ -548,7 +549,7 @@ computeScriptIntegrity :: AlonzoEraImp era => PParams era -> UTxO era -> - Tx era -> + Tx l era -> StrictMaybe (ScriptIntegrity era) computeScriptIntegrity pp utxo tx = mkScriptIntegrity pp tx scriptsProvided scriptsNeeded where @@ -557,11 +558,11 @@ computeScriptIntegrity pp utxo tx = mkScriptIntegrity pp tx scriptsProvided scri impComputeScriptIntegrity :: AlonzoEraImp era => - Tx era -> + Tx l era -> ImpTestM era (StrictMaybe (ScriptIntegrity era)) impComputeScriptIntegrity tx = computeScriptIntegrity <$> getsPParams id <*> getUTxO <*> pure tx computeScriptIntegrityHash :: - AlonzoEraImp era => Tx era -> ImpTestM era (StrictMaybe ScriptIntegrityHash) + AlonzoEraImp era => Tx l era -> ImpTestM era (StrictMaybe ScriptIntegrityHash) computeScriptIntegrityHash tx = fmap hashScriptIntegrity <$> impComputeScriptIntegrity tx diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/Golden.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/Golden.hs index a4675f163d3..295e26aa8b4 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/Golden.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/Golden.hs @@ -48,7 +48,7 @@ generateGoldenFile file = do assertTranslationResultsMatchGolden :: forall era. ( TranslatableGen era - , DecCBOR (Tx era) + , DecCBOR (Tx TopTx era) , HasCallStack ) => IO FilePath -> diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs index afeb65df3b3..078fc9aa73e 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs @@ -24,7 +24,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context ( ) import Cardano.Ledger.Alonzo.TxWits (Redeemers) import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) -import Cardano.Ledger.Core as Core +import Cardano.Ledger.Core import Cardano.Ledger.Plutus.Language (SLanguage (..)) import Cardano.Ledger.State (UTxO (..)) import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo) @@ -43,12 +43,12 @@ import Test.Cardano.Ledger.Common class (EraTx era, EraPlutusContext era, Arbitrary (Script era)) => TranslatableGen era where tgRedeemers :: Gen (Redeemers era) - tgTx :: SupportedLanguage era -> Gen (Core.Tx era) - tgUtxo :: SupportedLanguage era -> Core.Tx era -> Gen (UTxO era) + tgTx :: SupportedLanguage era -> Gen (Tx TopTx era) + tgUtxo :: SupportedLanguage era -> Tx TopTx era -> Gen (UTxO era) instance TranslatableGen AlonzoEra where tgRedeemers = arbitrary - tgTx _ = arbitrary :: Gen (Tx AlonzoEra) + tgTx _ = arbitrary tgUtxo _ tx = do let ins = tx ^. bodyTxL ^. inputsTxBodyL outs <- vectorOf (length ins) (arbitrary :: Gen (TxOut AlonzoEra)) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs index cff5ac778b0..f61a47e2d2d 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs @@ -56,16 +56,17 @@ data TranslationInstance era = TranslationInstance { tiProtVer :: ProtVer , tiLanguage :: SupportedLanguage era , tiUtxo :: UTxO era - , tiTx :: Core.Tx era + , tiTx :: Core.Tx TopTx era , tiResult :: VersionedTxInfo } deriving (Generic) deriving instance - (Era era, Eq (PParams era), Eq (UTxO era), Eq (Core.Tx era)) => Eq (TranslationInstance era) + (Era era, Eq (PParams era), Eq (UTxO era), Eq (Core.Tx TopTx era)) => Eq (TranslationInstance era) deriving instance - (Era era, Show (PParams era), Show (UTxO era), Show (Core.Tx era)) => Show (TranslationInstance era) + (Era era, Show (PParams era), Show (UTxO era), Show (Core.Tx TopTx era)) => + Show (TranslationInstance era) instance Cborg.Serialise PV1.DCert @@ -178,7 +179,7 @@ instance DecCBOR VersionedTxInfo where instance ( Era era , EncCBOR (UTxO era) - , EncCBOR (Core.Tx era) + , EncCBOR (Core.Tx TopTx era) ) => EncCBOR (TranslationInstance era) where @@ -194,7 +195,7 @@ instance instance ( DecCBOR (PParams era) , DecCBOR (UTxO era) - , DecCBOR (Core.Tx era) + , DecCBOR (Core.Tx TopTx era) , EraPlutusContext era ) => DecCBOR (TranslationInstance era) @@ -212,7 +213,7 @@ deserializeTranslationInstances :: forall era. ( DecCBOR (PParams era) , DecCBOR (UTxO era) - , DecCBOR (Core.Tx era) + , DecCBOR (Core.Tx TopTx era) , EraPlutusContext era ) => BSL.ByteString -> diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs index b1e08f0e1bb..cae010e5ab4 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs @@ -101,16 +101,42 @@ instance ToExpr DataHash32 instance ToExpr (CompactForm (Value era)) => ToExpr (AlonzoTxOut era) -- TxBody -instance ToExpr AlonzoTxBodyRaw +instance ToExpr (AlonzoTxBodyRaw TopTx AlonzoEra) where + toExpr AlonzoTxBodyRaw {..} = + Rec "AlonzoTxBodyRaw" $ + OMap.fromList + [ ("atbrInputs", toExpr atbrInputs) + , ("atbrCollateral", toExpr atbrCollateral) + , ("atbrOutputs", toExpr atbrOutputs) + , ("atbrCerts", toExpr atbrCerts) + , ("atbrWithdrawals", toExpr atbrWithdrawals) + , ("atbrTxFee", toExpr atbrTxFee) + , ("atbrValidityInterval", toExpr atbrValidityInterval) + , ("atbrUpdate", toExpr atbrUpdate) + , ("atbrReqSignerHashes", toExpr atbrReqSignerHashes) + , ("atbrMint", toExpr atbrMint) + , ("atbrScriptIntegrityHash", toExpr atbrScriptIntegrityHash) + , ("atbrAuxDataHash", toExpr atbrAuxDataHash) + , ("atbrTxNetworkId", toExpr atbrTxNetworkId) + ] -instance ToExpr (TxBody AlonzoEra) +instance ToExpr (TxBody TopTx AlonzoEra) -- Tx instance ToExpr IsValid instance - (ToExpr (TxBody era), ToExpr (TxWits era), ToExpr (TxAuxData era)) => - ToExpr (AlonzoTx era) + (ToExpr (TxBody TopTx era), ToExpr (TxWits era), ToExpr (TxAuxData era)) => + ToExpr (AlonzoTx TopTx era) + where + toExpr AlonzoTx {..} = + Rec "AlonzoTx" $ + OMap.fromList + [ ("atBody", toExpr atBody) + , ("atWits", toExpr atWits) + , ("atIsValid", toExpr atIsValid) + , ("atAuxData", toExpr atAuxData) + ] -- Plutus/TxInfo instance ToExpr (AlonzoContextError era) @@ -204,4 +230,4 @@ instance ) => ToExpr (TransactionScriptFailure era) -deriving newtype instance ToExpr (Tx AlonzoEra) +deriving newtype instance ToExpr (Tx TopTx AlonzoEra) diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index f36131d6c90..e2b21bbf161 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -300,7 +300,7 @@ genAlonzoTxBody :: Coin -> StrictMaybe (Update AlonzoEra) -> StrictMaybe TxAuxDataHash -> - Gen (TxBody AlonzoEra, [Script AlonzoEra]) + Gen (TxBody TopTx AlonzoEra, [Script AlonzoEra]) genAlonzoTxBody _genenv utxo pparams currentslot input txOuts certs withdrawals fee updates auxDHash = do netid <- genM $ pure Testnet -- frequency [(2, pure Mainnet), (1, pure Testnet)] startvalue <- genMint @@ -543,7 +543,7 @@ instance EraGen AlonzoEra where IsValid True -> tx ^. bodyTxL . feeTxBodyL IsValid False -> sumCollateral tx utxo -sumCollateral :: (EraTx era, AlonzoEraTxBody era) => Tx era -> UTxO era -> Coin +sumCollateral :: (EraTx era, AlonzoEraTxBody era) => Tx TopTx era -> UTxO era -> Coin sumCollateral tx utxo = sumCoinUTxO $ txInsFilter utxo $ tx ^. bodyTxL . collateralInputsTxBodyL diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs index a5e19c4ef2f..e8bffe3ebf4 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs @@ -60,7 +60,7 @@ instance , Embed (EraRule "UTXOW" era) (AlonzoLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Environment (EraRule "DELEGS" era) ~ DelegsEnv era , State (EraRule "DELEGS" era) ~ CertState era , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs index e057c9e199b..fb66e9408f6 100644 --- a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs +++ b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs @@ -291,7 +291,7 @@ goldenMinFee = Right (Block _bHeader bBody :: Block (BHeader StandardCrypto) AlonzoEra) -> bBody firstTx = case blockBody ^. txSeqBlockBodyL of - tx :<| _ -> (tx :: Tx AlonzoEra) + tx :<| _ -> (tx :: Tx TopTx AlonzoEra) Empty -> error "Block doesn't have any transactions" -- Below are the relevant protocol parameters that were active diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index c63a3f4d7a8..df1bf511f03 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -2,6 +2,26 @@ ## 1.12.1.0 +* Removed deprecated accessor functions: + - `spendInputs'` + - `collateralInputs'` + - `referenceInputs'` + - `outputs'` + - `collateralReturn'` + - `totalCollateral'` + - `certs'` + - `withdrawals'` + - `txfee'` + - `vldt'` + - `update'` + - `reqSignerHashes'` + - `mint'` + - `scriptIntegrityHash'` + - `adHash'` + - `txnetworkid'` +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Add `mkCollateralTxIn` ### `testlib` diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index 19561f523de..fa26c5187cd 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -84,7 +84,7 @@ library cardano-ledger-alonzo ^>=1.15, cardano-ledger-binary >=1.6, cardano-ledger-core:{cardano-ledger-core, internal} >=1.19, - cardano-ledger-mary ^>=1.9, + cardano-ledger-mary ^>=1.10, cardano-ledger-shelley ^>=1.18, cardano-strict-containers, containers, @@ -153,6 +153,7 @@ library testlib plutus-ledger-api, small-steps >=1.1, time, + tree-diff, executable huddle-cddl main-is: Main.hs diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Collateral.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Collateral.hs index b429b394db1..ea25ff81ddf 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Collateral.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Collateral.hs @@ -30,7 +30,7 @@ import Lens.Micro collAdaBalance :: forall era. BabbageEraTxBody era => - TxBody era -> + TxBody TopTx era -> Map.Map TxIn (TxOut era) -> DeltaCoin collAdaBalance txBody utxoCollateral = toDeltaCoin $ @@ -42,14 +42,14 @@ collAdaBalance txBody utxoCollateral = toDeltaCoin $ collOuts :: BabbageEraTxBody era => - TxBody era -> + TxBody TopTx era -> UTxO era collOuts txBody = case txBody ^. collateralReturnTxBodyL of SNothing -> UTxO Map.empty SJust txOut -> UTxO (Map.singleton (mkCollateralTxIn txBody) txOut) -mkCollateralTxIn :: EraTxBody era => TxBody era -> TxIn +mkCollateralTxIn :: EraTxBody era => TxBody l era -> TxIn mkCollateralTxIn txBody = TxIn (txIdTxBody txBody) txIx where txIx = case txIxFromIntegral (length (txBody ^. outputsTxBodyL)) of diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs index 086e4a3a1b3..891e959765e 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs @@ -35,6 +35,9 @@ import Cardano.Ledger.Shelley.Rules ( instance EraGenesis BabbageEra +instance EraTxLevel BabbageEra where + type STxLevel l BabbageEra = STxTopLevel l BabbageEra + type instance TranslationContext BabbageEra = NoGenesis BabbageEra type instance Value BabbageEra = MaryValue diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs index 44fb649a2d6..11ae336d46a 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs @@ -113,7 +113,7 @@ instance , Embed (EraRule "UTXOW" era) (BabbageLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Environment (EraRule "DELEGS" era) ~ DelegsEnv era , State (EraRule "DELEGS" era) ~ CertState era , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) @@ -126,7 +126,7 @@ instance STS (BabbageLEDGER era) where type State (BabbageLEDGER era) = LedgerState era - type Signal (BabbageLEDGER era) = Tx era + type Signal (BabbageLEDGER era) = Tx TopTx era type Environment (BabbageLEDGER era) = LedgerEnv era type BaseM (BabbageLEDGER era) = ShelleyBase type PredicateFailure (BabbageLEDGER era) = ShelleyLedgerPredFailure era diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs index f875a200c2d..c249273f6bb 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs @@ -201,7 +201,7 @@ feesOK :: , InjectRuleFailure rule BabbageUtxoPredFailure era ) => PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Test (EraRuleFailure rule era) feesOK pp tx u@(UTxO utxo) = @@ -245,7 +245,7 @@ validateTotalCollateral :: , InjectRuleFailure rule BabbageUtxoPredFailure era ) => PParams era -> - TxBody era -> + TxBody TopTx era -> Map.Map TxIn (TxOut era) -> Test (EraRuleFailure rule era) validateTotalCollateral pp txBody utxoCollateral = @@ -278,7 +278,7 @@ validateTotalCollateral pp txBody utxoCollateral = validateCollateralContainsNonADA :: forall era. BabbageEraTxBody era => - TxBody era -> + TxBody TopTx era -> Map.Map TxIn (TxOut era) -> Test (AlonzoUtxoPredFailure era) validateCollateralContainsNonADA txBody utxoCollateral = @@ -359,14 +359,14 @@ utxoTransition :: , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , BaseM (EraRule "UTXO" era) ~ ShelleyBase , STS (EraRule "UTXO" era) , -- In this function we we call the UTXOS rule, so we need some assumptions Embed (EraRule "UTXOS" era) (EraRule "UTXO" era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , State (EraRule "UTXOS" era) ~ UTxOState era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , EraCertState era ) => TransitionRule (EraRule "UTXO" era) @@ -462,14 +462,14 @@ instance Embed (EraRule "UTXOS" era) (BabbageUTXO era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , State (EraRule "UTXOS" era) ~ UTxOState era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , EraCertState era , SafeToHash (TxWits era) ) => STS (BabbageUTXO era) where type State (BabbageUTXO era) = UTxOState era - type Signal (BabbageUTXO era) = Tx era + type Signal (BabbageUTXO era) = Tx TopTx era type Environment (BabbageUTXO era) = UtxoEnv era type BaseM (BabbageUTXO era) = ShelleyBase type PredicateFailure (BabbageUTXO era) = BabbageUtxoPredFailure era diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs index fbee50cfb20..93c99f77f7b 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs @@ -105,7 +105,7 @@ instance , Environment (EraRule "PPUP" era) ~ PpupEnv era , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era) , State (EraRule "PPUP" era) ~ ShelleyGovState era - , Signal (BabbageUTXOS era) ~ Tx era + , Signal (BabbageUTXOS era) ~ Tx TopTx era , EncCBOR (EraRuleFailure "PPUP" era) , Eq (EraRuleFailure "PPUP" era) , Show (EraRuleFailure "PPUP" era) @@ -118,7 +118,7 @@ instance type BaseM (BabbageUTXOS era) = ShelleyBase type Environment (BabbageUTXOS era) = UtxoEnv era type State (BabbageUTXOS era) = UTxOState era - type Signal (BabbageUTXOS era) = Tx era + type Signal (BabbageUTXOS era) = Tx TopTx era type PredicateFailure (BabbageUTXOS era) = AlonzoUtxosPredFailure era type Event (BabbageUTXOS era) = AlonzoUtxosEvent era transitionRules = [utxosTransition] @@ -178,7 +178,7 @@ expectScriptsToPass :: , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era ) => PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Rule (EraRule "UTXOS" era) 'Transition () expectScriptsToPass pp tx utxo = do @@ -255,7 +255,7 @@ babbageEvalScriptsTxInvalid :: , ScriptsNeeded era ~ AlonzoScriptsNeeded era , STS (EraRule "UTXOS" era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , State (EraRule "UTXOS" era) ~ UTxOState era , BaseM (EraRule "UTXOS" era) ~ ShelleyBase , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs index 168050bea40..c873a7298a2 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs @@ -228,7 +228,7 @@ babbageMissingScripts _ sNeeded sRefs sReceived = {- ∀ s ∈ (txscripts txw utxo ∩ Scriptnative), validateScript s tx -} validateFailedBabbageScripts :: EraTx era => - Tx era -> + Tx TopTx era -> ScriptsProvided era -> Set ScriptHash -> Test (ShelleyUtxowPredFailure era) @@ -257,7 +257,7 @@ validateScriptsWellFormed :: , BabbageEraTxBody era ) => PParams era -> - Tx era -> + Tx TopTx era -> Test (BabbageUtxowPredFailure era) validateScriptsWellFormed pp tx = sequenceA_ @@ -292,7 +292,7 @@ babbageUtxowMirTransition :: , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , EraCertState era ) => Rule (EraRule "UTXOW" era) 'Transition () @@ -315,7 +315,7 @@ babbageUtxowTransition :: , ScriptsNeeded era ~ AlonzoScriptsNeeded era , BabbageEraTxBody era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , State (EraRule "UTXOW" era) ~ UTxOState era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , InjectRuleFailure "UTXOW" AlonzoUtxowPredFailure era @@ -323,7 +323,7 @@ babbageUtxowTransition :: , -- Allow UTXOW to call UTXO Embed (EraRule "UTXO" era) (EraRule "UTXOW" era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , State (EraRule "UTXO" era) ~ UTxOState era ) => TransitionRule (EraRule "UTXOW" era) @@ -408,7 +408,7 @@ instance Embed (EraRule "UTXO" era) (BabbageUTXOW era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , Eq (PredicateFailure (EraRule "UTXOS" era)) , Show (PredicateFailure (EraRule "UTXOS" era)) , EraCertState era @@ -416,7 +416,7 @@ instance STS (BabbageUTXOW era) where type State (BabbageUTXOW era) = UTxOState era - type Signal (BabbageUTXOW era) = Tx era + type Signal (BabbageUTXOW era) = Tx TopTx era type Environment (BabbageUTXOW era) = UtxoEnv era type BaseM (BabbageUTXOW era) = ShelleyBase type PredicateFailure (BabbageUTXOW era) = BabbageUtxowPredFailure era diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs index 4d95202d38b..0449132d4fe 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -58,23 +59,24 @@ instance TranslateEra BabbageEra NewEpochState where , stashedAVVMAddresses = () } -instance TranslateEra BabbageEra Tx where - type TranslationError BabbageEra Tx = DecoderError - translateEra _ctxt tx = do - -- Note that this does not preserve the hidden bytes field of the transaction. - -- This is under the premise that this is irrelevant for TxInBlocks, which are - -- not transmitted as contiguous chunks. - txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL - txWits <- translateEraThroughCBOR "TxWitness" $ tx ^. witsTxL - auxData <- case tx ^. auxDataTxL of - SNothing -> pure SNothing - SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData - let validating = tx ^. isValidTxL - pure $ - mkBasicTx txBody - & witsTxL .~ txWits - & auxDataTxL .~ auxData - & isValidTxL .~ validating +instance TranslateEra BabbageEra (Tx TopTx) where + type TranslationError BabbageEra (Tx TopTx) = DecoderError + translateEra _ctxt tx = + withTopTxLevelOnly tx $ \tx' -> do + -- Note that this does not preserve the hidden bytes field of the transaction. + -- This is under the premise that this is irrelevant for TxInBlocks, which are + -- not transmitted as contiguous chunks. + txBody <- translateEraThroughCBOR "TxBody" $ tx' ^. bodyTxL + txWits <- translateEraThroughCBOR "TxWitness" $ tx' ^. witsTxL + auxData <- case tx' ^. auxDataTxL of + SNothing -> pure SNothing + SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData + let validating = tx' ^. isValidTxL + pure . asSTxTopLevel $ + mkBasicTx txBody + & witsTxL .~ txWits + & auxDataTxL .~ auxData + & isValidTxL .~ validating -------------------------------------------------------------------------------- -- Auxiliary instances and functions diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs index fa87e60fda2..7469f1d7c9b 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -25,12 +27,16 @@ import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR, ToCBOR) import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes (EqRaw (..)) import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro (Lens', lens) import NoThunks.Class (NoThunks) +instance HasEraTxLevel Tx BabbageEra where + toSTxLevel (MkBabbageTx AlonzoTx {}) = STopTxOnly @BabbageEra + instance EraTx BabbageEra where - newtype Tx BabbageEra = MkBabbageTx {unBabbageTx :: AlonzoTx BabbageEra} + newtype Tx l BabbageEra = MkBabbageTx {unBabbageTx :: AlonzoTx l BabbageEra} deriving newtype (Eq, NFData, Show, NoThunks, ToCBOR, EncCBOR) deriving (Generic) mkBasicTx = MkBabbageTx . mkBasicAlonzoTx @@ -52,15 +58,15 @@ instance EraTx BabbageEra where getMinFeeTx pp tx _ = alonzoMinFeeTx pp tx -instance EqRaw (Tx BabbageEra) where +instance EqRaw (Tx l BabbageEra) where eqRaw = alonzoTxEqRaw instance AlonzoEraTx BabbageEra where isValidTxL = babbageTxL . isValidAlonzoTxL {-# INLINE isValidTxL #-} -instance DecCBOR (Annotator (Tx BabbageEra)) where +instance Typeable l => DecCBOR (Annotator (Tx l BabbageEra)) where decCBOR = fmap MkBabbageTx <$> decCBOR -babbageTxL :: Lens' (Tx BabbageEra) (AlonzoTx BabbageEra) +babbageTxL :: Lens' (Tx l BabbageEra) (AlonzoTx l BabbageEra) babbageTxL = lens unBabbageTx (\x y -> x {unBabbageTx = y}) diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs index e2366cde3bb..4d3b8609a48 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs @@ -1,18 +1,20 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} @@ -52,22 +54,6 @@ module Cardano.Ledger.Babbage.TxBody ( babbageAllInputsTxBodyF, babbageSpendableInputsTxBodyF, BabbageEraTxBody (..), - spendInputs', - collateralInputs', - referenceInputs', - outputs', - collateralReturn', - totalCollateral', - certs', - withdrawals', - txfee', - vldt', - update', - reqSignerHashes', - mint', - scriptIntegrityHash', - adHash', - txnetworkid', getEitherAddrBabbageTxOut, EraIndependentScriptIntegrity, ScriptIntegrityHash, @@ -81,13 +67,13 @@ import Cardano.Ledger.Alonzo.TxBody (alonzoRedeemerPointer, alonzoRedeemerPointe import Cardano.Ledger.Babbage.Era (BabbageEra) import Cardano.Ledger.Babbage.Scripts () import Cardano.Ledger.Babbage.TxCert () -import Cardano.Ledger.Babbage.TxOut hiding (TxOut) +import Cardano.Ledger.Babbage.TxOut import Cardano.Ledger.BaseTypes ( Network (..), StrictMaybe (..), ) import Cardano.Ledger.Binary ( - Annotator, + Annotator (..), DecCBOR (..), EncCBOR (..), Sized (..), @@ -96,7 +82,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Mary.Value (MultiAsset, policies) +import Cardano.Ledger.Mary.Value (MultiAsset) import Cardano.Ledger.MemoBytes ( EqRaw, Mem, @@ -113,105 +99,132 @@ import Cardano.Ledger.MemoBytes ( import Cardano.Ledger.Shelley.PParams (Update (..)) import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) import Cardano.Ledger.TxIn (TxIn (..)) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), deepseq) import Data.Foldable as F (foldl') import Data.Sequence.Strict (StrictSeq, (|>)) import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro -import NoThunks.Class (NoThunks) +import NoThunks.Class (InspectHeap (..), NoThunks) class (AlonzoEraTxBody era, BabbageEraTxOut era) => BabbageEraTxBody era where - sizedOutputsTxBodyL :: Lens' (TxBody era) (StrictSeq (Sized (TxOut era))) + sizedOutputsTxBodyL :: Lens' (TxBody l era) (StrictSeq (Sized (TxOut era))) - referenceInputsTxBodyL :: Lens' (TxBody era) (Set TxIn) + referenceInputsTxBodyL :: Lens' (TxBody l era) (Set TxIn) - totalCollateralTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) + totalCollateralTxBodyL :: Lens' (TxBody TopTx era) (StrictMaybe Coin) - collateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (TxOut era)) + collateralReturnTxBodyL :: Lens' (TxBody TopTx era) (StrictMaybe (TxOut era)) - sizedCollateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (Sized (TxOut era))) + sizedCollateralReturnTxBodyL :: Lens' (TxBody TopTx era) (StrictMaybe (Sized (TxOut era))) - allSizedOutputsTxBodyF :: SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) + allSizedOutputsTxBodyF :: SimpleGetter (TxBody l era) (StrictSeq (Sized (TxOut era))) -- ====================================== -data BabbageTxBodyRaw = BabbageTxBodyRaw - { btbrInputs :: !(Set TxIn) - , btbrCollateralInputs :: !(Set TxIn) - , btbrReferenceInputs :: !(Set TxIn) - , btbrOutputs :: !(StrictSeq (Sized (TxOut BabbageEra))) - , btbrCollateralReturn :: !(StrictMaybe (Sized (TxOut BabbageEra))) - , btbrTotalCollateral :: !(StrictMaybe Coin) - , btbrCerts :: !(StrictSeq (TxCert BabbageEra)) - , btbrWithdrawals :: !Withdrawals - , btbrFee :: !Coin - , btbrValidityInterval :: !ValidityInterval - , btbrUpdate :: !(StrictMaybe (Update BabbageEra)) - , btbrReqSignerHashes :: !(Set (KeyHash 'Guard)) - , btbrMint :: !MultiAsset - , -- The spec makes it clear that the mint field is a - -- Cardano.Ledger.Mary.Value.MaryValue, not a Value. - -- Operations on the TxBody in the BabbageEra depend upon this. - -- We now store only the MultiAsset part of a Mary.Value. - btbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) - , btbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - , btbrNetworkId :: !(StrictMaybe Network) - } - deriving (Generic) +data BabbageTxBodyRaw l era where + BabbageTxBodyRaw :: + { btbrInputs :: !(Set TxIn) + , btbrCollateralInputs :: !(Set TxIn) + , btbrReferenceInputs :: !(Set TxIn) + , btbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , btbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , btbrTotalCollateral :: !(StrictMaybe Coin) + , btbrCerts :: !(StrictSeq (TxCert era)) + , btbrWithdrawals :: !Withdrawals + , btbrFee :: !Coin + , btbrValidityInterval :: !ValidityInterval + , btbrUpdate :: !(StrictMaybe (Update era)) + , btbrReqSignerHashes :: !(Set (KeyHash 'Guard)) + , btbrMint :: !MultiAsset + , -- The spec makes it clear that the mint field is a + -- Cardano.Ledger.Mary.Value.MaryValue, not a Value. + -- Operations on the TxBody in the BabbageEra depend upon this. + -- We now store only the MultiAsset part of a Mary.Value. + btbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , btbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , btbrNetworkId :: !(StrictMaybe Network) + } -> + BabbageTxBodyRaw TopTx era + +deriving instance Eq (BabbageTxBodyRaw l BabbageEra) + +deriving instance Show (BabbageTxBodyRaw l BabbageEra) + +instance NFData (BabbageTxBodyRaw l BabbageEra) where + rnf BabbageTxBodyRaw {..} = + btbrInputs `deepseq` + btbrCollateralInputs `deepseq` + btbrReferenceInputs `deepseq` + btbrOutputs `deepseq` + btbrCollateralReturn `deepseq` + btbrTotalCollateral `deepseq` + btbrCerts `deepseq` + btbrWithdrawals `deepseq` + btbrFee `deepseq` + btbrValidityInterval `deepseq` + btbrUpdate `deepseq` + btbrReqSignerHashes `deepseq` + btbrMint `deepseq` + btbrScriptIntegrityHash `deepseq` + btbrAuxDataHash `deepseq` + rnf btbrNetworkId -- We override this instance because the 'Sized' types also reference their -- serialisation and as such cannot be compared directly. An alternative would -- be to derive `EqRaw` for `Sized`. -instance EqRaw BabbageTxBodyRaw where +instance EqRaw (BabbageTxBodyRaw l BabbageEra) where eqRaw a b = - btbrInputs a == btbrInputs b - && btbrCollateralInputs a == btbrCollateralInputs b - && btbrReferenceInputs a == btbrReferenceInputs b - && btbrOutputs a `eqSeqUnsized` btbrOutputs b - && btbrCollateralReturn a `eqMbUnsized` btbrCollateralReturn b - && btbrTotalCollateral a == btbrTotalCollateral b - && btbrCerts a == btbrCerts b - && btbrWithdrawals a == btbrWithdrawals b - && btbrFee a == btbrFee b - && btbrValidityInterval a == btbrValidityInterval b - && btbrUpdate a == btbrUpdate b - && btbrReqSignerHashes a == btbrReqSignerHashes b - && btbrMint a == btbrMint b - && btbrScriptIntegrityHash a == btbrScriptIntegrityHash b - && btbrAuxDataHash a == btbrAuxDataHash b - && btbrNetworkId a == btbrNetworkId b - where - eqMbUnsized x y = case (x, y) of - (SJust a', SJust b') -> a' `eqUnsized` b' - (SNothing, SNothing) -> True - _ -> False - eqSeqUnsized x y = - length x == length y - && F.foldl' (\acc (x', y') -> acc && x' `eqUnsized` y') True (StrictSeq.zip x y) - eqUnsized x y = sizedValue x == sizedValue y - -type instance MemoHashIndex BabbageTxBodyRaw = EraIndependentTxBody - -deriving instance Eq BabbageTxBodyRaw - -instance NoThunks BabbageTxBodyRaw - -instance NFData BabbageTxBodyRaw - -deriving instance Show BabbageTxBodyRaw - -deriving via Mem BabbageTxBodyRaw instance DecCBOR (Annotator (TxBody BabbageEra)) - -instance Memoized (TxBody BabbageEra) where - type RawType (TxBody BabbageEra) = BabbageTxBodyRaw - -deriving newtype instance NFData (TxBody BabbageEra) + case toSTxLevel a of + STopTxOnly -> + btbrInputs a == btbrInputs b + && btbrCollateralInputs a == btbrCollateralInputs b + && btbrReferenceInputs a == btbrReferenceInputs b + && btbrOutputs a `eqSeqUnsized` btbrOutputs b + && btbrCollateralReturn a `eqMbUnsized` btbrCollateralReturn b + && btbrTotalCollateral a == btbrTotalCollateral b + && btbrCerts a == btbrCerts b + && btbrWithdrawals a == btbrWithdrawals b + && btbrFee a == btbrFee b + && btbrValidityInterval a == btbrValidityInterval b + && btbrUpdate a == btbrUpdate b + && btbrReqSignerHashes a == btbrReqSignerHashes b + && btbrMint a == btbrMint b + && btbrScriptIntegrityHash a == btbrScriptIntegrityHash b + && btbrAuxDataHash a == btbrAuxDataHash b + && btbrNetworkId a == btbrNetworkId b + where + eqMbUnsized x y = case (x, y) of + (SJust a', SJust b') -> a' `eqUnsized` b' + (SNothing, SNothing) -> True + _ -> False + eqSeqUnsized x y = + length x == length y + && F.foldl' (\acc (x', y') -> acc && x' `eqUnsized` y') True (StrictSeq.zip x y) + eqUnsized x y = sizedValue x == sizedValue y + +type instance MemoHashIndex (BabbageTxBodyRaw l era) = EraIndependentTxBody + +deriving via + InspectHeap (BabbageTxBodyRaw l BabbageEra) + instance + Typeable l => NoThunks (BabbageTxBodyRaw l BabbageEra) + +deriving via + Mem (BabbageTxBodyRaw l BabbageEra) + instance + Typeable l => DecCBOR (Annotator (TxBody l BabbageEra)) + +instance Memoized (TxBody l BabbageEra) where + type RawType (TxBody l BabbageEra) = BabbageTxBodyRaw l BabbageEra + +deriving newtype instance NFData (TxBody l BabbageEra) babbageSpendableInputsTxBodyF :: - BabbageEraTxBody era => SimpleGetter (TxBody era) (Set TxIn) + BabbageEraTxBody era => SimpleGetter (TxBody TopTx era) (Set TxIn) babbageSpendableInputsTxBodyF = to $ \txBody -> (txBody ^. inputsTxBodyL) @@ -219,17 +232,18 @@ babbageSpendableInputsTxBodyF = {-# INLINEABLE babbageSpendableInputsTxBodyF #-} babbageAllInputsTxBodyF :: - BabbageEraTxBody era => SimpleGetter (TxBody era) (Set TxIn) + BabbageEraTxBody era => SimpleGetter (TxBody TopTx era) (Set TxIn) babbageAllInputsTxBodyF = - to $ \txBody -> - (txBody ^. inputsTxBodyL) - `Set.union` (txBody ^. collateralInputsTxBodyL) - `Set.union` (txBody ^. referenceInputsTxBodyL) + to $ + \txBody -> + (txBody ^. inputsTxBodyL) + `Set.union` (txBody ^. collateralInputsTxBodyL) + `Set.union` (txBody ^. referenceInputsTxBodyL) {-# INLINEABLE babbageAllInputsTxBodyF #-} allSizedOutputsBabbageTxBodyF :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) + SimpleGetter (TxBody TopTx era) (StrictSeq (Sized (TxOut era))) allSizedOutputsBabbageTxBodyF = to $ \txBody -> let txOuts = txBody ^. sizedOutputsTxBodyL @@ -238,43 +252,52 @@ allSizedOutputsBabbageTxBodyF = SJust collTxOut -> txOuts |> collTxOut {-# INLINEABLE allSizedOutputsBabbageTxBodyF #-} +instance HasEraTxLevel BabbageTxBodyRaw BabbageEra where + toSTxLevel BabbageTxBodyRaw {} = STopTxOnly + +instance HasEraTxLevel TxBody BabbageEra where + toSTxLevel = toSTxLevel . getMemoRawType + +basicBabbageTxBody :: Typeable l => TxBody l BabbageEra +basicBabbageTxBody = mkMemoizedEra @BabbageEra $ asSTxTopLevel basicBabbageTxBodyRaw + instance EraTxBody BabbageEra where - newtype TxBody BabbageEra = MkBabbageTxBody (MemoBytes BabbageTxBodyRaw) - deriving newtype (Generic, SafeToHash, ToCBOR) + newtype TxBody l BabbageEra = MkBabbageTxBody (MemoBytes (BabbageTxBodyRaw l BabbageEra)) + deriving newtype (Generic, SafeToHash, ToCBOR, Eq) - mkBasicTxBody = mkMemoizedEra @BabbageEra basicBabbageTxBodyRaw + mkBasicTxBody = basicBabbageTxBody inputsTxBodyL = - lensMemoRawType @BabbageEra btbrInputs $ \txBodyRaw inputs -> txBodyRaw {btbrInputs = inputs} + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrInputs} -> btbrInputs) $ \txBodyRaw inputs -> txBodyRaw {btbrInputs = inputs} {-# INLINE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @BabbageEra (fmap sizedValue . btbrOutputs) $ \txBodyRaw outputs -> + lensMemoRawType @BabbageEra (fmap sizedValue . (\BabbageTxBodyRaw {btbrOutputs} -> btbrOutputs)) $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = mkSized (eraProtVerLow @BabbageEra) <$> outputs} {-# INLINE outputsTxBodyL #-} feeTxBodyL = - lensMemoRawType @BabbageEra btbrFee $ \txBodyRaw fee -> txBodyRaw {btbrFee = fee} + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrFee} -> btbrFee) $ \txBodyRaw fee -> txBodyRaw {btbrFee = fee} {-# INLINE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType @BabbageEra btbrAuxDataHash $ \txBodyRaw auxDataHash -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrAuxDataHash} -> btbrAuxDataHash) $ \txBodyRaw auxDataHash -> txBodyRaw {btbrAuxDataHash = auxDataHash} {-# INLINE auxDataHashTxBodyL #-} - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + spendableInputsTxBodyF = to (`withTopTxLevelOnly` (^. babbageSpendableInputsTxBodyF)) {-# INLINE spendableInputsTxBodyF #-} allInputsTxBodyF = babbageAllInputsTxBodyF {-# INLINE allInputsTxBodyF #-} withdrawalsTxBodyL = - lensMemoRawType @BabbageEra btbrWithdrawals $ + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrWithdrawals} -> btbrWithdrawals) $ \txBodyRaw withdrawals -> txBodyRaw {btbrWithdrawals = withdrawals} {-# INLINE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @BabbageEra btbrCerts $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrCerts} -> btbrCerts) $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} {-# INLINE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -289,35 +312,32 @@ instance ShelleyEraTxBody BabbageEra where instance AllegraEraTxBody BabbageEra where vldtTxBodyL = - lensMemoRawType @BabbageEra btbrValidityInterval $ \txBodyRaw vldt -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrValidityInterval} -> btbrValidityInterval) $ \txBodyRaw vldt -> txBodyRaw {btbrValidityInterval = vldt} {-# INLINE vldtTxBodyL #-} instance MaryEraTxBody BabbageEra where mintTxBodyL = - lensMemoRawType @BabbageEra btbrMint $ \txBodyRaw mint -> txBodyRaw {btbrMint = mint} + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrMint} -> btbrMint) $ \txBodyRaw mint -> txBodyRaw {btbrMint = mint} {-# INLINE mintTxBodyL #-} - mintedTxBodyF = to (policies . btbrMint . getMemoRawType) - {-# INLINE mintedTxBodyF #-} - instance AlonzoEraTxBody BabbageEra where collateralInputsTxBodyL = - lensMemoRawType @BabbageEra btbrCollateralInputs $ \txBodyRaw collateral -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrCollateralInputs} -> btbrCollateralInputs) $ \txBodyRaw collateral -> txBodyRaw {btbrCollateralInputs = collateral} {-# INLINE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = - lensMemoRawType @BabbageEra btbrReqSignerHashes $ \txBodyRaw reqSignerHashes -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrReqSignerHashes} -> btbrReqSignerHashes) $ \txBodyRaw reqSignerHashes -> txBodyRaw {btbrReqSignerHashes = reqSignerHashes} {-# INLINE reqSignerHashesTxBodyL #-} scriptIntegrityHashTxBodyL = - lensMemoRawType @BabbageEra btbrScriptIntegrityHash $ \txBodyRaw scriptIntegrityHash -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrScriptIntegrityHash} -> btbrScriptIntegrityHash) $ \txBodyRaw scriptIntegrityHash -> txBodyRaw {btbrScriptIntegrityHash = scriptIntegrityHash} {-# INLINE scriptIntegrityHashTxBodyL #-} - networkIdTxBodyL = lensMemoRawType @BabbageEra btbrNetworkId $ \txBodyRaw networkId -> + networkIdTxBodyL = lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrNetworkId} -> btbrNetworkId) $ \txBodyRaw networkId -> txBodyRaw {btbrNetworkId = networkId} {-# INLINE networkIdTxBodyL #-} @@ -327,41 +347,40 @@ instance AlonzoEraTxBody BabbageEra where instance BabbageEraTxBody BabbageEra where sizedOutputsTxBodyL = - lensMemoRawType @BabbageEra btbrOutputs $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrOutputs} -> btbrOutputs) $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} {-# INLINE sizedOutputsTxBodyL #-} referenceInputsTxBodyL = - lensMemoRawType @BabbageEra btbrReferenceInputs $ \txBodyRaw reference -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrReferenceInputs} -> btbrReferenceInputs) $ \txBodyRaw reference -> txBodyRaw {btbrReferenceInputs = reference} {-# INLINE referenceInputsTxBodyL #-} totalCollateralTxBodyL = - lensMemoRawType @BabbageEra btbrTotalCollateral $ \txBodyRaw totalCollateral -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrTotalCollateral} -> btbrTotalCollateral) $ \txBodyRaw totalCollateral -> txBodyRaw {btbrTotalCollateral = totalCollateral} {-# INLINE totalCollateralTxBodyL #-} collateralReturnTxBodyL = - lensMemoRawType @BabbageEra (fmap sizedValue . btbrCollateralReturn) $ - \txBodyRaw collateralReturn -> + lensMemoRawType @BabbageEra + (fmap sizedValue . (\BabbageTxBodyRaw {btbrCollateralReturn} -> btbrCollateralReturn)) + $ \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = mkSized (eraProtVerLow @BabbageEra) <$> collateralReturn} {-# INLINE collateralReturnTxBodyL #-} sizedCollateralReturnTxBodyL = - lensMemoRawType @BabbageEra btbrCollateralReturn $ \txBodyRaw collateralReturn -> + lensMemoRawType @BabbageEra (\BabbageTxBodyRaw {btbrCollateralReturn} -> btbrCollateralReturn) $ \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = collateralReturn} {-# INLINE sizedCollateralReturnTxBodyL #-} - allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + allSizedOutputsTxBodyF = to (`withTopTxLevelOnly` (^. allSizedOutputsBabbageTxBodyF)) {-# INLINE allSizedOutputsTxBodyF #-} -instance EqRaw (TxBody BabbageEra) where +instance EqRaw (TxBody l BabbageEra) where eqRaw = zipMemoRawType eqRaw -deriving newtype instance Eq (TxBody BabbageEra) - -deriving instance NoThunks (TxBody BabbageEra) +deriving instance Typeable l => NoThunks (TxBody l BabbageEra) -deriving instance Show (TxBody BabbageEra) +deriving instance Show (TxBody l BabbageEra) pattern BabbageTxBody :: Set TxIn -> @@ -380,7 +399,7 @@ pattern BabbageTxBody :: StrictMaybe ScriptIntegrityHash -> StrictMaybe TxAuxDataHash -> StrictMaybe Network -> - TxBody BabbageEra + TxBody TopTx BabbageEra pattern BabbageTxBody { btbInputs , btbCollateral @@ -459,87 +478,17 @@ pattern BabbageTxBody {-# COMPLETE BabbageTxBody #-} -instance HashAnnotated (TxBody BabbageEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l BabbageEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash --- ============================================================================== --- We define these accessor functions manually, because if we define them using --- the record syntax in the TxBody pattern, they inherit the (BabbageBody era) --- constraint as a precondition. This is unnecessary, as one can see below --- they need not be constrained at all. This should be fixed in the GHC compiler. - -spendInputs' :: TxBody BabbageEra -> Set TxIn -collateralInputs' :: TxBody BabbageEra -> Set TxIn -referenceInputs' :: TxBody BabbageEra -> Set TxIn -outputs' :: TxBody BabbageEra -> StrictSeq (TxOut BabbageEra) -collateralReturn' :: TxBody BabbageEra -> StrictMaybe (TxOut BabbageEra) -totalCollateral' :: TxBody BabbageEra -> StrictMaybe Coin -certs' :: TxBody BabbageEra -> StrictSeq (TxCert BabbageEra) -txfee' :: TxBody BabbageEra -> Coin -withdrawals' :: TxBody BabbageEra -> Withdrawals -vldt' :: TxBody BabbageEra -> ValidityInterval -update' :: TxBody BabbageEra -> StrictMaybe (Update BabbageEra) -reqSignerHashes' :: TxBody BabbageEra -> Set (KeyHash 'Guard) -adHash' :: TxBody BabbageEra -> StrictMaybe TxAuxDataHash -mint' :: TxBody BabbageEra -> MultiAsset -scriptIntegrityHash' :: TxBody BabbageEra -> StrictMaybe ScriptIntegrityHash -txnetworkid' :: TxBody BabbageEra -> StrictMaybe Network -spendInputs' = btbrInputs . getMemoRawType -{-# DEPRECATED spendInputs' "In favor of `inputsTxBodyL`" #-} - -collateralInputs' = btbrCollateralInputs . getMemoRawType -{-# DEPRECATED collateralInputs' "In favor of `collateralInputsTxBodyL`" #-} - -referenceInputs' = btbrReferenceInputs . getMemoRawType -{-# DEPRECATED referenceInputs' "In favor of `referenceInputsTxBodyL`" #-} - -outputs' = fmap sizedValue . btbrOutputs . getMemoRawType -{-# DEPRECATED outputs' "In favor of `outputsTxBodyL`" #-} - -collateralReturn' = fmap sizedValue . btbrCollateralReturn . getMemoRawType -{-# DEPRECATED collateralReturn' "In favor of `collateralReturnTxBodyL`" #-} - -totalCollateral' = btbrTotalCollateral . getMemoRawType -{-# DEPRECATED totalCollateral' "In favor of `totalCollateralTxBodyL`" #-} - -certs' = btbrCerts . getMemoRawType -{-# DEPRECATED certs' "In favor of `certsTxBodyL`" #-} - -withdrawals' = btbrWithdrawals . getMemoRawType -{-# DEPRECATED withdrawals' "In favor of `withdrawalsTxBodyL`" #-} - -txfee' = btbrFee . getMemoRawType -{-# DEPRECATED txfee' "In favor of `feeTxBodyL`" #-} - -vldt' = btbrValidityInterval . getMemoRawType -{-# DEPRECATED vldt' "In favor of `vldtTxBodyL`" #-} - -update' = btbrUpdate . getMemoRawType -{-# DEPRECATED update' "In favor of `updateTxBodyL`" #-} - -reqSignerHashes' = btbrReqSignerHashes . getMemoRawType -{-# DEPRECATED reqSignerHashes' "In favor of `reqSignerHashesTxBodyL`" #-} - -adHash' = btbrAuxDataHash . getMemoRawType -{-# DEPRECATED adHash' "In favor of `auxDataHashTxBodyL`" #-} - -mint' = btbrMint . getMemoRawType -{-# DEPRECATED mint' "In favor of `mintTxBodyL`" #-} - -scriptIntegrityHash' = btbrScriptIntegrityHash . getMemoRawType -{-# DEPRECATED scriptIntegrityHash' "In favor of `scriptIntegrityHashTxBodyL`" #-} - -txnetworkid' = btbrNetworkId . getMemoRawType -{-# DEPRECATED txnetworkid' "In favor of `networkIdTxBodyL`" #-} - -------------------------------------------------------------------------------- -- Serialisation -------------------------------------------------------------------------------- -- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody BabbageEra) +deriving newtype instance EncCBOR (TxBody l BabbageEra) -instance EncCBOR BabbageTxBodyRaw where +instance EncCBOR (BabbageTxBodyRaw l BabbageEra) where encCBOR BabbageTxBodyRaw { btbrInputs @@ -582,16 +531,16 @@ instance EncCBOR BabbageTxBodyRaw where !> encodeKeyedStrictMaybe 7 btbrAuxDataHash !> encodeKeyedStrictMaybe 15 btbrNetworkId -instance DecCBOR BabbageTxBodyRaw where +instance Typeable l => DecCBOR (BabbageTxBodyRaw l BabbageEra) where decCBOR = - decode $ + fmap asSTxTopLevel . decode $ SparseKeyed "BabbageTxBodyRaw" - basicBabbageTxBodyRaw + (asSTxTopLevel basicBabbageTxBodyRaw) bodyFields requiredFields where - bodyFields :: Word -> Field BabbageTxBodyRaw + bodyFields :: Word -> Field (BabbageTxBodyRaw TopTx BabbageEra) bodyFields 0 = field (\x tx -> tx {btbrInputs = x}) From bodyFields 13 = field (\x tx -> tx {btbrCollateralInputs = x}) From bodyFields 18 = field (\x tx -> tx {btbrReferenceInputs = x}) From @@ -625,10 +574,10 @@ instance DecCBOR BabbageTxBodyRaw where ] {-# INLINE decCBOR #-} -instance DecCBOR (Annotator BabbageTxBodyRaw) where +instance Typeable l => DecCBOR (Annotator (BabbageTxBodyRaw l BabbageEra)) where decCBOR = pure <$> decCBOR -basicBabbageTxBodyRaw :: BabbageTxBodyRaw +basicBabbageTxBodyRaw :: BabbageTxBodyRaw TopTx era basicBabbageTxBodyRaw = BabbageTxBodyRaw mempty diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs index 5774c966828..9f1568f911b 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs @@ -186,14 +186,14 @@ transRedeemer :: Data era -> PV2.Redeemer transRedeemer = PV2.Redeemer . PV2.dataToBuiltinData . getPlutusData transRedeemerPtr :: - forall proxy l era. + forall proxy l era t. ( EraPlutusTxInfo l era , AlonzoEraTxBody era , Inject (BabbageContextError era) (ContextError era) ) => proxy l -> ProtVer -> - TxBody era -> + TxBody t era -> (PlutusPurpose AsIx era, (Data era, ExUnits)) -> Either (ContextError era) (PlutusScriptPurpose l, PV2.Redeemer) transRedeemerPtr proxy pv txBody (ptr, (d, _)) = @@ -214,7 +214,7 @@ transTxRedeemers :: ) => proxy l -> ProtVer -> - Tx era -> + Tx t era -> Either (ContextError era) (PV2.Map (PlutusScriptPurpose l) PV2.Redeemer) transTxRedeemers proxy pv tx = PV2.unsafeFromList diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs index 327fcea9b7a..942af5495a1 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs @@ -44,7 +44,8 @@ instance EraUTxO BabbageEra where getConsumedValue = getConsumedMaryValue - getProducedValue = getProducedMaryValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (getProducedMaryValue pp isRegPoolId) getScriptsProvided = getBabbageScriptsProvided @@ -65,7 +66,7 @@ instance AlonzoEraUTxO BabbageEra where getBabbageSupplementalDataHashes :: BabbageEraTxBody era => UTxO era -> - TxBody era -> + TxBody l era -> Set.Set DataHash getBabbageSupplementalDataHashes (UTxO utxo) txBody = Set.fromList [dh | txOut <- outs, SJust dh <- [txOut ^. dataHashTxOutL]] @@ -81,7 +82,7 @@ getBabbageSpendingDatum :: , BabbageEraTxOut era ) => UTxO era -> - Tx era -> + Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era) getBabbageSpendingDatum (UTxO utxo) tx sp = do @@ -129,7 +130,7 @@ getBabbageScriptsProvided :: , BabbageEraTxBody era ) => UTxO era -> - Tx era -> + Tx l era -> ScriptsProvided era getBabbageScriptsProvided utxo tx = ScriptsProvided ans where diff --git a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs index 88e486a0125..2b3dcd329b4 100644 --- a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs +++ b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs @@ -32,8 +32,8 @@ spec = let v = eraProtVerHigh @BabbageEra describe "Ruby-based" $ beforeAllCddlFile 3 readBabbageCddlFiles $ do cddlRoundTripCborSpec @(Value BabbageEra) v "coin" - cddlRoundTripAnnCborSpec @(TxBody BabbageEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody BabbageEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx BabbageEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx BabbageEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock BabbageEra) v "native_script" @@ -50,21 +50,21 @@ spec = cddlRoundTripCborSpec @CostModels v "cost_models" cddlRoundTripAnnCborSpec @(Redeemers BabbageEra) v "redeemers" cddlRoundTripCborSpec @(Redeemers BabbageEra) v "redeemers" - cddlRoundTripAnnCborSpec @(Tx BabbageEra) v "transaction" - cddlRoundTripCborSpec @(Tx BabbageEra) v "transaction" + cddlRoundTripAnnCborSpec @(Tx TopTx BabbageEra) v "transaction" + cddlRoundTripCborSpec @(Tx TopTx BabbageEra) v "transaction" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody BabbageEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx BabbageEra) v "transaction_body" cddlDecoderEquivalenceSpec @(TxAuxData BabbageEra) v "auxiliary_data" cddlDecoderEquivalenceSpec @(Timelock BabbageEra) v "native_script" cddlDecoderEquivalenceSpec @(Data BabbageEra) v "plutus_data" cddlDecoderEquivalenceSpec @(Script BabbageEra) v "script" cddlDecoderEquivalenceSpec @(TxWits BabbageEra) v "transaction_witness_set" cddlDecoderEquivalenceSpec @(Redeemers BabbageEra) v "redeemers" - cddlDecoderEquivalenceSpec @(Tx BabbageEra) v "transaction" + cddlDecoderEquivalenceSpec @(Tx TopTx BabbageEra) v "transaction" describe "Huddle" $ specWithHuddle babbageCDDL 100 $ do huddleRoundTripCborSpec @(Value BabbageEra) v "coin" - huddleRoundTripAnnCborSpec @(TxBody BabbageEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody BabbageEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx BabbageEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx BabbageEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" huddleRoundTripCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Timelock BabbageEra) v "native_script" @@ -81,14 +81,14 @@ spec = huddleRoundTripCborSpec @CostModels v "cost_models" huddleRoundTripAnnCborSpec @(Redeemers BabbageEra) v "redeemers" huddleRoundTripCborSpec @(Redeemers BabbageEra) v "redeemers" - huddleRoundTripAnnCborSpec @(Tx BabbageEra) v "transaction" - huddleRoundTripCborSpec @(Tx BabbageEra) v "transaction" + huddleRoundTripAnnCborSpec @(Tx TopTx BabbageEra) v "transaction" + huddleRoundTripCborSpec @(Tx TopTx BabbageEra) v "transaction" describe "DecCBOR instances equivalence via CDDL" $ do - huddleDecoderEquivalenceSpec @(TxBody BabbageEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx BabbageEra) v "transaction_body" huddleDecoderEquivalenceSpec @(TxAuxData BabbageEra) v "auxiliary_data" huddleDecoderEquivalenceSpec @(Timelock BabbageEra) v "native_script" huddleDecoderEquivalenceSpec @(Data BabbageEra) v "plutus_data" huddleDecoderEquivalenceSpec @(Script BabbageEra) v "script" huddleDecoderEquivalenceSpec @(TxWits BabbageEra) v "transaction_witness_set" huddleDecoderEquivalenceSpec @(Redeemers BabbageEra) v "redeemers" - huddleDecoderEquivalenceSpec @(Tx BabbageEra) v "transaction" + huddleDecoderEquivalenceSpec @(Tx TopTx BabbageEra) v "transaction" diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs index 1eeb9db0596..fb27a98fa05 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs @@ -127,7 +127,7 @@ instance <*> arbitrary <*> arbitrary -instance Arbitrary (TxBody BabbageEra) where +instance Arbitrary (TxBody TopTx BabbageEra) where arbitrary = BabbageTxBody <$> arbitrary @@ -149,4 +149,4 @@ instance Arbitrary (TxBody BabbageEra) where deriving newtype instance Arbitrary (TransitionConfig BabbageEra) -deriving newtype instance Arbitrary (Tx BabbageEra) +deriving newtype instance Arbitrary (Tx TopTx BabbageEra) diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Annotator.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Annotator.hs index 5b32ceb6fee..d885da37111 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Annotator.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Annotator.hs @@ -17,6 +17,6 @@ import Cardano.Ledger.Babbage.TxBody import Cardano.Ledger.Binary import Test.Cardano.Ledger.Alonzo.Binary.Annotator -deriving newtype instance DecCBOR (TxBody BabbageEra) +deriving newtype instance DecCBOR (TxBody TopTx BabbageEra) -deriving newtype instance DecCBOR (Tx BabbageEra) +deriving newtype instance DecCBOR (Tx TopTx BabbageEra) diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Twiddle.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Twiddle.hs index 557ad89b634..cdc19581015 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Twiddle.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Binary/Twiddle.hs @@ -26,7 +26,7 @@ instance Twiddle a => Twiddle (Sized a) instance (EraScript era, Val (Value era)) => Twiddle (BabbageTxOut era) where twiddle v = twiddle v . toTerm v -instance Twiddle (TxBody BabbageEra) where +instance Twiddle (TxBody TopTx BabbageEra) where twiddle v txBody = do inputs' <- twiddle v $ btbInputs txBody outputs' <- twiddle v $ btbOutputs txBody diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs index f915b156dea..2005bf3fcd4 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs @@ -82,14 +82,14 @@ exampleBabbageNewEpochState = emptyPParams (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) -exampleTxBabbage :: Tx BabbageEra +exampleTxBabbage :: Tx TopTx BabbageEra exampleTxBabbage = exampleTx exampleTxBodyBabbage (AlonzoSpending $ AsIx 0) (RequireAllOf @BabbageEra mempty) -exampleTxBodyBabbage :: TxBody BabbageEra +exampleTxBodyBabbage :: TxBody TopTx BabbageEra exampleTxBodyBabbage = BabbageTxBody (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash 1)) 0]) -- spending inputs diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs index b573cd318df..d079d3b5b4c 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs @@ -69,8 +69,8 @@ babbageFixupTx :: , AlonzoEraImp era , BabbageEraTxBody era ) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) babbageFixupTx = addNativeScriptTxWits >=> fixupAuxDataHash @@ -91,8 +91,8 @@ fixupCollateralReturn :: ( ShelleyEraImp era , BabbageEraTxBody era ) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) fixupCollateralReturn tx = do pp <- getsNES $ nesEsL . curPParamsEpochStateL pure $ tx & bodyTxL . collateralReturnTxBodyL %~ fmap (ensureMinCoinTxOut pp) @@ -102,7 +102,7 @@ impBabbageExpectTxSuccess :: , AlonzoEraImp era , BabbageEraTxBody era ) => - Tx era -> ImpTestM era () + Tx TopTx era -> ImpTestM era () impBabbageExpectTxSuccess tx = do impAlonzoExpectTxSuccess tx -- Check that the balance of the collateral was returned @@ -140,7 +140,7 @@ produceRefScripts scripts = do produceRefScriptsTx :: (ShelleyEraImp era, BabbageEraTxOut era) => NonEmpty (Script era) -> - ImpTestM era (Tx era) + ImpTestM era (Tx TopTx era) produceRefScriptsTx scripts = do pp <- getsNES $ nesEsL . curPParamsEpochStateL txOuts <- forM scripts $ \script -> do @@ -155,7 +155,7 @@ mkTxWithRefInputs :: (ShelleyEraImp era, BabbageEraTxBody era) => TxIn -> NonEmpty TxIn -> - Tx era + Tx TopTx era mkTxWithRefInputs txIn refIns = mkBasicTx $ mkBasicTxBody @@ -166,7 +166,7 @@ submitTxWithRefInputs :: (ShelleyEraImp era, BabbageEraTxBody era) => TxIn -> NonEmpty TxIn -> - ImpTestM era (Tx era) + ImpTestM era (Tx TopTx era) submitTxWithRefInputs txIn refIns = submitTx $ mkTxWithRefInputs txIn refIns class diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs index 685c7bc4a24..46fdfa346f5 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs @@ -49,7 +49,7 @@ import Test.QuickCheck ( instance TranslatableGen BabbageEra where tgRedeemers = genRedeemers - tgTx l = MkBabbageTx <$> genTx @BabbageEra (genTxBody l) + tgTx l = MkBabbageTx <$> genTx @BabbageEra (asSTxTopLevel <$> genTxBody l) tgUtxo = utxoWithTx @BabbageEra utxoWithTx :: @@ -60,7 +60,7 @@ utxoWithTx :: , TxOut era ~ BabbageTxOut era ) => SupportedLanguage era -> - Tx era -> + Tx TopTx era -> Gen (UTxO era) utxoWithTx l tx = do let allIns = tx ^. bodyTxL ^. allInputsTxBodyF @@ -73,8 +73,8 @@ genTx :: , Arbitrary (TxAuxData era) , AlonzoTxWits era ~ TxWits era ) => - Gen (TxBody era) -> - Gen (AlonzoTx era) + Gen (TxBody TopTx era) -> + Gen (AlonzoTx TopTx era) genTx txbGen = AlonzoTx <$> txbGen @@ -101,7 +101,7 @@ genTxOut (SupportedLanguage slang) = do _ -> arbitrary pure $ BabbageTxOut addr value datum script -genTxBody :: SupportedLanguage BabbageEra -> Gen (TxBody BabbageEra) +genTxBody :: SupportedLanguage BabbageEra -> Gen (TxBody TopTx BabbageEra) genTxBody l@(SupportedLanguage slang) = do let genTxOuts = fromList <$> listOf1 (mkSized (eraProtVerLow @BabbageEra) <$> genTxOut @BabbageEra l) let genTxIns = Set.fromList <$> listOf1 (arbitrary :: Gen TxIn) diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs index c82ba9864b3..f77836f6970 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -23,6 +24,7 @@ import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..)) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Compactible import Cardano.Ledger.Shelley.Rules +import qualified Data.TreeDiff.OMap as OMap import Test.Cardano.Ledger.Alonzo.TreeDiff -- Core @@ -48,9 +50,29 @@ instance ToExpr (BabbageTxOut era) -- TxBody -instance ToExpr BabbageTxBodyRaw +instance ToExpr (BabbageTxBodyRaw TopTx BabbageEra) where + toExpr BabbageTxBodyRaw {..} = + Rec "BabbageTxBodyRaw" $ + OMap.fromList + [ ("btbrInputs", toExpr btbrInputs) + , ("btbrCollateralInputs", toExpr btbrCollateralInputs) + , ("btbrReferenceInputs", toExpr btbrReferenceInputs) + , ("btbrOutputs", toExpr btbrOutputs) + , ("btbrCollateralReturn", toExpr btbrCollateralReturn) + , ("btbrTotalCollateral", toExpr btbrTotalCollateral) + , ("btbrCerts", toExpr btbrCerts) + , ("btbrWithdrawals", toExpr btbrWithdrawals) + , ("btbrFee", toExpr btbrFee) + , ("btbrValidityInterval", toExpr btbrValidityInterval) + , ("btbrUpdate", toExpr btbrUpdate) + , ("btbrReqSignerHashes", toExpr btbrReqSignerHashes) + , ("btbrMint", toExpr btbrMint) + , ("btbrScriptIntegrityHash", toExpr btbrScriptIntegrityHash) + , ("btbrAuxDataHash", toExpr btbrAuxDataHash) + , ("btbrNetworkId", toExpr btbrNetworkId) + ] -instance ToExpr (TxBody BabbageEra) +instance ToExpr (TxBody TopTx BabbageEra) -- Rules/Utxo instance @@ -69,4 +91,4 @@ instance ) => ToExpr (BabbageUtxowPredFailure era) -instance ToExpr (Tx BabbageEra) +instance ToExpr (Tx TopTx BabbageEra) diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs index 021124d30be..87a77cc1134 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs @@ -133,7 +133,7 @@ txb :: TxIn -> Maybe TxIn -> TxOut era -> - TxBody era + TxBody TopTx era txb i mRefInp o = mkBasicTxBody & inputsTxBodyL .~ Set.singleton i @@ -146,10 +146,10 @@ txBare :: (EraTx era, BabbageEraTxBody era) => TxIn -> TxOut era -> - Tx era + Tx TopTx era txBare i o = mkBasicTx (txb i Nothing o) -txRefInput :: forall era. (EraTx era, BabbageEraTxBody era) => TxIn -> Tx era +txRefInput :: forall era. (EraTx era, BabbageEraTxBody era) => TxIn -> Tx TopTx era txRefInput refInput = mkBasicTx (txb shelleyInput (Just refInput) shelleyOutput) hasReferenceInput :: SLanguage l -> PlutusTxInfo l -> Expectation @@ -197,7 +197,7 @@ successfulTranslation :: , Value era ~ MaryValue ) => SLanguage l -> - Tx era -> + Tx TopTx era -> (SLanguage l -> PlutusTxInfo l -> Expectation) -> Expectation successfulTranslation slang tx f = @@ -221,7 +221,7 @@ expectTranslationError :: , Value era ~ MaryValue ) => SLanguage l -> - Tx era -> + Tx TopTx era -> ContextError era -> Expectation expectTranslationError slang tx expected = @@ -243,7 +243,7 @@ expectV1TranslationError :: , EraPlutusTxInfo 'PlutusV2 era , Value era ~ MaryValue ) => - Tx era -> + Tx TopTx era -> ContextError era -> Expectation expectV1TranslationError = expectTranslationError SPlutusV1 diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index b6900c1253e..dc6c272d717 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.21.0.0 +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Add `shelleyToConwayLedgerPredFailure`. * Move withdrawal-validation and DRep expiry updates from `CERTS` to `LEDGER` starting protocol version 11. - Add `ConwayWithdrawalsMissingAccounts` and `ConwayIncompleteWithdrawals` to `ConwayLedgerPredFailure`. diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index dac4846b0c6..5414e2f1f25 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -101,7 +101,7 @@ library cardano-ledger-babbage ^>=1.12, cardano-ledger-binary ^>=1.8, cardano-ledger-core:{cardano-ledger-core, internal} ^>=1.19, - cardano-ledger-mary ^>=1.9, + cardano-ledger-mary ^>=1.10, cardano-ledger-shelley ^>=1.18, cardano-slotting, cardano-strict-containers, @@ -205,6 +205,7 @@ library testlib small-steps >=1.1, text, time, + tree-diff, executable huddle-cddl main-is: Main.hs diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs index f13f31b0eb1..86719311693 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs @@ -46,6 +46,9 @@ import Cardano.Ledger.Shelley.Rules ( -- ===================================================== +instance EraTxLevel ConwayEra where + type STxLevel l ConwayEra = STxTopLevel l ConwayEra + type instance Value ConwayEra = MaryValue ------------------------------------------------------------------------------- diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs index 7ad82ccd9a5..9e76ad5b5b0 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -243,7 +243,7 @@ instance ( Embed (EraRule "LEDGERS" era) (EraRule "BBODY" era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , AlonzoEraTxWits era , BlockBody era ~ AlonzoBlockBody era , EraBlockBody era @@ -322,7 +322,7 @@ instance wrapEvent = ShelleyInAlonzoEvent . LedgersEvent totalRefScriptSizeInBlock :: - (AlonzoEraTx era, BabbageEraTxBody era) => ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int + (AlonzoEraTx era, BabbageEraTxBody era) => ProtVer -> StrictSeq (Tx TopTx era) -> UTxO era -> Int totalRefScriptSizeInBlock protVer txs (UTxO utxo) | pvMajor protVer <= natVersion @10 = getSum $ foldMap' (Monoid.Sum . txNonDistinctRefScriptsSize (UTxO utxo)) txs diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs index cfcb3ef0b7c..a550764ff4e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs @@ -85,7 +85,7 @@ import Lens.Micro import NoThunks.Class (NoThunks (..)) data CertsEnv era = CertsEnv - { certsTx :: Tx era + { certsTx :: Tx TopTx era , certsPParams :: PParams era , certsCurrentEpoch :: EpochNo -- ^ Lazy on purpose, because not all certificates need to know the current EpochNo @@ -105,11 +105,11 @@ instance EraTx era => EncCBOR (CertsEnv era) where !> To certsCurrentCommittee !> To certsCommitteeProposals -deriving instance (EraPParams era, Eq (Tx era)) => Eq (CertsEnv era) +deriving instance (EraPParams era, Eq (Tx TopTx era)) => Eq (CertsEnv era) -deriving instance (EraPParams era, Show (Tx era)) => Show (CertsEnv era) +deriving instance (EraPParams era, Show (Tx TopTx era)) => Show (CertsEnv era) -instance (EraPParams era, NFData (Tx era)) => NFData (CertsEnv era) +instance (EraPParams era, NFData (Tx TopTx era)) => NFData (CertsEnv era) data ConwayCertsPredFailure era = -- | Withdrawals that are missing or do not withdraw the entire amount (pv < 11) @@ -261,7 +261,7 @@ updateDormantDRepExpiries :: , ConwayEraTxBody era , ConwayEraCertState era ) => - Tx era -> EpochNo -> CertState era -> CertState era + Tx TopTx era -> EpochNo -> CertState era -> CertState era updateDormantDRepExpiries tx currentEpoch = let hasProposals = not . OSet.null $ tx ^. bodyTxL . proposalProceduresTxBodyL in if hasProposals @@ -276,7 +276,7 @@ updateVotingDRepExpiries :: , ConwayEraTxBody era , ConwayEraCertState era ) => - Tx era -> EpochNo -> EpochInterval -> CertState era -> CertState era + Tx TopTx era -> EpochNo -> EpochInterval -> CertState era -> CertState era updateVotingDRepExpiries tx currentEpoch drepActivity certState = let numDormantEpochs = certState ^. certVStateL . vsNumDormantEpochsL updateVSDReps vsDReps = diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index dd6313ad9bc..d85e85b294f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -322,7 +322,7 @@ instance , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , Environment (EraRule "CERTS" era) ~ CertsEnv era , Environment (EraRule "GOV" era) ~ GovEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "GOV" era) ~ GovSignal era , ConwayEraCertState era @@ -334,7 +334,7 @@ instance STS (ConwayLEDGER era) where type State (ConwayLEDGER era) = LedgerState era - type Signal (ConwayLEDGER era) = Tx era + type Signal (ConwayLEDGER era) = Tx TopTx era type Environment (ConwayLEDGER era) = LedgerEnv era type BaseM (ConwayLEDGER era) = ShelleyBase type PredicateFailure (ConwayLEDGER era) = ConwayLedgerPredFailure era @@ -355,27 +355,27 @@ ledgerTransition :: , ConwayEraTxBody era , ConwayEraGov era , GovState era ~ ConwayGovState era + , Signal (someLEDGER era) ~ Tx TopTx era + , State (someLEDGER era) ~ LedgerState era + , Environment (someLEDGER era) ~ LedgerEnv era + , PredicateFailure (someLEDGER era) ~ ConwayLedgerPredFailure era , Embed (EraRule "UTXOW" era) (someLEDGER era) , Embed (EraRule "GOV" era) (someLEDGER era) , Embed (EraRule "CERTS" era) (someLEDGER era) , State (EraRule "UTXOW" era) ~ UTxOState era , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "GOV" era) ~ Proposals era - , State (someLEDGER era) ~ LedgerState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , Environment (EraRule "GOV" era) ~ GovEnv era , Environment (EraRule "CERTS" era) ~ CertsEnv era - , Environment (someLEDGER era) ~ LedgerEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "GOV" era) ~ GovSignal era - , Signal (someLEDGER era) ~ Tx era , BaseM (someLEDGER era) ~ ShelleyBase , STS (someLEDGER era) , ConwayEraCertState era , EraRule "LEDGER" era ~ someLEDGER era , InjectRuleFailure "LEDGER" ShelleyLedgerPredFailure era - , PredicateFailure (someLEDGER era) ~ ConwayLedgerPredFailure era ) => TransitionRule (someLEDGER era) ledgerTransition = do @@ -511,7 +511,7 @@ instance , Script era ~ AlonzoScript era , TxOut era ~ BabbageTxOut era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , PredicateFailure (EraRule "UTXOW" era) ~ ConwayUtxowPredFailure era , Event (EraRule "UTXOW" era) ~ AlonzoUtxowEvent era , STS (ConwayUTXOW era) @@ -559,7 +559,7 @@ instance , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , Environment (EraRule "CERTS" era) ~ CertsEnv era , Environment (EraRule "GOV" era) ~ GovEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "GOV" era) ~ GovSignal era , State (EraRule "UTXOW" era) ~ UTxOState era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs index 8f470288917..995072b1732 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs @@ -75,12 +75,12 @@ instance , Show (PredicateFailure (EraRule "GOV" era)) , Show (PredicateFailure (EraRule "UTXOW" era)) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Tx era ~ Signal (EraRule "LEDGER" era) + , Tx TopTx era ~ Signal (EraRule "LEDGER" era) ) => STS (ConwayMEMPOOL era) where type State (ConwayMEMPOOL era) = LedgerState era - type Signal (ConwayMEMPOOL era) = Tx era + type Signal (ConwayMEMPOOL era) = Tx TopTx era type Environment (ConwayMEMPOOL era) = LedgerEnv era type BaseM (ConwayMEMPOOL era) = ShelleyBase type PredicateFailure (ConwayMEMPOOL era) = ConwayLedgerPredFailure era @@ -97,7 +97,7 @@ mempoolTransition :: , Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era) , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Tx era ~ Signal (EraRule "LEDGER" era) + , Tx TopTx era ~ Signal (EraRule "LEDGER" era) ) => TransitionRule (ConwayMEMPOOL era) mempoolTransition = do @@ -157,8 +157,8 @@ instance , GovState era ~ ConwayGovState era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "GOV" era) ~ GovSignal era - , Signal (EraRule "UTXOW" era) ~ Tx era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , ConwayEraCertState era , EraRule "LEDGER" era ~ ConwayLEDGER era , EraRuleFailure "LEDGER" era ~ ConwayLedgerPredFailure era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs index a495df0aedc..cfda453090a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs @@ -234,7 +234,7 @@ instance , Embed (EraRule "UTXOS" era) (ConwayUTXO era) , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , PredicateFailure (EraRule "UTXO" era) ~ ConwayUtxoPredFailure era , EraCertState era , SafeToHash (TxWits era) @@ -242,7 +242,7 @@ instance STS (ConwayUTXO era) where type State (ConwayUTXO era) = Shelley.UTxOState era - type Signal (ConwayUTXO era) = Tx era + type Signal (ConwayUTXO era) = Tx TopTx era type Environment (ConwayUTXO era) = Shelley.UtxoEnv era type BaseM (ConwayUTXO era) = ShelleyBase type PredicateFailure (ConwayUTXO era) = ConwayUtxoPredFailure era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs index 4a4a292ed02..d4fbe786501 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs @@ -205,7 +205,7 @@ instance , EraPlutusContext era , GovState era ~ ConwayGovState era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , Signal (ConwayUTXOS era) ~ Tx era + , Signal (ConwayUTXOS era) ~ Tx TopTx era , EraRule "UTXOS" era ~ ConwayUTXOS era , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era @@ -216,7 +216,7 @@ instance type BaseM (ConwayUTXOS era) = Cardano.Ledger.BaseTypes.ShelleyBase type Environment (ConwayUTXOS era) = UtxoEnv era type State (ConwayUTXOS era) = UTxOState era - type Signal (ConwayUTXOS era) = Tx era + type Signal (ConwayUTXOS era) = Tx TopTx era type PredicateFailure (ConwayUTXOS era) = ConwayUtxosPredFailure era type Event (ConwayUTXOS era) = ConwayUtxosEvent era @@ -234,7 +234,7 @@ instance , GovState era ~ ConwayGovState era , PredicateFailure (EraRule "UTXOS" era) ~ ConwayUtxosPredFailure era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , Signal (ConwayUTXOS era) ~ Tx era + , Signal (ConwayUTXOS era) ~ Tx TopTx era , EraRule "UTXOS" era ~ ConwayUTXOS era , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era @@ -254,7 +254,7 @@ utxosTransition :: , EraStake era , EraCertState era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , STS (EraRule "UTXOS" era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , State (EraRule "UTXOS" era) ~ UTxOState era @@ -279,7 +279,7 @@ conwayEvalScriptsTxValid :: , EraStake era , EraCertState era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , Signal (EraRule "UTXOS" era) ~ Tx era + , Signal (EraRule "UTXOS" era) ~ Tx TopTx era , STS (EraRule "UTXOS" era) , State (EraRule "UTXOS" era) ~ UTxOState era , Environment (EraRule "UTXOS" era) ~ UtxoEnv era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs index 2a1413ca616..f60ff27393a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs @@ -211,14 +211,14 @@ instance Embed (EraRule "UTXO" era) (ConwayUTXOW era) , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era , State (EraRule "UTXO" era) ~ Shelley.UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , Eq (PredicateFailure (EraRule "UTXOS" era)) , Show (PredicateFailure (EraRule "UTXOS" era)) ) => STS (ConwayUTXOW era) where type State (ConwayUTXOW era) = Shelley.UTxOState era - type Signal (ConwayUTXOW era) = Tx era + type Signal (ConwayUTXOW era) = Tx TopTx era type Environment (ConwayUTXOW era) = Shelley.UtxoEnv era type BaseM (ConwayUTXOW era) = ShelleyBase type PredicateFailure (ConwayUTXOW era) = ConwayUtxowPredFailure era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/State/CertState.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/State/CertState.hs index da90602abb0..078bdb789b8 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/State/CertState.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/State/CertState.hs @@ -117,12 +117,12 @@ conwayObligationCertState certState = } conwayCertsTotalDepositsTxBody :: - EraTxBody era => PParams era -> ConwayCertState era -> TxBody era -> Coin + EraTxBody era => PParams era -> ConwayCertState era -> TxBody l era -> Coin conwayCertsTotalDepositsTxBody pp ConwayCertState {conwayCertPState} = getTotalDepositsTxBody pp (`Map.member` psStakePools conwayCertPState) conwayCertsTotalRefundsTxBody :: - (EraTxBody era, EraAccounts era) => PParams era -> ConwayCertState era -> TxBody era -> Coin + (EraTxBody era, EraAccounts era) => PParams era -> ConwayCertState era -> TxBody l era -> Coin conwayCertsTotalRefundsTxBody pp ConwayCertState {conwayCertDState, conwayCertVState} = getTotalRefundsTxBody pp diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index 4532df03e64..80a3631ec90 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -84,8 +85,8 @@ instance TranslateEra ConwayEra NewEpochState where , stashedAVVMAddresses = () } -instance TranslateEra ConwayEra Tx where - type TranslationError ConwayEra Tx = DecoderError +instance TranslateEra ConwayEra (Tx TopTx) where + type TranslationError ConwayEra (Tx TopTx) = DecoderError translateEra _ctxt tx = do -- Note that this does not preserve the hidden bytes field of the transaction. -- This is under the premise that this is irrelevant for TxInBlocks, which are diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs index d7491e88d7a..48b32bcd3f2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -45,14 +46,18 @@ import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes (EqRaw (..)) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) import Data.Word (Word32) import GHC.Generics (Generic) import GHC.Stack import Lens.Micro (Lens', lens, (^.)) import NoThunks.Class (NoThunks) +instance HasEraTxLevel Tx ConwayEra where + toSTxLevel (MkConwayTx AlonzoTx {}) = STopTxOnly @ConwayEra + instance EraTx ConwayEra where - newtype Tx ConwayEra = MkConwayTx {unConwayTx :: AlonzoTx ConwayEra} + newtype Tx l ConwayEra = MkConwayTx {unConwayTx :: AlonzoTx l ConwayEra} deriving newtype (Eq, Show, NFData, NoThunks, ToCBOR, EncCBOR) deriving (Generic) @@ -75,10 +80,10 @@ instance EraTx ConwayEra where getMinFeeTx = getConwayMinFeeTx -instance EqRaw (Tx ConwayEra) where +instance EqRaw (Tx l ConwayEra) where eqRaw = alonzoTxEqRaw -conwayTxL :: Lens' (Tx ConwayEra) (AlonzoTx ConwayEra) +conwayTxL :: Lens' (Tx l ConwayEra) (AlonzoTx l ConwayEra) conwayTxL = lens unConwayTx (\x y -> x {unConwayTx = y}) getConwayMinFeeTx :: @@ -87,7 +92,7 @@ getConwayMinFeeTx :: , ConwayEraPParams era ) => PParams era -> - Tx era -> + Tx l era -> Int -> Coin getConwayMinFeeTx pp tx refScriptsSize = @@ -129,5 +134,5 @@ instance AlonzoEraTx ConwayEra where isValidTxL = conwayTxL . isValidAlonzoTxL {-# INLINE isValidTxL #-} -instance DecCBOR (Annotator (Tx ConwayEra)) where +instance Typeable l => DecCBOR (Annotator (Tx l ConwayEra)) where decCBOR = fmap MkConwayTx <$> decCBOR diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs index 1789dd66059..f7f089b35ef 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs @@ -3,10 +3,12 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -88,11 +90,9 @@ import Cardano.Ledger.Conway.Era (ConwayEra) import Cardano.Ledger.Conway.Governance.Procedures (ProposalProcedure, VotingProcedures (..)) import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppGovActionDepositL) import Cardano.Ledger.Conway.Scripts (ConwayEraScript, ConwayPlutusPurpose (..)) -import Cardano.Ledger.Conway.TxCert ( - ConwayEraTxCert, - ) +import Cardano.Ledger.Conway.TxCert (ConwayEraTxCert) import Cardano.Ledger.Conway.TxOut (upgradeBabbageTxOut) -import Cardano.Ledger.Mary.Value (MultiAsset (..), policies) +import Cardano.Ledger.Mary.Value (MultiAsset (..)) import Cardano.Ledger.MemoBytes ( EqRaw, Mem, @@ -106,59 +106,87 @@ import Cardano.Ledger.MemoBytes ( ) import Cardano.Ledger.TxIn (TxIn (..)) import Cardano.Ledger.Val (Val (..)) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), deepseq) import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.OSet.Strict as OSet import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro (Lens', to, (^.)) -import NoThunks.Class (NoThunks) - -instance Memoized (TxBody ConwayEra) where - type RawType (TxBody ConwayEra) = ConwayTxBodyRaw - -data ConwayTxBodyRaw = ConwayTxBodyRaw - { ctbrSpendInputs :: !(Set TxIn) - , ctbrCollateralInputs :: !(Set TxIn) - , ctbrReferenceInputs :: !(Set TxIn) - , ctbrOutputs :: !(StrictSeq (Sized (TxOut ConwayEra))) - , ctbrCollateralReturn :: !(StrictMaybe (Sized (TxOut ConwayEra))) - , ctbrTotalCollateral :: !(StrictMaybe Coin) - , ctbrCerts :: !(OSet.OSet (TxCert ConwayEra)) - , ctbrWithdrawals :: !Withdrawals - , ctbrFee :: !Coin - , ctbrVldt :: !ValidityInterval - , ctbrReqSignerHashes :: !(Set (KeyHash 'Guard)) - , ctbrMint :: !MultiAsset - , ctbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) - , ctbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - , ctbrNetworkId :: !(StrictMaybe Network) - , ctbrVotingProcedures :: !(VotingProcedures ConwayEra) - , ctbrProposalProcedures :: !(OSet.OSet (ProposalProcedure ConwayEra)) - , ctbrCurrentTreasuryValue :: !(StrictMaybe Coin) - , ctbrTreasuryDonation :: !Coin - } - deriving (Generic) - -deriving instance Eq ConwayTxBodyRaw - -instance NoThunks ConwayTxBodyRaw - -instance NFData ConwayTxBodyRaw - -deriving instance Show ConwayTxBodyRaw - -instance DecCBOR ConwayTxBodyRaw where +import NoThunks.Class (InspectHeap (..), NoThunks) + +instance Memoized (TxBody l ConwayEra) where + type RawType (TxBody l ConwayEra) = ConwayTxBodyRaw l ConwayEra + +data ConwayTxBodyRaw l era where + ConwayTxBodyRaw :: + { ctbrSpendInputs :: !(Set TxIn) + , ctbrCollateralInputs :: !(Set TxIn) + , ctbrReferenceInputs :: !(Set TxIn) + , ctbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , ctbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , ctbrTotalCollateral :: !(StrictMaybe Coin) + , ctbrCerts :: !(OSet.OSet (TxCert era)) + , ctbrWithdrawals :: !Withdrawals + , ctbrFee :: !Coin + , ctbrVldt :: !ValidityInterval + , ctbrReqSignerHashes :: !(Set (KeyHash 'Guard)) + , ctbrMint :: !MultiAsset + , ctbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , ctbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , ctbrNetworkId :: !(StrictMaybe Network) + , ctbrVotingProcedures :: !(VotingProcedures era) + , ctbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , ctbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , ctbrTreasuryDonation :: !Coin + } -> + ConwayTxBodyRaw TopTx era + +deriving instance Eq (ConwayTxBodyRaw l ConwayEra) + +deriving via + InspectHeap (ConwayTxBodyRaw l ConwayEra) + instance + Typeable l => NoThunks (ConwayTxBodyRaw l ConwayEra) + +instance NFData (ConwayTxBodyRaw l ConwayEra) where + rnf ConwayTxBodyRaw {..} = + ctbrSpendInputs `deepseq` + ctbrCollateralInputs `deepseq` + ctbrReferenceInputs `deepseq` + ctbrOutputs `deepseq` + ctbrCollateralReturn `deepseq` + ctbrTotalCollateral `deepseq` + ctbrCerts `deepseq` + ctbrWithdrawals `deepseq` + ctbrFee `deepseq` + ctbrVldt `deepseq` + ctbrReqSignerHashes `deepseq` + ctbrMint `deepseq` + ctbrScriptIntegrityHash `deepseq` + ctbrAuxDataHash `deepseq` + ctbrNetworkId `deepseq` + ctbrVotingProcedures `deepseq` + ctbrProposalProcedures `deepseq` + ctbrCurrentTreasuryValue `deepseq` + rnf ctbrTreasuryDonation + +deriving instance Show (ConwayTxBodyRaw l ConwayEra) + +instance HasEraTxLevel ConwayTxBodyRaw ConwayEra where + toSTxLevel ConwayTxBodyRaw {} = STopTxOnly + +instance Typeable l => DecCBOR (ConwayTxBodyRaw l ConwayEra) where decCBOR = - decode $ + fmap asSTxTopLevel . decode $ SparseKeyed "TxBodyRaw" - basicConwayTxBodyRaw + (asSTxTopLevel basicConwayTxBodyRaw) bodyFields requiredFields where - bodyFields :: Word -> Field ConwayTxBodyRaw + bodyFields :: Word -> Field (ConwayTxBodyRaw TopTx ConwayEra) bodyFields 0 = field (\x tx -> tx {ctbrSpendInputs = x}) From bodyFields 1 = field (\x tx -> tx {ctbrOutputs = x}) From bodyFields 2 = field (\x tx -> tx {ctbrFee = x}) From @@ -238,28 +266,31 @@ instance DecCBOR ConwayTxBodyRaw where emptyFailure fieldName requirement = "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" -instance DecCBOR (Annotator ConwayTxBodyRaw) where +instance Typeable l => DecCBOR (Annotator (ConwayTxBodyRaw l ConwayEra)) where decCBOR = pure <$> decCBOR -deriving via Mem ConwayTxBodyRaw instance DecCBOR (Annotator (TxBody ConwayEra)) +deriving via + Mem (ConwayTxBodyRaw l ConwayEra) + instance + Typeable l => DecCBOR (Annotator (TxBody l ConwayEra)) -deriving instance NoThunks (TxBody ConwayEra) +deriving instance Typeable l => NoThunks (TxBody l ConwayEra) -deriving instance Eq (TxBody ConwayEra) +deriving instance Eq (TxBody l ConwayEra) -deriving newtype instance NFData (TxBody ConwayEra) +deriving newtype instance NFData (TxBody l ConwayEra) -deriving instance Show (TxBody ConwayEra) +deriving instance Show (TxBody l ConwayEra) -type instance MemoHashIndex ConwayTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (ConwayTxBodyRaw l ConwayEra) = EraIndependentTxBody -instance HashAnnotated (TxBody ConwayEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l ConwayEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -mkConwayTxBody :: TxBody ConwayEra -mkConwayTxBody = mkMemoizedEra @ConwayEra basicConwayTxBodyRaw +mkConwayTxBody :: Typeable l => TxBody l ConwayEra +mkConwayTxBody = mkMemoizedEra @ConwayEra $ asSTxTopLevel basicConwayTxBodyRaw -basicConwayTxBodyRaw :: ConwayTxBodyRaw +basicConwayTxBodyRaw :: ConwayTxBodyRaw TopTx ConwayEra basicConwayTxBodyRaw = ConwayTxBodyRaw mempty @@ -282,40 +313,43 @@ basicConwayTxBodyRaw = SNothing mempty +instance HasEraTxLevel TxBody ConwayEra where + toSTxLevel = toSTxLevel . getMemoRawType + instance EraTxBody ConwayEra where - newtype TxBody ConwayEra = MkConwayTxBody (MemoBytes ConwayTxBodyRaw) + newtype TxBody l ConwayEra = MkConwayTxBody (MemoBytes (ConwayTxBodyRaw l ConwayEra)) deriving (Generic, SafeToHash, ToCBOR) mkBasicTxBody = mkConwayTxBody - inputsTxBodyL = lensMemoRawType @ConwayEra ctbrSpendInputs $ + inputsTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrSpendInputs} -> ctbrSpendInputs) $ \txb x -> txb {ctbrSpendInputs = x} {-# INLINE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @ConwayEra (fmap sizedValue . ctbrOutputs) $ + lensMemoRawType @ConwayEra (fmap sizedValue . (\ConwayTxBodyRaw {ctbrOutputs} -> ctbrOutputs)) $ \txb x -> txb {ctbrOutputs = mkSized (eraProtVerLow @ConwayEra) <$> x} {-# INLINE outputsTxBodyL #-} feeTxBodyL = lensMemoRawType @ConwayEra ctbrFee (\txb x -> txb {ctbrFee = x}) {-# INLINE feeTxBodyL #-} - auxDataHashTxBodyL = lensMemoRawType @ConwayEra ctbrAuxDataHash $ + auxDataHashTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrAuxDataHash} -> ctbrAuxDataHash) $ \txb x -> txb {ctbrAuxDataHash = x} {-# INLINE auxDataHashTxBodyL #-} - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + spendableInputsTxBodyF = to (`withTopTxLevelOnly` (^. babbageSpendableInputsTxBodyF)) {-# INLINE spendableInputsTxBodyF #-} allInputsTxBodyF = babbageAllInputsTxBodyF {-# INLINE allInputsTxBodyF #-} - withdrawalsTxBodyL = lensMemoRawType @ConwayEra ctbrWithdrawals $ + withdrawalsTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrWithdrawals} -> ctbrWithdrawals) $ \txb x -> txb {ctbrWithdrawals = x} {-# INLINE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @ConwayEra (OSet.toStrictSeq . ctbrCerts) $ + lensMemoRawType @ConwayEra (OSet.toStrictSeq . (\ConwayTxBodyRaw {ctbrCerts} -> ctbrCerts)) $ \txb x -> txb {ctbrCerts = OSet.fromStrictSeq x} {-# INLINE certsTxBodyL #-} @@ -339,7 +373,7 @@ instance EraTxBody ConwayEra where conwayTotalDepositsTxBody :: PParams ConwayEra -> (KeyHash 'StakePool -> Bool) -> - TxBody ConwayEra -> + TxBody l ConwayEra -> Coin conwayTotalDepositsTxBody pp isPoolRegisted txBody = getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) @@ -349,7 +383,7 @@ conwayTotalDepositsTxBody pp isPoolRegisted txBody = conwayProposalsDeposits :: ConwayEraTxBody era => PParams era -> - TxBody era -> + TxBody l era -> Coin conwayProposalsDeposits pp txBody = numProposals <×> depositPerProposal where @@ -357,35 +391,32 @@ conwayProposalsDeposits pp txBody = numProposals <×> depositPerProposal depositPerProposal = pp ^. ppGovActionDepositL instance AllegraEraTxBody ConwayEra where - vldtTxBodyL = lensMemoRawType @ConwayEra ctbrVldt $ + vldtTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrVldt} -> ctbrVldt) $ \txb x -> txb {ctbrVldt = x} {-# INLINE vldtTxBodyL #-} instance MaryEraTxBody ConwayEra where - mintTxBodyL = lensMemoRawType @ConwayEra ctbrMint $ + mintTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrMint} -> ctbrMint) $ \txb x -> txb {ctbrMint = x} {-# INLINE mintTxBodyL #-} - mintedTxBodyF = to $ \txBody -> policies (ctbrMint (getMemoRawType txBody)) - {-# INLINE mintedTxBodyF #-} - instance AlonzoEraTxBody ConwayEra where collateralInputsTxBodyL = - lensMemoRawType @ConwayEra ctbrCollateralInputs $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrCollateralInputs} -> ctbrCollateralInputs) $ \txb x -> txb {ctbrCollateralInputs = x} {-# INLINE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = - lensMemoRawType @ConwayEra ctbrReqSignerHashes $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrReqSignerHashes} -> ctbrReqSignerHashes) $ \txb x -> txb {ctbrReqSignerHashes = x} {-# INLINE reqSignerHashesTxBodyL #-} scriptIntegrityHashTxBodyL = - lensMemoRawType @ConwayEra ctbrScriptIntegrityHash $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrScriptIntegrityHash} -> ctbrScriptIntegrityHash) $ \txb x -> txb {ctbrScriptIntegrityHash = x} {-# INLINE scriptIntegrityHashTxBodyL #-} - networkIdTxBodyL = lensMemoRawType @ConwayEra ctbrNetworkId $ + networkIdTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrNetworkId} -> ctbrNetworkId) $ \txb x -> txb {ctbrNetworkId = x} {-# INLINE networkIdTxBodyL #-} @@ -394,52 +425,53 @@ instance AlonzoEraTxBody ConwayEra where redeemerPointerInverse = conwayRedeemerPointerInverse instance BabbageEraTxBody ConwayEra where - sizedOutputsTxBodyL = lensMemoRawType @ConwayEra ctbrOutputs $ + sizedOutputsTxBodyL = lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrOutputs} -> ctbrOutputs) $ \txb x -> txb {ctbrOutputs = x} {-# INLINE sizedOutputsTxBodyL #-} referenceInputsTxBodyL = - lensMemoRawType @ConwayEra ctbrReferenceInputs $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrReferenceInputs} -> ctbrReferenceInputs) $ \txb x -> txb {ctbrReferenceInputs = x} {-# INLINE referenceInputsTxBodyL #-} totalCollateralTxBodyL = - lensMemoRawType @ConwayEra ctbrTotalCollateral $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrTotalCollateral} -> ctbrTotalCollateral) $ \txb x -> txb {ctbrTotalCollateral = x} {-# INLINE totalCollateralTxBodyL #-} collateralReturnTxBodyL = - lensMemoRawType @ConwayEra (fmap sizedValue . ctbrCollateralReturn) $ - \txb x -> txb {ctbrCollateralReturn = mkSized (eraProtVerLow @ConwayEra) <$> x} + lensMemoRawType @ConwayEra + (fmap sizedValue . (\ConwayTxBodyRaw {ctbrCollateralReturn} -> ctbrCollateralReturn)) + $ \txb x -> txb {ctbrCollateralReturn = mkSized (eraProtVerLow @ConwayEra) <$> x} {-# INLINE collateralReturnTxBodyL #-} sizedCollateralReturnTxBodyL = - lensMemoRawType @ConwayEra ctbrCollateralReturn $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrCollateralReturn} -> ctbrCollateralReturn) $ \txb x -> txb {ctbrCollateralReturn = x} {-# INLINE sizedCollateralReturnTxBodyL #-} - allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + allSizedOutputsTxBodyF = to (`withTopTxLevelOnly` (^. allSizedOutputsBabbageTxBodyF)) {-# INLINE allSizedOutputsTxBodyF #-} instance ConwayEraTxBody ConwayEra where votingProceduresTxBodyL = - lensMemoRawType @ConwayEra ctbrVotingProcedures $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrVotingProcedures} -> ctbrVotingProcedures) $ \txb x -> txb {ctbrVotingProcedures = x} {-# INLINE votingProceduresTxBodyL #-} proposalProceduresTxBodyL = - lensMemoRawType @ConwayEra ctbrProposalProcedures $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrProposalProcedures} -> ctbrProposalProcedures) $ \txb x -> txb {ctbrProposalProcedures = x} {-# INLINE proposalProceduresTxBodyL #-} currentTreasuryValueTxBodyL = - lensMemoRawType @ConwayEra ctbrCurrentTreasuryValue $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrCurrentTreasuryValue} -> ctbrCurrentTreasuryValue) $ \txb x -> txb {ctbrCurrentTreasuryValue = x} {-# INLINE currentTreasuryValueTxBodyL #-} treasuryDonationTxBodyL = - lensMemoRawType @ConwayEra ctbrTreasuryDonation $ + lensMemoRawType @ConwayEra (\ConwayTxBodyRaw {ctbrTreasuryDonation} -> ctbrTreasuryDonation) $ \txb x -> txb {ctbrTreasuryDonation = x} {-# INLINE treasuryDonationTxBodyL #-} -instance EqRaw (TxBody ConwayEra) +instance EqRaw (TxBody l ConwayEra) pattern ConwayTxBody :: Set TxIn -> @@ -461,7 +493,7 @@ pattern ConwayTxBody :: OSet.OSet (ProposalProcedure ConwayEra) -> StrictMaybe Coin -> Coin -> - TxBody ConwayEra + TxBody TopTx ConwayEra pattern ConwayTxBody { ctbSpendInputs , ctbCollateralInputs @@ -556,8 +588,8 @@ pattern ConwayTxBody -------------------------------------------------------------------------------- encodeTxBodyRaw :: - ConwayTxBodyRaw -> - Encode ('Closed 'Sparse) ConwayTxBodyRaw + ConwayTxBodyRaw l ConwayEra -> + Encode ('Closed 'Sparse) (ConwayTxBodyRaw l ConwayEra) encodeTxBodyRaw ConwayTxBodyRaw {..} = let ValidityInterval bot top = ctbrVldt in Keyed @@ -585,11 +617,11 @@ encodeTxBodyRaw ConwayTxBodyRaw {..} = !> encodeKeyedStrictMaybe 21 ctbrCurrentTreasuryValue !> Omit (== mempty) (Key 22 $ To ctbrTreasuryDonation) -instance EncCBOR ConwayTxBodyRaw where +instance EncCBOR (ConwayTxBodyRaw l ConwayEra) where encCBOR = encode . encodeTxBodyRaw -- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody ConwayEra) +deriving newtype instance EncCBOR (TxBody l ConwayEra) class (BabbageEraTxBody era, ConwayEraTxCert era, ConwayEraPParams era, ConwayEraScript era) => @@ -597,20 +629,20 @@ class where -- | Lens for getting and setting number of `Coin` that is expected to be in the -- Treasury at the current Epoch - currentTreasuryValueTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) + currentTreasuryValueTxBodyL :: Lens' (TxBody l era) (StrictMaybe Coin) -- | Lens for getting and setting `VotingProcedures`. - votingProceduresTxBodyL :: Lens' (TxBody era) (VotingProcedures era) + votingProceduresTxBodyL :: Lens' (TxBody l era) (VotingProcedures era) -- | Lens for getting and setting `ProposalProcedures`. - proposalProceduresTxBodyL :: Lens' (TxBody era) (OSet.OSet (ProposalProcedure era)) + proposalProceduresTxBodyL :: Lens' (TxBody l era) (OSet.OSet (ProposalProcedure era)) - treasuryDonationTxBodyL :: Lens' (TxBody era) Coin + treasuryDonationTxBodyL :: Lens' (TxBody l era) Coin conwayRedeemerPointer :: - forall era. + forall era l. ConwayEraTxBody era => - TxBody era -> + TxBody l era -> ConwayPlutusPurpose AsItem era -> StrictMaybe (ConwayPlutusPurpose AsIx era) conwayRedeemerPointer txBody = \case @@ -629,7 +661,7 @@ conwayRedeemerPointer txBody = \case conwayRedeemerPointerInverse :: ConwayEraTxBody era => - TxBody era -> + TxBody l era -> ConwayPlutusPurpose AsIx era -> StrictMaybe (ConwayPlutusPurpose AsIxItem era) conwayRedeemerPointerInverse txBody = \case diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs index 6f62be4d08c..3a5ae3bfa9f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs @@ -350,12 +350,12 @@ transTxInInfoV3 utxo txIn = do Right (PV3.TxInInfo (transTxIn txIn) plutusTxOut) guardConwayFeaturesForPlutusV1V2 :: - forall era. + forall era l. ( EraTx era , ConwayEraTxBody era , Inject (ConwayContextError era) (ContextError era) ) => - Tx era -> + Tx l era -> Either (ContextError era) () guardConwayFeaturesForPlutusV1V2 tx = do let txBody = tx ^. bodyTxL @@ -532,8 +532,8 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where transTxId :: TxId -> PV3.TxId transTxId txId = PV3.TxId (transSafeHash (unTxId txId)) -transTxBodyId :: EraTxBody era => TxBody era -> PV3.TxId -transTxBodyId txBody = PV3.TxId (transSafeHash (hashAnnotated txBody)) +transTxBodyId :: EraTxBody era => TxBody l era -> PV3.TxId +transTxBodyId txBody = PV3.TxId (transSafeHash (hashAnnotated @_ @EraIndependentTxBody txBody)) transTxIn :: TxIn -> PV3.TxOutRef transTxIn (TxIn txid txIx) = PV3.TxOutRef (transTxId txid) (toInteger (txIxToInt txIx)) @@ -542,7 +542,7 @@ transMintValue :: MultiAsset -> PV3.MintValue transMintValue = PV3.UnsafeMintValue . PV1.getValue . Alonzo.transMultiAsset -- | Translate all `Withdrawal`s from within a `TxBody` -transTxBodyWithdrawals :: EraTxBody era => TxBody era -> PV3.Map PV3.Credential PV3.Lovelace +transTxBodyWithdrawals :: EraTxBody era => TxBody l era -> PV3.Map PV3.Credential PV3.Lovelace transTxBodyWithdrawals txBody = transMap transRewardAccount transCoinToLovelace (unWithdrawals $ txBody ^. withdrawalsTxBodyL) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs index 379d2293fce..f9c46db7c84 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs @@ -59,7 +59,7 @@ import Lens.Micro ((^.)) getConwayScriptsNeeded :: ConwayEraTxBody era => UTxO era -> - TxBody era -> + TxBody l era -> AlonzoScriptsNeeded era getConwayScriptsNeeded utxo txBody = getSpendingScriptsNeeded utxo txBody @@ -106,7 +106,7 @@ conwayConsumed :: PParams era -> CertState era -> UTxO era -> - TxBody era -> + TxBody l era -> Value era conwayConsumed pp certState = getConsumedValue @@ -115,10 +115,12 @@ conwayConsumed pp certState = (lookupDepositVState $ certState ^. certVStateL) conwayProducedValue :: - (ConwayEraTxBody era, Value era ~ MaryValue) => + ( ConwayEraTxBody era + , Value era ~ MaryValue + ) => PParams era -> (KeyHash 'StakePool -> Bool) -> - TxBody era -> + TxBody TopTx era -> Value era conwayProducedValue pp isStakePool txBody = getProducedMaryValue pp isStakePool txBody @@ -131,7 +133,8 @@ instance EraUTxO ConwayEra where getConsumedValue = getConsumedMaryValue - getProducedValue = conwayProducedValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (conwayProducedValue pp isRegPoolId) getScriptsProvided = getBabbageScriptsProvided @@ -153,7 +156,7 @@ getConwayMinFeeTxUtxo :: , BabbageEraTxBody era ) => PParams era -> - Tx era -> + Tx l era -> UTxO era -> Coin getConwayMinFeeTxUtxo pparams tx utxo = @@ -165,7 +168,7 @@ getConwayMinFeeTxUtxo pparams tx utxo = -- -- Any input that appears in both regular inputs and reference inputs of a transaction is -- only used once in this computation. -txNonDistinctRefScriptsSize :: (EraTx era, BabbageEraTxBody era) => UTxO era -> Tx era -> Int +txNonDistinctRefScriptsSize :: (EraTx era, BabbageEraTxBody era) => UTxO era -> Tx l era -> Int txNonDistinctRefScriptsSize utxo tx = getSum $ foldMap (Sum . originalBytesSize . snd) refScripts where inputs = (tx ^. bodyTxL . referenceInputsTxBodyL) `Set.union` (tx ^. bodyTxL . inputsTxBodyL) @@ -174,7 +177,7 @@ txNonDistinctRefScriptsSize utxo tx = getSum $ foldMap (Sum . originalBytesSize getConwayWitsVKeyNeeded :: (EraTx era, ConwayEraTxBody era) => UTxO era -> - TxBody era -> + TxBody l era -> Set.Set (KeyHash 'Witness) getConwayWitsVKeyNeeded utxo txBody = getShelleyWitsVKeyNeededNoGov utxo txBody @@ -183,7 +186,7 @@ getConwayWitsVKeyNeeded utxo txBody = voterWitnesses :: ConwayEraTxBody era => - TxBody era -> + TxBody l era -> Set.Set (KeyHash 'Witness) voterWitnesses txb = Map.foldrWithKey' accum mempty (unVotingProcedures (txb ^. votingProceduresTxBodyL)) diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs index 02772860f85..b597090f79b 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs @@ -40,8 +40,8 @@ spec = do describe "Ruby-based" $ beforeAllCddlFile 3 readConwayCddlFiles $ do cddlRoundTripCborSpec @(Value ConwayEra) v "positive_coin" cddlRoundTripCborSpec @(Value ConwayEra) v "value" - cddlRoundTripAnnCborSpec @(TxBody ConwayEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody ConwayEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx ConwayEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx ConwayEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock ConwayEra) v "native_script" @@ -58,31 +58,31 @@ spec = do cddlRoundTripCborSpec @CostModels v "cost_models" cddlRoundTripAnnCborSpec @(Redeemers ConwayEra) v "redeemers" cddlRoundTripCborSpec @(Redeemers ConwayEra) v "redeemers" - cddlRoundTripAnnCborSpec @(Tx ConwayEra) v "transaction" - cddlRoundTripCborSpec @(Tx ConwayEra) v "transaction" + cddlRoundTripAnnCborSpec @(Tx TopTx ConwayEra) v "transaction" + cddlRoundTripCborSpec @(Tx TopTx ConwayEra) v "transaction" cddlRoundTripCborSpec @(VotingProcedure ConwayEra) v "voting_procedure" cddlRoundTripCborSpec @(ProposalProcedure ConwayEra) v "proposal_procedure" cddlRoundTripCborSpec @(GovAction ConwayEra) v "gov_action" cddlRoundTripCborSpec @(TxCert ConwayEra) v "certificate" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody ConwayEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx ConwayEra) v "transaction_body" cddlDecoderEquivalenceSpec @(TxAuxData ConwayEra) v "auxiliary_data" cddlDecoderEquivalenceSpec @(Timelock ConwayEra) v "native_script" cddlDecoderEquivalenceSpec @(Data ConwayEra) v "plutus_data" cddlDecoderEquivalenceSpec @(Script ConwayEra) v "script" cddlDecoderEquivalenceSpec @(TxWits ConwayEra) v "transaction_witness_set" cddlDecoderEquivalenceSpec @(Redeemers ConwayEra) v "redeemers" - cddlDecoderEquivalenceSpec @(Tx ConwayEra) v "transaction" + cddlDecoderEquivalenceSpec @(Tx TopTx ConwayEra) v "transaction" describe "Huddle" $ specWithHuddle conwayCDDL 100 $ do -- Value huddleRoundTripCborSpec @(Value ConwayEra) v "positive_coin" huddleRoundTripArbitraryValidate @(Value ConwayEra) v "value" huddleRoundTripCborSpec @(Value ConwayEra) v "value" -- TxBody - huddleRoundTripAnnCborSpec @(TxBody ConwayEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx ConwayEra) v "transaction_body" -- TODO enable this once map/list expansion has been optimized in cuddle - xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(TxBody ConwayEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody ConwayEra) v "transaction_body" + xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(TxBody TopTx ConwayEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx ConwayEra) v "transaction_body" -- AuxData huddleRoundTripAnnCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" -- TODO fails because of plutus scripts @@ -130,10 +130,10 @@ spec = do xdescribe "fix redeemers" $ huddleRoundTripArbitraryValidate @(Redeemers ConwayEra) v "redeemers" huddleRoundTripCborSpec @(Redeemers ConwayEra) v "redeemers" -- Tx - huddleRoundTripAnnCborSpec @(Tx ConwayEra) v "transaction" + huddleRoundTripAnnCborSpec @(Tx TopTx ConwayEra) v "transaction" -- TODO enable this once map/list expansion has been optimized in cuddle - xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(Tx ConwayEra) v "transaction" - huddleRoundTripCborSpec @(Tx ConwayEra) v "transaction" + xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(Tx TopTx ConwayEra) v "transaction" + huddleRoundTripCborSpec @(Tx TopTx ConwayEra) v "transaction" -- VotingProcedure huddleRoundTripCborSpec @(VotingProcedure ConwayEra) v "voting_procedure" huddleRoundTripArbitraryValidate @(VotingProcedure ConwayEra) v "voting_procedure" @@ -151,11 +151,11 @@ spec = do -- TODO this fails because of the hard-coded `unit_interval` in the CDDL xdescribe "fix unit_interval" $ huddleRoundTripArbitraryValidate @(TxCert ConwayEra) v "certificate" describe "DecCBOR instances equivalence via CDDL" $ do - huddleDecoderEquivalenceSpec @(TxBody ConwayEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx ConwayEra) v "transaction_body" huddleDecoderEquivalenceSpec @(TxAuxData ConwayEra) v "auxiliary_data" huddleDecoderEquivalenceSpec @(Timelock ConwayEra) v "native_script" huddleDecoderEquivalenceSpec @(Data ConwayEra) v "plutus_data" huddleDecoderEquivalenceSpec @(Script ConwayEra) v "script" huddleDecoderEquivalenceSpec @(TxWits ConwayEra) v "transaction_witness_set" huddleDecoderEquivalenceSpec @(Redeemers ConwayEra) v "redeemers" - huddleDecoderEquivalenceSpec @(Tx ConwayEra) v "transaction" + huddleDecoderEquivalenceSpec @(Tx TopTx ConwayEra) v "transaction" diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 7d00af7e334..ac13fb02e1f 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -566,7 +566,7 @@ instance Arbitrary Vote where arbitrary = arbitraryBoundedEnum shrink = shrinkBoundedEnum -instance Arbitrary (TxBody ConwayEra) where +instance Arbitrary (TxBody TopTx ConwayEra) where arbitrary = ConwayTxBody <$> arbitrary @@ -891,4 +891,4 @@ instance Arbitrary (ConwayAccountState era) where instance Arbitrary (TransitionConfig ConwayEra) where arbitrary = ConwayTransitionConfig <$> arbitrary <*> arbitrary -deriving newtype instance Arbitrary (Tx ConwayEra) +deriving newtype instance Arbitrary (Tx TopTx ConwayEra) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Annotator.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Annotator.hs index 1f5993b9c63..6c06d3365df 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Annotator.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Annotator.hs @@ -17,6 +17,6 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.TxBody import Test.Cardano.Ledger.Babbage.Binary.Annotator -deriving newtype instance DecCBOR (TxBody ConwayEra) +deriving newtype instance DecCBOR (TxBody TopTx ConwayEra) -deriving newtype instance DecCBOR (Tx ConwayEra) +deriving newtype instance DecCBOR (Tx TopTx ConwayEra) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs index d041dc0f5be..110c1f0fd59 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs @@ -44,7 +44,7 @@ spec :: spec = describe "Regression" $ do it "DeserialiseFailure on resubmitting Conway Tx with invalid plutus script #4198" $ do io . expectRightDeep_ $ - decodeFullAnnotatorFromHexText @(Tx era) (eraProtVerLow @era) "Unwitnessed Tx" decCBOR $ + decodeFullAnnotatorFromHexText @(Tx TopTx era) (eraProtVerLow @era) "Unwitnessed Tx" decCBOR $ mconcat [ "84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300" , "37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3" @@ -59,7 +59,7 @@ spec = describe "Regression" $ do , "799f182aff0581840000d8799f182aff820000f4f6" ] expectRightDeep_ $ - decodeFullAnnotatorFromHexText @(Tx era) (eraProtVerLow @era) "Witnessed Tx" decCBOR $ + decodeFullAnnotatorFromHexText @(Tx TopTx era) (eraProtVerLow @era) "Witnessed Tx" decCBOR $ mconcat [ "84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300" , "37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3" diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/BinarySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/BinarySpec.hs index 1f2be33f1e2..c7746bb5fec 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/BinarySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/BinarySpec.hs @@ -80,12 +80,12 @@ spec = do prop "Completely empty mint MultiAsset fails deserialisation since Conway" $ -- Cannot use standard serialization because Conway TxBody encoder omits empty -- mint fields via 'Omit (== mempty) (Key 9 (To ctbrMint))', preventing decoder testing - testMultiAssetRejection @era @(TxBody era) (natVersion @9) "Conway" $ \version -> + testMultiAssetRejection @era @(TxBody TopTx era) (natVersion @9) "Conway" $ \version -> buildTxBodyCborWithMint @era (MultiAsset Map.empty) version prop "Empty nested asset maps in mint MultiAsset fails deserialisation since Conway" $ forAll arbitrary $ \policyId -> - testMultiAssetRejection @era @(TxBody era) (natVersion @9) "Conway" $ \version -> + testMultiAssetRejection @era @(TxBody TopTx era) (natVersion @9) "Conway" $ \version -> buildTxBodyCborWithMint @era (MultiAsset $ Map.singleton policyId Map.empty) version where -- The expectation used in this spec allows for the deserialization to fail, in which case diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs index bd5ebd393e8..0116b6f30ad 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs @@ -72,14 +72,14 @@ ledgerExamples = exampleTxConway exampleConwayGenesis -exampleTxConway :: Tx ConwayEra +exampleTxConway :: Tx TopTx ConwayEra exampleTxConway = exampleTx exampleTxBodyConway (ConwaySpending $ AsIx 0) (RequireAllOf @ConwayEra mempty) -exampleTxBodyConway :: TxBody ConwayEra +exampleTxBodyConway :: TxBody TopTx ConwayEra exampleTxBodyConway = ConwayTxBody (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash 1)) 0]) -- spending inputs diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index a8e52c5d467..923479bfbbb 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -113,7 +113,7 @@ spec = do -- We are creating reference scripts and transaction that depend on them in a "simulation", -- so the result will be correctly constructed that are not applied to the ledger state - txs :: [Tx era] <- simulateThenRestore $ do + txs :: [Tx TopTx era] <- simulateThenRestore $ do concat <$> forM txScriptCounts @@ -154,7 +154,7 @@ spec = do -- their individual reference script sizes, and then restore the original state - -- meaning the transactions are not actually applied. -- Finally, we check that the accumulated sizes from both before and after match. - txsWithRefScriptSizes :: ([(Tx era, Int)], Int) <- simulateThenRestore $ do + txsWithRefScriptSizes :: ([(Tx TopTx era, Int)], Int) <- simulateThenRestore $ do let mkTxWithExpectedSize expectedSize txAction = do tx <- txAction totalRefScriptSizeInBlock protVer [tx] <$> getUTxO `shouldReturn` expectedSize @@ -240,7 +240,7 @@ spec = do addr <- freshKeyAddr_ pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script) - (txs :: [Tx era]) <- simulateThenRestore $ do + (txs :: [Tx TopTx era]) <- simulateThenRestore $ do -- submit an invalid transaction which attempts to consume the failing script -- and specifies as collateral return the txout with reference script createCollateralTx <- diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index f5d2a79f815..ad9c5982852 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -60,7 +60,7 @@ spec = do maxRefScriptSizePerTx = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerTxG n = maxRefScriptSizePerTx `div` size + 1 txIns <- replicateM n (produceRefScript script) - let tx :: Tx era + let tx :: Tx TopTx era tx = mkBasicTx (mkBasicTxBody & referenceInputsTxBodyL .~ Set.fromList txIns) submitFailingTx tx diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs index 4a2eaa40b20..236dfa09b73 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs @@ -659,7 +659,7 @@ testPlutusV1V2Failure :: ) => ScriptHash -> a -> - Lens' (TxBody era) a -> + Lens' (TxBody TopTx era) a -> ContextError era -> ImpTestM era () testPlutusV1V2Failure sh badField lenz errorField = do 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..be091d4814e 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 @@ -30,6 +30,7 @@ import Cardano.Ledger.Conway.Core ( InjectRuleFailure (..), SafeHash, SafeToHash (..), + TxLevel (..), ppCoinsPerUTxOByteL, txIdTx, ) @@ -89,7 +90,7 @@ spec = do setupBadPPViewHashTx :: forall era. ConwayEraImp era => - ImpTestM era (Tx era) + ImpTestM era (Tx TopTx era) setupBadPPViewHashTx = do modifyPParams $ ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1) someKeyHash <- arbitrary @StakeReference @@ -114,8 +115,8 @@ substituteIntegrityHashAndFixWits :: forall era. ConwayEraImp era => StrictMaybe (SafeHash EraIndependentScriptIntegrity) -> - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) substituteIntegrityHashAndFixWits hash tx = let txWithNewHash = tx diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index 315d6f50e1d..358a48b54fe 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -719,7 +719,9 @@ trySubmitProposals :: , ConwayEraTxBody era ) => NE.NonEmpty (ProposalProcedure era) -> - ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era)) + ImpTestM + era + (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era)) trySubmitProposals proposals = do trySubmitTx $ mkBasicTx mkBasicTxBody @@ -771,7 +773,9 @@ submitAndExpireProposalToMakeReward stakingC = do trySubmitGovActions :: ConwayEraImp era => NE.NonEmpty (GovAction era) -> - ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era)) + ImpTestM + era + (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era)) trySubmitGovActions gas = do proposals <- traverse mkProposal gas trySubmitProposals proposals @@ -1719,7 +1723,7 @@ showConwayTxBalance :: PParams era -> CertState era -> UTxO era -> - Tx era -> + Tx TopTx era -> String showConwayTxBalance pp certState utxo tx = unlines @@ -1754,7 +1758,7 @@ logConwayTxBalance :: , ConwayEraTxBody era , ConwayEraCertState era ) => - Tx era -> + Tx TopTx era -> ImpTestM era () logConwayTxBalance tx = do pp <- getsPParams id diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs index 6dae9433a0b..2b2e0f7dc12 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs @@ -34,10 +34,10 @@ import Test.Cardano.Ledger.Conway.Arbitrary () instance TranslatableGen ConwayEra where tgRedeemers = genRedeemers - tgTx = fmap MkConwayTx . BabbageTranslatableGen.genTx @ConwayEra . genTxBody + tgTx = fmap MkConwayTx . BabbageTranslatableGen.genTx @ConwayEra . fmap asSTxTopLevel . genTxBody tgUtxo = BabbageTranslatableGen.utxoWithTx @ConwayEra -genTxBody :: SupportedLanguage ConwayEra -> Gen (TxBody ConwayEra) +genTxBody :: SupportedLanguage ConwayEra -> Gen (TxBody TopTx ConwayEra) genTxBody l@(SupportedLanguage slang) = do let lang = plutusLanguage slang genTxOuts = diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs index 6149ea72c9f..0344e603470 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -26,6 +27,7 @@ import Cardano.Ledger.Conway.TxInfo (ConwayContextError) import Cardano.Ledger.HKD import Control.State.Transition.Extended (STS (..)) import Data.Functor.Identity +import qualified Data.TreeDiff.OMap as OMap import Test.Cardano.Data.TreeDiff () import Test.Cardano.Ledger.Babbage.TreeDiff @@ -194,9 +196,32 @@ instance ToExpr (ConwayUtxosPredFailure era) -- TxBody -instance ToExpr ConwayTxBodyRaw - -instance ToExpr (TxBody ConwayEra) +instance ToExpr (ConwayTxBodyRaw TopTx ConwayEra) where + toExpr ConwayTxBodyRaw {..} = + Rec "ConwayTxBodyRaw" $ + OMap.fromList + [ ("ctbrSpendInputs", toExpr ctbrSpendInputs) + , ("ctbrCollateralInputs", toExpr ctbrCollateralInputs) + , ("ctbrReferenceInputs", toExpr ctbrReferenceInputs) + , ("ctbrOutputs", toExpr ctbrOutputs) + , ("ctbrCollateralReturn", toExpr ctbrCollateralReturn) + , ("ctbrTotalCollateral", toExpr ctbrTotalCollateral) + , ("ctbrCerts", toExpr ctbrCerts) + , ("ctbrWithdrawals", toExpr ctbrWithdrawals) + , ("ctbrFee", toExpr ctbrFee) + , ("ctbrVldt", toExpr ctbrVldt) + , ("ctbrReqSignerHashes", toExpr ctbrReqSignerHashes) + , ("ctbrMint", toExpr ctbrMint) + , ("ctbrScriptIntegrityHash", toExpr ctbrScriptIntegrityHash) + , ("ctbrAuxDataHash", toExpr ctbrAuxDataHash) + , ("ctbrNetworkId", toExpr ctbrNetworkId) + , ("ctbrVotingProcedures", toExpr ctbrVotingProcedures) + , ("ctbrProposalProcedures", toExpr ctbrProposalProcedures) + , ("ctbrCurrentTreasuryValue", toExpr ctbrCurrentTreasuryValue) + , ("ctbrTreasuryDonation", toExpr ctbrTreasuryDonation) + ] + +instance ToExpr (TxBody TopTx ConwayEra) -- Rules/Cert instance @@ -312,7 +337,7 @@ instance ToExpr (PParamsHKD StrictMaybe era) => ToExpr (EnactSignal era) instance ( ToExpr (PParamsHKD Identity era) , ToExpr (PParamsHKD StrictMaybe era) - , ToExpr (Tx era) + , ToExpr (Tx TopTx era) ) => ToExpr (CertsEnv era) @@ -328,4 +353,4 @@ instance ToExpr (PredicateFailure (EraRule "LEDGERS" era)) => ToExpr (ConwayBbodyPredFailure era) -instance ToExpr (Tx ConwayEra) +instance ToExpr (Tx TopTx ConwayEra) diff --git a/eras/dijkstra/impl/CHANGELOG.md b/eras/dijkstra/impl/CHANGELOG.md index 492033274aa..415564bad23 100644 --- a/eras/dijkstra/impl/CHANGELOG.md +++ b/eras/dijkstra/impl/CHANGELOG.md @@ -2,6 +2,11 @@ ## 0.2.0.0 +* Add `DijkstraTx` type with `DijkstraTx` and `DijkstraSubTx` constructors +* Add `DijkstraSubTxBody` constructor to `DijkstraTxBodyRaw` +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Add `DijkstraNativeScript` and `DijkstraNativeScriptRaw` along with type instances * Change `NativeScript` type family to `DijkstraNativeScript` * Add `evalDijkstraNativeScript` to `Scripts` module diff --git a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal index 367807f5715..ce5b9ead322 100644 --- a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal @@ -78,8 +78,10 @@ library -Wunused-packages build-depends: + FailT, aeson, base >=4.14 && <5, + bytestring, cardano-crypto-class, cardano-data, cardano-ledger-allegra, @@ -150,6 +152,7 @@ library testlib heredoc, microlens, small-steps, + tree-diff, executable huddle-cddl main-is: Main.hs diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Era.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Era.hs index 29a4976b0bc..782827f79e8 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Era.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Era.hs @@ -18,6 +18,9 @@ import Cardano.Ledger.Mary (MaryValue) import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Shelley.Rules +instance EraTxLevel DijkstraEra where + type STxLevel l DijkstraEra = STxBothLevels l DijkstraEra + ------------------------------------------------------------------------------- -- Deprecated rules ------------------------------------------------------------------------------- diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Translation.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Translation.hs index 53e9544a34c..a78e4c8d9d2 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Translation.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Translation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -54,21 +55,22 @@ import Lens.Micro ((&), (.~), (^.)) type instance TranslationContext DijkstraEra = DijkstraGenesis -instance TranslateEra DijkstraEra Tx where - type TranslationError DijkstraEra Tx = DecoderError - translateEra _ctxt tx = do - -- Note that this does not preserve the hidden bytes field of the transaction. - -- This is under the premise that this is irrelevant for TxInBlocks, which are - -- not transmitted as contiguous chunks. - txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL - txWits <- translateEraThroughCBOR "TxWits" $ tx ^. witsTxL - auxData <- mapM (translateEraThroughCBOR "TxAuxData") (tx ^. auxDataTxL) - let isValidTx = tx ^. isValidTxL - pure $ - mkBasicTx txBody - & witsTxL .~ txWits - & isValidTxL .~ isValidTx - & auxDataTxL .~ auxData +instance TranslateEra DijkstraEra (Tx TopTx) where + type TranslationError DijkstraEra (Tx TopTx) = DecoderError + translateEra _ctxt tx = case toSTxLevel tx of + STopTxOnly -> do + -- Note that this does not preserve the hidden bytes field of the transaction. + -- This is under the premise that this is irrelevant for TxInBlocks, which are + -- not transmitted as contiguous chunks. + txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL + txWits <- translateEraThroughCBOR "TxWits" $ tx ^. witsTxL + auxData <- mapM (translateEraThroughCBOR "TxAuxData") (tx ^. auxDataTxL) + let isValidTx = tx ^. isValidTxL + pure $ + mkBasicTx txBody + & witsTxL .~ txWits + & isValidTxL .~ isValidTx + & auxDataTxL .~ auxData instance TranslateEra DijkstraEra NewEpochState where translateEra ctxt nes = do diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Tx.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Tx.hs index 6a13fbe9210..acd2edaac00 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Tx.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Tx.hs @@ -1,33 +1,47 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Dijkstra.Tx ( + DijkstraTx (..), Tx (..), validateDijkstraNativeScript, ) where -import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..)) +import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..), StrictMaybe) import Cardano.Ledger.Alonzo.Tx ( AlonzoEraTx, - AlonzoTx (..), - alonzoTxEqRaw, - auxDataAlonzoTxL, - bodyAlonzoTxL, - isValidAlonzoTxL, - mkBasicAlonzoTx, - sizeAlonzoTxF, - witsAlonzoTxL, + IsValid (..), ) -import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR, ToCBOR) +import Cardano.Ledger.BaseTypes (StrictMaybe (..), integralToBounded) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (..), + EncCBOR (..), + Encoding, + ToCBOR (..), + decodeNullStrictMaybe, + encodeListLen, + encodeNullStrictMaybe, + serialize, + ) +import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<*!)) import Cardano.Ledger.Conway.Tx (AlonzoEraTx (..), Tx (..), getConwayMinFeeTx) import Cardano.Ledger.Core import Cardano.Ledger.Dijkstra.Era (DijkstraEra) @@ -41,29 +55,123 @@ import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..)) import Cardano.Ledger.Dijkstra.TxWits () import Cardano.Ledger.Keys.WitVKey (witVKeyHash) import Cardano.Ledger.MemoBytes (EqRaw (..)) -import Control.DeepSeq (NFData) +import Cardano.Ledger.Shelley.Tx (shelleyTxEqRaw) +import Control.DeepSeq (NFData (..), deepseq) +import Control.Monad.Trans.Fail.String (errorFail) +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.Word (Word32) import GHC.Generics (Generic) -import Lens.Micro (Lens', lens, (^.)) -import NoThunks.Class (NoThunks) +import Lens.Micro (Lens', SimpleGetter, lens, to, (^.)) +import NoThunks.Class (InspectHeap (..), NoThunks) + +data DijkstraTx l era where + DijkstraTx :: + { dtBody :: !(TxBody TopTx era) + , dtWits :: !(TxWits era) + , dtIsValid :: !IsValid + , dtAuxData :: !(StrictMaybe (TxAuxData era)) + } -> + DijkstraTx TopTx era + DijkstraSubTx :: + { dstBody :: !(TxBody SubTx era) + , dstWits :: !(TxWits era) + , dstAuxData :: !(StrictMaybe (TxAuxData era)) + } -> + DijkstraTx SubTx era + +deriving instance EraTx era => Eq (DijkstraTx l era) + +deriving instance EraTx era => Show (DijkstraTx l era) + +instance + ( EraTx era + , NFData (TxWits era) + , NFData (TxAuxData era) + ) => + NFData (DijkstraTx l era) + where + rnf DijkstraTx {..} = + dtBody `deepseq` + dtWits `deepseq` + dtIsValid `deepseq` + rnf dtAuxData + rnf DijkstraSubTx {..} = + dstBody `deepseq` + dstWits `deepseq` + rnf dstAuxData + +deriving via + InspectHeap (DijkstraTx l era) + instance + ( Era era + , Typeable l + ) => + NoThunks (DijkstraTx l era) + +instance (EraTx era, Typeable l) => ToCBOR (DijkstraTx l era) where + toCBOR = toEraCBOR @era + +instance EraTx era => EncCBOR (DijkstraTx l era) where + encCBOR = toCBORForMempoolSubmission + +instance (EraTx era, Typeable l) => DecCBOR (Annotator (DijkstraTx l era)) where + decCBOR = withSTxBothLevels @l $ \case + STopTx -> + decode $ + Ann (RecD DijkstraTx) + <*! From + <*! From + <*! Ann From + <*! D (sequence <$> decodeNullStrictMaybe decCBOR) + SSubTx -> + decode $ + Ann (RecD DijkstraSubTx) + <*! From + <*! From + <*! D (sequence <$> decodeNullStrictMaybe decCBOR) + +instance HasEraTxLevel DijkstraTx DijkstraEra where + toSTxLevel DijkstraTx {} = STopTx + toSTxLevel DijkstraSubTx {} = SSubTx + +instance HasEraTxLevel Tx DijkstraEra where + toSTxLevel = toSTxLevel . unDijkstraTx + +mkBasicDijkstraTx :: TxBody l DijkstraEra -> DijkstraTx l DijkstraEra +mkBasicDijkstraTx txBody = + case toSTxLevel txBody of + STopTx -> + DijkstraTx + txBody + mempty + (IsValid True) + SNothing + SSubTx -> + DijkstraSubTx + txBody + mempty + SNothing instance EraTx DijkstraEra where - newtype Tx DijkstraEra = MkDijkstraTx {unDijkstraTx :: AlonzoTx DijkstraEra} + newtype Tx l DijkstraEra = MkDijkstraTx {unDijkstraTx :: DijkstraTx l DijkstraEra} deriving newtype (Eq, Show, NFData, NoThunks, ToCBOR, EncCBOR) deriving (Generic) - mkBasicTx = MkDijkstraTx . mkBasicAlonzoTx + mkBasicTx = MkDijkstraTx . mkBasicDijkstraTx - bodyTxL = dijkstraTxL . bodyAlonzoTxL + bodyTxL = dijkstraTxL . bodyDijkstraTxL {-# INLINE bodyTxL #-} - witsTxL = dijkstraTxL . witsAlonzoTxL + witsTxL = dijkstraTxL . witsDijkstraTxL {-# INLINE witsTxL #-} - auxDataTxL = dijkstraTxL . auxDataAlonzoTxL + auxDataTxL = dijkstraTxL . auxDataDijkstraTxL {-# INLINE auxDataTxL #-} - sizeTxF = dijkstraTxL . sizeAlonzoTxF + sizeTxF = dijkstraTxL . sizeDijkstraTxF {-# INLINE sizeTxF #-} validateNativeScript = validateDijkstraNativeScript @@ -71,17 +179,103 @@ instance EraTx DijkstraEra where getMinFeeTx = getConwayMinFeeTx -instance EqRaw (Tx DijkstraEra) where - eqRaw = alonzoTxEqRaw +bodyDijkstraTxL :: Lens' (DijkstraTx l era) (TxBody l era) +bodyDijkstraTxL = + lens + ( \case + DijkstraTx {dtBody} -> dtBody + DijkstraSubTx {dstBody} -> dstBody + ) + ( \case + tx@DijkstraTx {} -> \x -> tx {dtBody = x} + tx@DijkstraSubTx {} -> \x -> tx {dstBody = x} + ) + +witsDijkstraTxL :: Lens' (DijkstraTx l era) (TxWits era) +witsDijkstraTxL = + lens + ( \case + DijkstraTx {dtWits} -> dtWits + DijkstraSubTx {dstWits} -> dstWits + ) + ( \case + tx@DijkstraTx {} -> \x -> tx {dtWits = x} + tx@DijkstraSubTx {} -> \x -> tx {dstWits = x} + ) + +isValidDijkstraTxL :: Lens' (DijkstraTx TopTx era) IsValid +isValidDijkstraTxL = + lens (\DijkstraTx {dtIsValid} -> dtIsValid) $ \tx txIsValid -> + case tx of + DijkstraTx {} -> tx {dtIsValid = txIsValid} + +auxDataDijkstraTxL :: Lens' (DijkstraTx l era) (StrictMaybe (TxAuxData era)) +auxDataDijkstraTxL = + lens + ( \case + DijkstraTx {dtAuxData} -> dtAuxData + DijkstraSubTx {dstAuxData} -> dstAuxData + ) + ( \case + tx@DijkstraTx {} -> \x -> tx {dtAuxData = x} + tx@DijkstraSubTx {} -> \x -> tx {dstAuxData = x} + ) + +toCBORForSizeComputation :: + ( EncCBOR (TxBody l era) + , EncCBOR (TxWits era) + , EncCBOR (TxAuxData era) + ) => + DijkstraTx l era -> + Encoding +toCBORForSizeComputation tx = + encodeListLen 3 + <> encCBOR (tx ^. bodyDijkstraTxL) + <> encCBOR (tx ^. witsDijkstraTxL) + <> encodeNullStrictMaybe encCBOR (tx ^. auxDataDijkstraTxL) + +sizeDijkstraTxF :: + forall era l. + EraTx era => + SimpleGetter (DijkstraTx l era) Word32 +sizeDijkstraTxF = + to $ + errorFail + . integralToBounded @Int64 @Word32 + . LBS.length + . serialize (eraProtVerLow @era) + . toCBORForSizeComputation -dijkstraTxL :: Lens' (Tx DijkstraEra) (AlonzoTx DijkstraEra) +dijkstraTxEqRaw :: + ( STxLevel l era ~ STxBothLevels l era + , AlonzoEraTx era + ) => + Tx l era -> + Tx l era -> + Bool +dijkstraTxEqRaw tx1 tx2 = + shelleyTxEqRaw tx1 tx2 + && withBothTxLevels + tx1 + ( \tx1' -> + withBothTxLevels + tx2 + (\tx2' -> tx1' ^. isValidTxL == tx2' ^. isValidTxL) + (const True) + ) + (const True) + +instance EqRaw (Tx l DijkstraEra) where + eqRaw = dijkstraTxEqRaw + +dijkstraTxL :: Lens' (Tx l DijkstraEra) (DijkstraTx l DijkstraEra) dijkstraTxL = lens unDijkstraTx (\x y -> x {unDijkstraTx = y}) instance AlonzoEraTx DijkstraEra where - isValidTxL = dijkstraTxL . isValidAlonzoTxL + isValidTxL = dijkstraTxL . isValidDijkstraTxL {-# INLINE isValidTxL #-} -instance DecCBOR (Annotator (Tx DijkstraEra)) where +instance Typeable l => DecCBOR (Annotator (Tx l DijkstraEra)) where decCBOR = fmap MkDijkstraTx <$> decCBOR validateDijkstraNativeScript :: @@ -90,9 +284,50 @@ validateDijkstraNativeScript :: , DijkstraEraScript era , NativeScript era ~ DijkstraNativeScript era ) => - Tx era -> NativeScript era -> Bool + Tx l era -> NativeScript era -> Bool validateDijkstraNativeScript tx = evalDijkstraNativeScript vhks (tx ^. bodyTxL . vldtTxBodyL) (tx ^. bodyTxL . guardsTxBodyL) where vhks = Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL) {-# INLINEABLE validateDijkstraNativeScript #-} + +-------------------------------------------------------------------------------- +-- Mempool Serialisation +-- +-- We do not store the Tx bytes for the following reasons: +-- - A Tx serialised in this way never forms part of any hashed structure, hence +-- we do not worry about the serialisation changing and thus seeing a new +-- hash. +-- - The three principal components of this Tx already store their own bytes; +-- here we simply concatenate them. The final component, `IsValid`, is +-- just a flag and very cheap to serialise. +-------------------------------------------------------------------------------- + +-- | Encode to CBOR for the purposes of transmission from node to node, or from +-- wallet to node. +-- +-- Note that this serialisation is neither the serialisation used on-chain +-- (where Txs are deconstructed using segwit), nor the serialisation used for +-- computing the transaction size (which omits the `IsValid` field for +-- compatibility with Mary - see 'toCBORForSizeComputation'). +toCBORForMempoolSubmission :: + ( EncCBOR (TxBody l era) + , EncCBOR (TxWits era) + , EncCBOR (TxAuxData era) + ) => + DijkstraTx l era -> + Encoding +toCBORForMempoolSubmission = \case + DijkstraTx {dtBody, dtWits, dtAuxData, dtIsValid} -> + encode $ + Rec DijkstraTx + !> To dtBody + !> To dtWits + !> To dtIsValid + !> E (encodeNullStrictMaybe encCBOR) dtAuxData + DijkstraSubTx {dstBody, dstWits, dstAuxData} -> + encode $ + Rec DijkstraSubTx + !> To dstBody + !> To dstWits + !> E (encodeNullStrictMaybe encCBOR) dstAuxData diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs index c1278057f30..f93b2ba6682 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxBody.hs @@ -3,9 +3,11 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -22,6 +24,7 @@ module Cardano.Ledger.Dijkstra.TxBody ( TxBody ( MkDijkstraTxBody, DijkstraTxBody, + DijkstraSubTxBody, dtbSpendInputs, dtbCollateralInputs, dtbReferenceInputs, @@ -40,13 +43,29 @@ module Cardano.Ledger.Dijkstra.TxBody ( dtbProposalProcedures, dtbCurrentTreasuryValue, dtbTreasuryDonation, - dtbGuards + dtbGuards, + dstbSpendInputs, + dstbReferenceInputs, + dstbOutputs, + dstbCerts, + dstbWithdrawals, + dstbVldt, + dstbMint, + dstbScriptIntegrityHash, + dstbAdHash, + dstbTxNetworkId, + dstbVotingProcedures, + dstbProposalProcedures, + dstbCurrentTreasuryValue, + dstbTreasuryDonation, + dstbGuards ), upgradeProposals, upgradeGovAction, DijkstraTxBodyRaw (..), ) where +import Cardano.Ledger.Allegra.Scripts (invalidBeforeL, invalidHereAfterL) import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) import Cardano.Ledger.Babbage.TxBody ( allSizedOutputsBabbageTxBodyF, @@ -98,7 +117,7 @@ import Cardano.Ledger.Dijkstra.Era (DijkstraEra) import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..)) import Cardano.Ledger.Dijkstra.TxOut () import Cardano.Ledger.Keys (HasKeyRole (..)) -import Cardano.Ledger.Mary.Value (MultiAsset, policies) +import Cardano.Ledger.Mary.Value (MultiAsset) import Cardano.Ledger.MemoBytes ( EqRaw, Mem, @@ -108,11 +127,12 @@ import Cardano.Ledger.MemoBytes ( getMemoRawType, getMemoSafeHash, lensMemoRawType, + memoRawTypeL, mkMemoizedEra, ) import Cardano.Ledger.TxIn (TxIn) import Cardano.Ledger.Val (Val (..)) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), deepseq) import Data.Coerce (coerce) import Data.OSet.Strict (OSet, decodeOSet) import qualified Data.OSet.Strict as OSet @@ -120,45 +140,106 @@ import Data.STRef (newSTRef, readSTRef, writeSTRef) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set, foldr') import qualified Data.Set as Set +import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Lens.Micro (Lens', to, (^.)) -import NoThunks.Class (NoThunks) - -data DijkstraTxBodyRaw = DijkstraTxBodyRaw - { dtbrSpendInputs :: !(Set TxIn) - , dtbrCollateralInputs :: !(Set TxIn) - , dtbrReferenceInputs :: !(Set TxIn) - , dtbrOutputs :: !(StrictSeq (Sized (TxOut DijkstraEra))) - , dtbrCollateralReturn :: !(StrictMaybe (Sized (TxOut DijkstraEra))) - , dtbrTotalCollateral :: !(StrictMaybe Coin) - , dtbrCerts :: !(OSet.OSet (TxCert DijkstraEra)) - , dtbrWithdrawals :: !Withdrawals - , dtbrFee :: !Coin - , dtbrVldt :: !ValidityInterval - , dtbrGuards :: !(OSet (Credential Guard)) - , dtbrMint :: !MultiAsset - , dtbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) - , dtbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - , dtbrNetworkId :: !(StrictMaybe Network) - , dtbrVotingProcedures :: !(VotingProcedures DijkstraEra) - , dtbrProposalProcedures :: !(OSet.OSet (ProposalProcedure DijkstraEra)) - , dtbrCurrentTreasuryValue :: !(StrictMaybe Coin) - , dtbrTreasuryDonation :: !Coin - } - deriving (Generic) - -deriving instance Eq DijkstraTxBodyRaw - -instance EqRaw (TxBody DijkstraEra) - -instance NoThunks DijkstraTxBodyRaw - -instance NFData DijkstraTxBodyRaw - -deriving instance Show DijkstraTxBodyRaw - -basicDijkstraTxBodyRaw :: DijkstraTxBodyRaw -basicDijkstraTxBodyRaw = +import Lens.Micro (Lens', lens, to, (.~), (^.)) +import NoThunks.Class (InspectHeap (..), NoThunks) + +data DijkstraTxBodyRaw l era where + DijkstraTxBodyRaw :: + { dtbrSpendInputs :: !(Set TxIn) + , dtbrCollateralInputs :: !(Set TxIn) + , dtbrReferenceInputs :: !(Set TxIn) + , dtbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , dtbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , dtbrTotalCollateral :: !(StrictMaybe Coin) + , dtbrCerts :: !(OSet.OSet (TxCert era)) + , dtbrWithdrawals :: !Withdrawals + , dtbrFee :: !Coin + , dtbrVldt :: !ValidityInterval + , dtbrGuards :: !(OSet (Credential Guard)) + , dtbrMint :: !MultiAsset + , dtbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , dtbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , dtbrNetworkId :: !(StrictMaybe Network) + , dtbrVotingProcedures :: !(VotingProcedures era) + , dtbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , dtbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , dtbrTreasuryDonation :: !Coin + } -> + DijkstraTxBodyRaw TopTx era + DijkstraSubTxBodyRaw :: + { dstbrSpendInputs :: !(Set TxIn) + , dstbrReferenceInputs :: !(Set TxIn) + , dstbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , dstbrCerts :: !(OSet.OSet (TxCert era)) + , dstbrWithdrawals :: !Withdrawals + , dstbrVldt :: !ValidityInterval + , dstbrGuards :: !(OSet (Credential Guard)) + , dstbrMint :: !MultiAsset + , dstbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , dstbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , dstbrNetworkId :: !(StrictMaybe Network) + , dstbrVotingProcedures :: !(VotingProcedures era) + , dstbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , dstbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , dstbrTreasuryDonation :: !Coin + } -> + DijkstraTxBodyRaw SubTx era + +deriving instance EraTxBody era => Eq (DijkstraTxBodyRaw l era) + +instance EqRaw (TxBody l DijkstraEra) + +deriving via + InspectHeap (DijkstraTxBodyRaw l era) + instance + (Typeable l, EraTxBody era) => NoThunks (DijkstraTxBodyRaw l era) + +instance EraTxBody era => NFData (DijkstraTxBodyRaw l era) where + rnf txBodyRaw@(DijkstraTxBodyRaw _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = + let DijkstraTxBodyRaw {..} = txBodyRaw + in dtbrSpendInputs `deepseq` + dtbrCollateralInputs `deepseq` + dtbrReferenceInputs `deepseq` + dtbrOutputs `deepseq` + dtbrCollateralReturn `deepseq` + dtbrTotalCollateral `deepseq` + dtbrCerts `deepseq` + dtbrWithdrawals `deepseq` + dtbrFee `deepseq` + dtbrVldt `deepseq` + dtbrGuards `deepseq` + dtbrMint `deepseq` + dtbrScriptIntegrityHash `deepseq` + dtbrAuxDataHash `deepseq` + dtbrNetworkId `deepseq` + dtbrVotingProcedures `deepseq` + dtbrProposalProcedures `deepseq` + dtbrCurrentTreasuryValue `deepseq` + rnf dtbrTreasuryDonation + rnf txBodyRaw@(DijkstraSubTxBodyRaw _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = + let DijkstraSubTxBodyRaw {..} = txBodyRaw + in dstbrSpendInputs `deepseq` + dstbrReferenceInputs `deepseq` + dstbrOutputs `deepseq` + dstbrCerts `deepseq` + dstbrWithdrawals `deepseq` + dstbrVldt `deepseq` + dstbrGuards `deepseq` + dstbrMint `deepseq` + dstbrScriptIntegrityHash `deepseq` + dstbrAuxDataHash `deepseq` + dstbrNetworkId `deepseq` + dstbrVotingProcedures `deepseq` + dstbrProposalProcedures `deepseq` + dstbrCurrentTreasuryValue `deepseq` + rnf dstbrTreasuryDonation + +deriving instance EraTxBody era => Show (DijkstraTxBodyRaw l era) + +basicDijkstraTxBodyRaw :: EraTxBody era => STxBothLevels l era -> DijkstraTxBodyRaw l era +basicDijkstraTxBodyRaw STopTx = DijkstraTxBodyRaw mempty mempty @@ -179,85 +260,102 @@ basicDijkstraTxBodyRaw = OSet.empty SNothing mempty +basicDijkstraTxBodyRaw SSubTx = + DijkstraSubTxBodyRaw + mempty + mempty + mempty + mempty + (Withdrawals mempty) + (ValidityInterval SNothing SNothing) + mempty + mempty + SNothing + SNothing + SNothing + (VotingProcedures mempty) + mempty + mempty + mempty -instance DecCBOR DijkstraTxBodyRaw where - decCBOR = +instance (Typeable l, EraTxBody era) => DecCBOR (DijkstraTxBodyRaw l era) where + decCBOR = withSTxBothLevels @l $ \sTxLevel -> decode $ SparseKeyed "TxBodyRaw" - basicDijkstraTxBodyRaw - bodyFields + (basicDijkstraTxBodyRaw sTxLevel) + (bodyFields sTxLevel) requiredFields where - bodyFields :: Word -> Field DijkstraTxBodyRaw - bodyFields 0 = field (\x tx -> tx {dtbrSpendInputs = x}) From - bodyFields 1 = field (\x tx -> tx {dtbrOutputs = x}) From - bodyFields 2 = field (\x tx -> tx {dtbrFee = x}) From - bodyFields 3 = - ofield - (\x tx -> tx {dtbrVldt = (dtbrVldt tx) {invalidHereafter = x}}) - From - bodyFields 4 = - fieldGuarded - (emptyFailure "Certificates" "non-empty") - OSet.null - (\x tx -> tx {dtbrCerts = x}) - From - bodyFields 5 = - fieldGuarded - (emptyFailure "Withdrawals" "non-empty") - (null . unWithdrawals) - (\x tx -> tx {dtbrWithdrawals = x}) - From - bodyFields 7 = ofield (\x tx -> tx {dtbrAuxDataHash = x}) From - bodyFields 8 = - ofield - (\x tx -> tx {dtbrVldt = (dtbrVldt tx) {invalidBefore = x}}) - From - bodyFields 9 = - fieldGuarded - (emptyFailure "Mint" "non-empty") - (== mempty) - (\x tx -> tx {dtbrMint = x}) - From - bodyFields 11 = ofield (\x tx -> tx {dtbrScriptIntegrityHash = x}) From - bodyFields 13 = - fieldGuarded - (emptyFailure "Collateral Inputs" "non-empty") - null - (\x tx -> tx {dtbrCollateralInputs = x}) - From - bodyFields 14 = - ofield - (\x tx -> tx {dtbrGuards = fromSMaybe mempty x}) - (D decodeGuards) - bodyFields 15 = ofield (\x tx -> tx {dtbrNetworkId = x}) From - bodyFields 16 = ofield (\x tx -> tx {dtbrCollateralReturn = x}) From - bodyFields 17 = ofield (\x tx -> tx {dtbrTotalCollateral = x}) From - bodyFields 18 = - fieldGuarded - (emptyFailure "Reference Inputs" "non-empty") - null - (\x tx -> tx {dtbrReferenceInputs = x}) - From - bodyFields 19 = - fieldGuarded - (emptyFailure "VotingProcedures" "non-empty") - (null . unVotingProcedures) - (\x tx -> tx {dtbrVotingProcedures = x}) - From - bodyFields 20 = - fieldGuarded - (emptyFailure "ProposalProcedures" "non-empty") - OSet.null - (\x tx -> tx {dtbrProposalProcedures = x}) - From - bodyFields 21 = ofield (\x tx -> tx {dtbrCurrentTreasuryValue = x}) From - bodyFields 22 = - ofield - (\x tx -> tx {dtbrTreasuryDonation = fromSMaybe zero x}) - (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) - bodyFields n = invalidField n + bodyFields :: STxBothLevels l era -> Word -> Field (DijkstraTxBodyRaw l era) + bodyFields sTxLevel = \case + 0 -> field (inputsDijkstraTxBodyRawL .~) From + 1 -> field (outputsDijkstraTxBodyRawL .~) From + 2 | STopTx <- sTxLevel -> field (feeDijkstraTxBodyRawL .~) From + 3 -> ofield (vldtDijkstraTxBodyRawL . invalidHereAfterL .~) From + 4 -> + fieldGuarded + (emptyFailure "Certificates" "non-empty") + OSet.null + (certsDijkstraTxBodyRawL .~) + From + 5 -> + fieldGuarded + (emptyFailure "Withdrawals" "non-empty") + (null . unWithdrawals) + (withdrawalsDijkstraTxBodyRawL .~) + From + 7 -> ofield (auxDataHashDijkstraTxBodyRawL .~) From + 8 -> ofield (vldtDijkstraTxBodyRawL . invalidBeforeL .~) From + 9 -> + fieldGuarded + (emptyFailure "Mint" "non-empty") + (== mempty) + (mintDijkstraTxBodyRawL .~) + From + 11 -> ofield (scriptIntegrityHashDijkstraTxBodyRawL .~) From + 13 + | STopTx <- sTxLevel -> + fieldGuarded + (emptyFailure "Collateral Inputs" "non-empty") + null + (collateralInputsDijkstraTxBodyRawL .~) + From + 14 -> + ofield + (\x -> guardsDijkstraTxBodyRawL .~ fromSMaybe mempty x) + (D decodeGuards) + 15 -> ofield (networkIdDijkstraTxBodyRawL .~) From + 16 + | STopTx <- sTxLevel -> + ofield (collateralReturnDijkstraTxBodyRawL .~) From + 17 + | STopTx <- sTxLevel -> + ofield (totalCollateralDijkstraTxBodyRawL .~) From + 18 -> + fieldGuarded + (emptyFailure "Reference Inputs" "non-empty") + null + (referenceInputsDijkstraTxBodyRawL .~) + From + 19 -> + fieldGuarded + (emptyFailure "VotingProcedures" "non-empty") + (null . unVotingProcedures) + (votingProceduresDijkstraTxBodyRawL .~) + From + 20 -> + fieldGuarded + (emptyFailure "ProposalProcedures" "non-empty") + OSet.null + (proposalProceduresDijkstraTxBodyRawL .~) + From + 21 -> ofield (currentTreasuryValueDijkstraTxBodyRawL .~) From + 22 -> + ofield + (\x -> treasuryDonationDijkstraTxBodyRawL .~ fromSMaybe zero x) + (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) + n -> invalidField n requiredFields :: [(Word, String)] requiredFields = [ (0, "inputs") @@ -268,8 +366,9 @@ instance DecCBOR DijkstraTxBodyRaw where "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" encodeTxBodyRaw :: - DijkstraTxBodyRaw -> - Encode ('Closed 'Sparse) DijkstraTxBodyRaw + EraTxBody era => + DijkstraTxBodyRaw l era -> + Encode ('Closed 'Sparse) (DijkstraTxBodyRaw l era) encodeTxBodyRaw DijkstraTxBodyRaw {..} = let ValidityInterval bot top = dtbrVldt in Keyed @@ -296,17 +395,39 @@ encodeTxBodyRaw DijkstraTxBodyRaw {..} = !> Omit OSet.null (Key 20 (To dtbrProposalProcedures)) !> encodeKeyedStrictMaybe 21 dtbrCurrentTreasuryValue !> Omit (== mempty) (Key 22 $ To dtbrTreasuryDonation) +encodeTxBodyRaw DijkstraSubTxBodyRaw {..} = + let ValidityInterval bot top = dstbrVldt + in Keyed + ( \i ri o t c w b -> + DijkstraSubTxBodyRaw i ri o c w (ValidityInterval b t) + ) + !> Key 0 (To dstbrSpendInputs) + !> Omit null (Key 18 (To dstbrReferenceInputs)) + !> Key 1 (To dstbrOutputs) + !> encodeKeyedStrictMaybe 3 top + !> Omit OSet.null (Key 4 (To dstbrCerts)) + !> Omit (null . unWithdrawals) (Key 5 (To dstbrWithdrawals)) + !> encodeKeyedStrictMaybe 8 bot + !> Omit null (Key 14 (To dstbrGuards)) + !> Omit (== mempty) (Key 9 (To dstbrMint)) + !> encodeKeyedStrictMaybe 11 dstbrScriptIntegrityHash + !> encodeKeyedStrictMaybe 7 dstbrAuxDataHash + !> encodeKeyedStrictMaybe 15 dstbrNetworkId + !> Omit (null . unVotingProcedures) (Key 19 (To dstbrVotingProcedures)) + !> Omit OSet.null (Key 20 (To dstbrProposalProcedures)) + !> encodeKeyedStrictMaybe 21 dstbrCurrentTreasuryValue + !> Omit (== mempty) (Key 22 $ To dstbrTreasuryDonation) -instance EncCBOR DijkstraTxBodyRaw where +instance EraTxBody era => EncCBOR (DijkstraTxBodyRaw l era) where encCBOR = encode . encodeTxBodyRaw -deriving instance NoThunks (TxBody DijkstraEra) +deriving instance Typeable l => NoThunks (TxBody l DijkstraEra) -deriving instance Eq (TxBody DijkstraEra) +deriving instance Eq (TxBody l DijkstraEra) -deriving newtype instance NFData (TxBody DijkstraEra) +deriving newtype instance NFData (TxBody l DijkstraEra) -deriving instance Show (TxBody DijkstraEra) +deriving instance Show (TxBody l DijkstraEra) pattern DijkstraTxBody :: Set TxIn -> @@ -328,7 +449,7 @@ pattern DijkstraTxBody :: OSet.OSet (ProposalProcedure DijkstraEra) -> StrictMaybe Coin -> Coin -> - TxBody DijkstraEra + TxBody TopTx DijkstraEra pattern DijkstraTxBody { dtbSpendInputs , dtbCollateralInputs @@ -416,58 +537,219 @@ pattern DijkstraTxBody currentTreasuryValue treasuryDonation -{-# COMPLETE DijkstraTxBody #-} +pattern DijkstraSubTxBody :: + Set TxIn -> + Set TxIn -> + StrictSeq (Sized (TxOut DijkstraEra)) -> + OSet.OSet (TxCert DijkstraEra) -> + Withdrawals -> + ValidityInterval -> + OSet (Credential Guard) -> + MultiAsset -> + StrictMaybe ScriptIntegrityHash -> + StrictMaybe TxAuxDataHash -> + StrictMaybe Network -> + VotingProcedures DijkstraEra -> + OSet.OSet (ProposalProcedure DijkstraEra) -> + StrictMaybe Coin -> + Coin -> + TxBody SubTx DijkstraEra +pattern DijkstraSubTxBody + { dstbSpendInputs + , dstbReferenceInputs + , dstbOutputs + , dstbCerts + , dstbWithdrawals + , dstbVldt + , dstbGuards + , dstbMint + , dstbScriptIntegrityHash + , dstbAdHash + , dstbTxNetworkId + , dstbVotingProcedures + , dstbProposalProcedures + , dstbCurrentTreasuryValue + , dstbTreasuryDonation + } <- + ( getMemoRawType -> + DijkstraSubTxBodyRaw + { dstbrSpendInputs = dstbSpendInputs + , dstbrReferenceInputs = dstbReferenceInputs + , dstbrOutputs = dstbOutputs + , dstbrCerts = dstbCerts + , dstbrWithdrawals = dstbWithdrawals + , dstbrVldt = dstbVldt + , dstbrGuards = dstbGuards + , dstbrMint = dstbMint + , dstbrScriptIntegrityHash = dstbScriptIntegrityHash + , dstbrAuxDataHash = dstbAdHash + , dstbrNetworkId = dstbTxNetworkId + , dstbrVotingProcedures = dstbVotingProcedures + , dstbrProposalProcedures = dstbProposalProcedures + , dstbrCurrentTreasuryValue = dstbCurrentTreasuryValue + , dstbrTreasuryDonation = dstbTreasuryDonation + } + ) + where + DijkstraSubTxBody + inputsX + referenceInputsX + outputsX + certsX + withdrawalsX + vldtX + guards + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation = + mkMemoizedEra @DijkstraEra $ + DijkstraSubTxBodyRaw + inputsX + referenceInputsX + outputsX + certsX + withdrawalsX + vldtX + guards + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation + +{-# COMPLETE DijkstraTxBody, DijkstraSubTxBody #-} -instance Memoized (TxBody DijkstraEra) where - type RawType (TxBody DijkstraEra) = DijkstraTxBodyRaw +instance Memoized (TxBody l DijkstraEra) where + type RawType (TxBody l DijkstraEra) = DijkstraTxBodyRaw l DijkstraEra -instance EncCBOR (TxBody DijkstraEra) +deriving newtype instance EncCBOR (TxBody l DijkstraEra) -type instance MemoHashIndex DijkstraTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (DijkstraTxBodyRaw l DijkstraEra) = EraIndependentTxBody -instance HashAnnotated (TxBody DijkstraEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l DijkstraEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -instance DecCBOR (Annotator DijkstraTxBodyRaw) where +instance (Typeable l, EraTxBody era) => DecCBOR (Annotator (DijkstraTxBodyRaw l era)) where decCBOR = pure <$> decCBOR -deriving via Mem DijkstraTxBodyRaw instance DecCBOR (Annotator (TxBody DijkstraEra)) +deriving via + Mem (DijkstraTxBodyRaw l DijkstraEra) + instance + Typeable l => DecCBOR (Annotator (TxBody l DijkstraEra)) + +instance HasEraTxLevel DijkstraTxBodyRaw DijkstraEra where + toSTxLevel DijkstraTxBodyRaw {} = STopTx + toSTxLevel DijkstraSubTxBodyRaw {} = SSubTx + +instance HasEraTxLevel TxBody DijkstraEra where + toSTxLevel = toSTxLevel . getMemoRawType + +inputsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (Set TxIn) +inputsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrSpendInputs} -> dtbrSpendInputs + DijkstraSubTxBodyRaw {dstbrSpendInputs} -> dstbrSpendInputs + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrSpendInputs = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrSpendInputs = y} + ) + +outputsDijkstraTxBodyRawL :: + forall era l. + EraTxOut era => + Lens' (DijkstraTxBodyRaw l era) (StrictSeq (TxOut era)) +outputsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrOutputs} -> sizedValue <$> dtbrOutputs + DijkstraSubTxBodyRaw {dstbrOutputs} -> sizedValue <$> dstbrOutputs + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrOutputs = mkSized (eraProtVerLow @era) <$> y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrOutputs = mkSized (eraProtVerLow @era) <$> y} + ) + +feeDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw TopTx era) Coin +feeDijkstraTxBodyRawL = lens dtbrFee (\txb x -> txb {dtbrFee = x}) + +auxDataHashDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (StrictMaybe TxAuxDataHash) +auxDataHashDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrAuxDataHash} -> dtbrAuxDataHash + DijkstraSubTxBodyRaw {dstbrAuxDataHash} -> dstbrAuxDataHash + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrAuxDataHash = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrAuxDataHash = y} + ) + +certsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (OSet (TxCert era)) +certsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrCerts} -> dtbrCerts + DijkstraSubTxBodyRaw {dstbrCerts} -> dstbrCerts + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrCerts = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrCerts = y} + ) + +withdrawalsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) Withdrawals +withdrawalsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrWithdrawals} -> dtbrWithdrawals + DijkstraSubTxBodyRaw {dstbrWithdrawals} -> dstbrWithdrawals + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrWithdrawals = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrWithdrawals = y} + ) instance EraTxBody DijkstraEra where - newtype TxBody DijkstraEra = MkDijkstraTxBody (MemoBytes DijkstraTxBodyRaw) + newtype TxBody l DijkstraEra = MkDijkstraTxBody (MemoBytes (DijkstraTxBodyRaw l DijkstraEra)) deriving (Generic, SafeToHash, ToCBOR) - mkBasicTxBody = mkMemoizedEra @DijkstraEra basicDijkstraTxBodyRaw + mkBasicTxBody = mkMemoizedEra @DijkstraEra $ withSTxBothLevels basicDijkstraTxBodyRaw - inputsTxBodyL = lensMemoRawType @DijkstraEra dtbrSpendInputs $ - \txb x -> txb {dtbrSpendInputs = x} + inputsTxBodyL = memoRawTypeL @DijkstraEra . inputsDijkstraTxBodyRawL {-# INLINE inputsTxBodyL #-} - outputsTxBodyL = - lensMemoRawType @DijkstraEra (fmap sizedValue . dtbrOutputs) $ - \txb x -> txb {dtbrOutputs = mkSized (eraProtVerLow @DijkstraEra) <$> x} + outputsTxBodyL = memoRawTypeL @DijkstraEra . outputsDijkstraTxBodyRawL {-# INLINE outputsTxBodyL #-} - feeTxBodyL = lensMemoRawType @DijkstraEra dtbrFee (\txb x -> txb {dtbrFee = x}) + feeTxBodyL = memoRawTypeL @DijkstraEra . feeDijkstraTxBodyRawL {-# INLINE feeTxBodyL #-} - auxDataHashTxBodyL = lensMemoRawType @DijkstraEra dtbrAuxDataHash $ - \txb x -> txb {dtbrAuxDataHash = x} + auxDataHashTxBodyL = memoRawTypeL @DijkstraEra . auxDataHashDijkstraTxBodyRawL {-# INLINE auxDataHashTxBodyL #-} - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + spendableInputsTxBodyF = to $ \txBody -> + withBothTxLevels txBody (^. babbageSpendableInputsTxBodyF) (^. inputsTxBodyL) {-# INLINE spendableInputsTxBodyF #-} allInputsTxBodyF = babbageAllInputsTxBodyF {-# INLINE allInputsTxBodyF #-} - withdrawalsTxBodyL = lensMemoRawType @DijkstraEra dtbrWithdrawals $ - \txb x -> txb {dtbrWithdrawals = x} + withdrawalsTxBodyL = memoRawTypeL @DijkstraEra . withdrawalsDijkstraTxBodyRawL {-# INLINE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @DijkstraEra (OSet.toStrictSeq . dtbrCerts) $ - \txb x -> txb {dtbrCerts = OSet.fromStrictSeq x} + memoRawTypeL @DijkstraEra + . certsDijkstraTxBodyRawL + . lens OSet.toStrictSeq (\_ x -> OSet.fromStrictSeq x) {-# INLINE certsTxBodyL #-} getTotalDepositsTxBody = dijkstraTotalDepositsTxBody @@ -499,7 +781,7 @@ upgradeProposals ProposalProcedure {..} = } dijkstraTotalDepositsTxBody :: - PParams DijkstraEra -> (KeyHash StakePool -> Bool) -> TxBody DijkstraEra -> Coin + ConwayEraTxBody era => PParams era -> (KeyHash StakePool -> Bool) -> TxBody l era -> Coin dijkstraTotalDepositsTxBody pp isPoolRegisted txBody = getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) <+> conwayProposalsDeposits pp txBody @@ -519,9 +801,9 @@ instance Indexable ScriptHash GuardsScriptHashView where toScriptHash _ = SNothing dijkstraRedeemerPointer :: - forall era. + forall era l. DijkstraEraTxBody era => - TxBody era -> + TxBody l era -> DijkstraPlutusPurpose AsItem era -> StrictMaybe (DijkstraPlutusPurpose AsIx era) dijkstraRedeemerPointer txBody = \case @@ -543,7 +825,7 @@ dijkstraRedeemerPointer txBody = \case dijkstraRedeemerPointerInverse :: DijkstraEraTxBody era => - TxBody era -> + TxBody l era -> DijkstraPlutusPurpose AsIx era -> StrictMaybe (DijkstraPlutusPurpose AsIxItem era) dijkstraRedeemerPointerInverse txBody = \case @@ -562,23 +844,69 @@ dijkstraRedeemerPointerInverse txBody = \case DijkstraGuarding idx -> DijkstraGuarding <$> fromIndex idx (GuardsScriptHashView $ txBody ^. guardsTxBodyL) +vldtDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) ValidityInterval +vldtDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrVldt} -> dtbrVldt + DijkstraSubTxBodyRaw {dstbrVldt} -> dstbrVldt + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrVldt = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrVldt = y} + ) + instance AllegraEraTxBody DijkstraEra where - vldtTxBodyL = lensMemoRawType @DijkstraEra dtbrVldt $ - \txb x -> txb {dtbrVldt = x} + vldtTxBodyL = memoRawTypeL @DijkstraEra . vldtDijkstraTxBodyRawL {-# INLINE vldtTxBodyL #-} +mintDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) MultiAsset +mintDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrMint} -> dtbrMint + DijkstraSubTxBodyRaw {dstbrMint} -> dstbrMint + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrMint = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrMint = y} + ) + instance MaryEraTxBody DijkstraEra where - mintTxBodyL = lensMemoRawType @DijkstraEra dtbrMint $ - \txb x -> txb {dtbrMint = x} + mintTxBodyL = memoRawTypeL @DijkstraEra . mintDijkstraTxBodyRawL {-# INLINE mintTxBodyL #-} - mintedTxBodyF = to $ \txBody -> policies (dtbrMint (getMemoRawType txBody)) - {-# INLINE mintedTxBodyF #-} +collateralInputsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw TopTx era) (Set TxIn) +collateralInputsDijkstraTxBodyRawL = + lens dtbrCollateralInputs $ \txb x -> txb {dtbrCollateralInputs = x} + +scriptIntegrityHashDijkstraTxBodyRawL :: + Lens' (DijkstraTxBodyRaw l era) (StrictMaybe ScriptIntegrityHash) +scriptIntegrityHashDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrScriptIntegrityHash} -> dtbrScriptIntegrityHash + DijkstraSubTxBodyRaw {dstbrScriptIntegrityHash} -> dstbrScriptIntegrityHash + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrScriptIntegrityHash = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrScriptIntegrityHash = y} + ) + +networkIdDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (StrictMaybe Network) +networkIdDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrNetworkId} -> dtbrNetworkId + DijkstraSubTxBodyRaw {dstbrNetworkId} -> dstbrNetworkId + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrNetworkId = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrNetworkId = y} + ) instance AlonzoEraTxBody DijkstraEra where - collateralInputsTxBodyL = - lensMemoRawType @DijkstraEra dtbrCollateralInputs $ - \txb x -> txb {dtbrCollateralInputs = x} + collateralInputsTxBodyL = memoRawTypeL @DijkstraEra . collateralInputsDijkstraTxBodyRawL {-# INLINE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = notSupportedInThisEraL @@ -590,37 +918,61 @@ instance AlonzoEraTxBody DijkstraEra where insertKeyHash (ScriptHashObj _) = id {-# INLINE reqSignerHashesTxBodyG #-} - scriptIntegrityHashTxBodyL = - lensMemoRawType @DijkstraEra dtbrScriptIntegrityHash $ - \txb x -> txb {dtbrScriptIntegrityHash = x} + scriptIntegrityHashTxBodyL = memoRawTypeL @DijkstraEra . scriptIntegrityHashDijkstraTxBodyRawL {-# INLINE scriptIntegrityHashTxBodyL #-} - networkIdTxBodyL = lensMemoRawType @DijkstraEra dtbrNetworkId $ - \txb x -> txb {dtbrNetworkId = x} + networkIdTxBodyL = memoRawTypeL @DijkstraEra . networkIdDijkstraTxBodyRawL {-# INLINE networkIdTxBodyL #-} redeemerPointer = dijkstraRedeemerPointer redeemerPointerInverse = dijkstraRedeemerPointerInverse +collateralReturnDijkstraTxBodyRawL :: + forall era. + EraTxBody era => + Lens' (DijkstraTxBodyRaw TopTx era) (StrictMaybe (TxOut era)) +collateralReturnDijkstraTxBodyRawL = + lens (fmap sizedValue . dtbrCollateralReturn) $ + \txb x -> txb {dtbrCollateralReturn = mkSized (eraProtVerLow @era) <$> x} + +totalCollateralDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw TopTx era) (StrictMaybe Coin) +totalCollateralDijkstraTxBodyRawL = + lens dtbrTotalCollateral $ + \txb x -> txb {dtbrTotalCollateral = x} + +referenceInputsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (Set TxIn) +referenceInputsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrReferenceInputs} -> dtbrReferenceInputs + DijkstraSubTxBodyRaw {dstbrReferenceInputs} -> dstbrReferenceInputs + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrReferenceInputs = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrReferenceInputs = y} + ) + instance BabbageEraTxBody DijkstraEra where - sizedOutputsTxBodyL = lensMemoRawType @DijkstraEra dtbrOutputs $ - \txb x -> txb {dtbrOutputs = x} + sizedOutputsTxBodyL = + lensMemoRawType @DijkstraEra + ( \case + DijkstraTxBodyRaw {dtbrOutputs} -> dtbrOutputs + DijkstraSubTxBodyRaw {dstbrOutputs} -> dstbrOutputs + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrOutputs = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrOutputs = y} + ) {-# INLINE sizedOutputsTxBodyL #-} - referenceInputsTxBodyL = - lensMemoRawType @DijkstraEra dtbrReferenceInputs $ - \txb x -> txb {dtbrReferenceInputs = x} + referenceInputsTxBodyL = memoRawTypeL @DijkstraEra . referenceInputsDijkstraTxBodyRawL {-# INLINE referenceInputsTxBodyL #-} - totalCollateralTxBodyL = - lensMemoRawType @DijkstraEra dtbrTotalCollateral $ - \txb x -> txb {dtbrTotalCollateral = x} + totalCollateralTxBodyL = memoRawTypeL @DijkstraEra . totalCollateralDijkstraTxBodyRawL {-# INLINE totalCollateralTxBodyL #-} - collateralReturnTxBodyL = - lensMemoRawType @DijkstraEra (fmap sizedValue . dtbrCollateralReturn) $ - \txb x -> txb {dtbrCollateralReturn = mkSized (eraProtVerLow @DijkstraEra) <$> x} + collateralReturnTxBodyL = memoRawTypeL @DijkstraEra . collateralReturnDijkstraTxBodyRawL {-# INLINE collateralReturnTxBodyL #-} sizedCollateralReturnTxBodyL = @@ -628,35 +980,87 @@ instance BabbageEraTxBody DijkstraEra where \txb x -> txb {dtbrCollateralReturn = x} {-# INLINE sizedCollateralReturnTxBodyL #-} - allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + allSizedOutputsTxBodyF = to $ \txBody -> + withBothTxLevels txBody (^. allSizedOutputsBabbageTxBodyF) (^. sizedOutputsTxBodyL) {-# INLINE allSizedOutputsTxBodyF #-} +votingProceduresDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (VotingProcedures era) +votingProceduresDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrVotingProcedures} -> dtbrVotingProcedures + DijkstraSubTxBodyRaw {dstbrVotingProcedures} -> dstbrVotingProcedures + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrVotingProcedures = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrVotingProcedures = y} + ) + +proposalProceduresDijkstraTxBodyRawL :: + Lens' (DijkstraTxBodyRaw l era) (OSet (ProposalProcedure era)) +proposalProceduresDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrProposalProcedures} -> dtbrProposalProcedures + DijkstraSubTxBodyRaw {dstbrProposalProcedures} -> dstbrProposalProcedures + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrProposalProcedures = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrProposalProcedures = y} + ) + +treasuryDonationDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) Coin +treasuryDonationDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrTreasuryDonation} -> dtbrTreasuryDonation + DijkstraSubTxBodyRaw {dstbrTreasuryDonation} -> dstbrTreasuryDonation + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrTreasuryDonation = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrTreasuryDonation = y} + ) + +currentTreasuryValueDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (StrictMaybe Coin) +currentTreasuryValueDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrCurrentTreasuryValue} -> dtbrCurrentTreasuryValue + DijkstraSubTxBodyRaw {dstbrCurrentTreasuryValue} -> dstbrCurrentTreasuryValue + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrCurrentTreasuryValue = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrCurrentTreasuryValue = y} + ) + instance ConwayEraTxBody DijkstraEra where - votingProceduresTxBodyL = - lensMemoRawType @DijkstraEra dtbrVotingProcedures $ - \txb x -> txb {dtbrVotingProcedures = x} + votingProceduresTxBodyL = memoRawTypeL @DijkstraEra . votingProceduresDijkstraTxBodyRawL {-# INLINE votingProceduresTxBodyL #-} - proposalProceduresTxBodyL = - lensMemoRawType @DijkstraEra dtbrProposalProcedures $ - \txb x -> txb {dtbrProposalProcedures = x} + proposalProceduresTxBodyL = memoRawTypeL @DijkstraEra . proposalProceduresDijkstraTxBodyRawL {-# INLINE proposalProceduresTxBodyL #-} - currentTreasuryValueTxBodyL = - lensMemoRawType @DijkstraEra dtbrCurrentTreasuryValue $ - \txb x -> txb {dtbrCurrentTreasuryValue = x} + currentTreasuryValueTxBodyL = memoRawTypeL @DijkstraEra . currentTreasuryValueDijkstraTxBodyRawL {-# INLINE currentTreasuryValueTxBodyL #-} - treasuryDonationTxBodyL = - lensMemoRawType @DijkstraEra dtbrTreasuryDonation $ - \txb x -> txb {dtbrTreasuryDonation = x} + treasuryDonationTxBodyL = memoRawTypeL @DijkstraEra . treasuryDonationDijkstraTxBodyRawL {-# INLINE treasuryDonationTxBodyL #-} class ConwayEraTxBody era => DijkstraEraTxBody era where - guardsTxBodyL :: Lens' (TxBody era) (OSet (Credential Guard)) + guardsTxBodyL :: Lens' (TxBody l era) (OSet (Credential Guard)) + +guardsDijkstraTxBodyRawL :: Lens' (DijkstraTxBodyRaw l era) (OSet (Credential Guard)) +guardsDijkstraTxBodyRawL = + lens + ( \case + DijkstraTxBodyRaw {dtbrGuards} -> dtbrGuards + DijkstraSubTxBodyRaw {dstbrGuards} -> dstbrGuards + ) + ( \case + x@DijkstraTxBodyRaw {} -> \y -> x {dtbrGuards = y} + x@DijkstraSubTxBodyRaw {} -> \y -> x {dstbrGuards = y} + ) instance DijkstraEraTxBody DijkstraEra where {-# INLINE guardsTxBodyL #-} - guardsTxBodyL = - lensMemoRawType @DijkstraEra dtbrGuards $ - \txb x -> txb {dtbrGuards = x} + guardsTxBodyL = memoRawTypeL @DijkstraEra . guardsDijkstraTxBodyRawL -- | Decoder for decoding guards in a backwards-compatible manner. It peeks at -- the first element and if it's a credential, it decodes the rest of the diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/UTxO.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/UTxO.hs index 8e1c7eec520..e50696f44f0 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/UTxO.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/UTxO.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Dijkstra.UTxO ( @@ -17,6 +19,7 @@ import Cardano.Ledger.Babbage.UTxO ( getBabbageSpendingDatum, getBabbageSupplementalDataHashes, ) +import Cardano.Ledger.BaseTypes (inject) import Cardano.Ledger.Conway.UTxO ( conwayConsumed, conwayProducedValue, @@ -25,14 +28,14 @@ import Cardano.Ledger.Conway.UTxO ( getConwayWitsVKeyNeeded, ) import Cardano.Ledger.Credential (credScriptHash) -import Cardano.Ledger.Dijkstra.Core (AsIxItem (..), EraTxBody (..)) +import Cardano.Ledger.Dijkstra.Core import Cardano.Ledger.Dijkstra.Era (DijkstraEra) import Cardano.Ledger.Dijkstra.Scripts (DijkstraEraScript (..), pattern GuardingPurpose) -import Cardano.Ledger.Dijkstra.State (EraUTxO (..), UTxO) -import Cardano.Ledger.Dijkstra.State.CertState () +import Cardano.Ledger.Dijkstra.State import Cardano.Ledger.Dijkstra.Tx () import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..)) -import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue) +import Cardano.Ledger.Mary.UTxO (burnedMultiAssets, getConsumedMaryValue) +import Cardano.Ledger.Mary.Value (MaryValue) import Data.Maybe (catMaybes) import Lens.Micro ((^.)) @@ -43,7 +46,11 @@ instance EraUTxO DijkstraEra where getConsumedValue = getConsumedMaryValue - getProducedValue = conwayProducedValue + getProducedValue pp isRegPoolId txBody = + withBothTxLevels + txBody + (conwayProducedValue pp isRegPoolId) + (dijkstraSubTxProducedValue pp isRegPoolId) getScriptsProvided = getBabbageScriptsProvided @@ -56,7 +63,8 @@ instance EraUTxO DijkstraEra where getMinFeeTxUtxo = getConwayMinFeeTxUtxo getDijkstraScriptsNeeded :: - (DijkstraEraTxBody era, DijkstraEraScript era) => UTxO era -> TxBody era -> AlonzoScriptsNeeded era + (DijkstraEraTxBody era, DijkstraEraScript era) => + UTxO era -> TxBody l era -> AlonzoScriptsNeeded era getDijkstraScriptsNeeded utxo txb = getConwayScriptsNeeded utxo txb <> guardingScriptsNeeded @@ -70,3 +78,14 @@ instance AlonzoEraUTxO DijkstraEra where getSupplementalDataHashes = getBabbageSupplementalDataHashes getSpendingDatum = getBabbageSpendingDatum + +dijkstraSubTxProducedValue :: + (ConwayEraTxBody era, Value era ~ MaryValue) => + PParams era -> + (KeyHash StakePool -> Bool) -> + TxBody SubTx era -> + Value era +dijkstraSubTxProducedValue pp isRegPoolId txBody = + sumAllValue (txBody ^. outputsTxBodyL) + <> inject (getTotalDepositsTxBody pp isRegPoolId txBody <> txBody ^. treasuryDonationTxBodyL) + <> burnedMultiAssets txBody diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index f133f86c3dd..4f9f9f74250 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -42,8 +42,8 @@ spec = do xdescribe "fix Multiasset" $ do cddlRoundTripCborSpec @(Value DijkstraEra) v "value" xdescribe "fix TxBody" $ do - cddlRoundTripAnnCborSpec @(TxBody DijkstraEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody DijkstraEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx DijkstraEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx DijkstraEra) v "transaction_body" xdescribe "fix TxAuxData via annotator" $ do cddlRoundTripAnnCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" @@ -64,15 +64,15 @@ spec = do cddlRoundTripAnnCborSpec @(Redeemers DijkstraEra) v "redeemers" cddlRoundTripCborSpec @(Redeemers DijkstraEra) v "redeemers" xdescribe "fix Tx" $ do - cddlRoundTripAnnCborSpec @(Tx DijkstraEra) v "transaction" - cddlRoundTripCborSpec @(Tx DijkstraEra) v "transaction" + cddlRoundTripAnnCborSpec @(Tx TopTx DijkstraEra) v "transaction" + cddlRoundTripCborSpec @(Tx TopTx DijkstraEra) v "transaction" cddlRoundTripCborSpec @(VotingProcedure DijkstraEra) v "voting_procedure" cddlRoundTripCborSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure" cddlRoundTripCborSpec @(GovAction DijkstraEra) v "gov_action" xdescribe "fix TxCert" $ do cddlRoundTripCborSpec @(TxCert DijkstraEra) v "certificate" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody DijkstraEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx DijkstraEra) v "transaction_body" xdescribe "Fix decoder equivalence of TxAuxData" $ do cddlDecoderEquivalenceSpec @(TxAuxData DijkstraEra) v "auxiliary_data" cddlDecoderEquivalenceSpec @(Timelock DijkstraEra) v "native_script" @@ -81,17 +81,18 @@ spec = do cddlDecoderEquivalenceSpec @(TxWits DijkstraEra) v "transaction_witness_set" cddlDecoderEquivalenceSpec @(Redeemers DijkstraEra) v "redeemers" xdescribe "Fix decoder equivalence of Tx" $ do - cddlDecoderEquivalenceSpec @(Tx DijkstraEra) v "transaction" + cddlDecoderEquivalenceSpec @(Tx TopTx DijkstraEra) v "transaction" describe "Huddle" $ specWithHuddle dijkstraCDDL 100 $ do huddleRoundTripCborSpec @(Value DijkstraEra) v "positive_coin" huddleRoundTripArbitraryValidate @(Value DijkstraEra) v "value" xdescribe "fix MultiAsset" $ do huddleRoundTripCborSpec @(Value DijkstraEra) v "value" xdescribe "fix TxBody" $ do - huddleRoundTripAnnCborSpec @(TxBody DijkstraEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody DijkstraEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx DijkstraEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx DijkstraEra) v "transaction_body" -- TODO enable this once map/list expansion has been optimized in cuddle - xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(TxBody DijkstraEra) v "transaction_body" + xdescribe "hangs" $ + huddleRoundTripArbitraryValidate @(TxBody TopTx DijkstraEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" -- TODO fails because of plutus scripts xdescribe "fix plutus scripts" $ do @@ -132,10 +133,10 @@ spec = do xdescribe "fix redeemers" $ huddleRoundTripArbitraryValidate @(Redeemers DijkstraEra) v "redeemers" huddleRoundTripCborSpec @(Redeemers DijkstraEra) v "redeemers" xdescribe "fix Transaction" $ do - huddleRoundTripAnnCborSpec @(Tx DijkstraEra) v "transaction" - huddleRoundTripCborSpec @(Tx DijkstraEra) v "transaction" + huddleRoundTripAnnCborSpec @(Tx TopTx DijkstraEra) v "transaction" + huddleRoundTripCborSpec @(Tx TopTx DijkstraEra) v "transaction" -- TODO enable this once map/list expansion has been optimized in cuddle - xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(Tx DijkstraEra) v "transaction" + xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(Tx TopTx DijkstraEra) v "transaction" huddleRoundTripCborSpec @(VotingProcedure DijkstraEra) v "voting_procedure" huddleRoundTripArbitraryValidate @(VotingProcedure DijkstraEra) v "voting_procedure" huddleRoundTripCborSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure" @@ -151,7 +152,7 @@ spec = do xdescribe "fix unit_interval" $ huddleRoundTripArbitraryValidate @(TxCert DijkstraEra) v "certificate" describe "DecCBOR instances equivalence via CDDL" $ do - huddleDecoderEquivalenceSpec @(TxBody DijkstraEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx DijkstraEra) v "transaction_body" xdescribe "Fix decoder equivalence of TxAuxData" $ do huddleDecoderEquivalenceSpec @(TxAuxData DijkstraEra) v "auxiliary_data" huddleDecoderEquivalenceSpec @(NativeScript DijkstraEra) v "native_script" @@ -160,4 +161,4 @@ spec = do huddleDecoderEquivalenceSpec @(TxWits DijkstraEra) v "transaction_witness_set" huddleDecoderEquivalenceSpec @(Redeemers DijkstraEra) v "redeemers" xdescribe "Fix decoder equivalence of Tx" $ do - huddleDecoderEquivalenceSpec @(Tx DijkstraEra) v "transaction" + huddleDecoderEquivalenceSpec @(Tx TopTx DijkstraEra) v "transaction" 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..0be7178a430 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs @@ -1,10 +1,15 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -21,13 +26,14 @@ import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..)) 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.Tx (DijkstraTx (..), Tx (..)) import Cardano.Ledger.Dijkstra.TxBody (TxBody (..)) import Cardano.Ledger.Dijkstra.TxCert import Cardano.Ledger.Shelley.Scripts ( pattern RequireSignature, ) import Data.Functor.Identity (Identity) +import Data.Typeable (Typeable) import Generic.Random (genericArbitraryU) import Test.Cardano.Ledger.Allegra.Arbitrary (maxTimelockDepth) import Test.Cardano.Ledger.Common @@ -40,7 +46,7 @@ instance Arbitrary (DijkstraPParams Identity DijkstraEra) where instance Arbitrary (DijkstraPParams StrictMaybe DijkstraEra) where arbitrary = genericArbitraryU -instance Arbitrary (TxBody DijkstraEra) where +instance Arbitrary (TxBody TopTx DijkstraEra) where arbitrary = DijkstraTxBody <$> arbitrary @@ -94,7 +100,11 @@ sizedDijkstraNativeScript n = , RequireGuard <$> arbitrary ] -deriving newtype instance Arbitrary (Tx DijkstraEra) +instance (Arbitrary (TxBody l DijkstraEra), Typeable l) => Arbitrary (Tx l DijkstraEra) where + arbitrary = + fmap MkDijkstraTx . withSTxBothLevels @l $ \case + STopTx -> DijkstraTx <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + SSubTx -> DijkstraSubTx <$> arbitrary <*> arbitrary <*> arbitrary instance Era era => Arbitrary (DijkstraTxCert era) where arbitrary = diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs index 3b4330d6163..c4adefce776 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Ledger.Dijkstra.Binary.Annotator ( @@ -15,12 +18,13 @@ import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Core import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.Scripts -import Cardano.Ledger.Dijkstra.Tx (Tx (..)) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (..), Tx (..)) import Cardano.Ledger.Dijkstra.TxBody (TxBody (..)) import Cardano.Ledger.MemoBytes (decodeMemoized) +import Data.Typeable (Typeable) import Test.Cardano.Ledger.Conway.Binary.Annotator () -deriving newtype instance DecCBOR (TxBody DijkstraEra) +deriving newtype instance Typeable l => DecCBOR (TxBody l DijkstraEra) instance Era era => DecCBOR (DijkstraNativeScriptRaw era) where decCBOR = decode $ Summands "DijkstraNativeScriptRaw" $ \case @@ -36,4 +40,22 @@ instance Era era => DecCBOR (DijkstraNativeScriptRaw era) where instance Era era => DecCBOR (DijkstraNativeScript era) where decCBOR = MkDijkstraNativeScript <$> decodeMemoized decCBOR -deriving newtype instance DecCBOR (Tx DijkstraEra) +instance Typeable l => DecCBOR (DijkstraTx l DijkstraEra) where + decCBOR = + withSTxBothLevels @l $ \case + STopTx -> + decode $ + RecD DijkstraTx + + decode $ + RecD DijkstraSubTx + DecCBOR (Tx l DijkstraEra) 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 f3146c25def..2136a140fd3 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs @@ -73,14 +73,14 @@ ledgerExamples = exampleTxDijkstra exampleDijkstraGenesis -exampleTxDijkstra :: Tx DijkstraEra +exampleTxDijkstra :: Tx TopTx DijkstraEra exampleTxDijkstra = exampleTx exampleTxBodyDijkstra (DijkstraSpending $ AsIx 0) (RequireAllOf @DijkstraEra mempty) -exampleTxBodyDijkstra :: TxBody DijkstraEra +exampleTxBodyDijkstra :: TxBody TopTx DijkstraEra exampleTxBodyDijkstra = DijkstraTxBody (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash 1)) 0]) -- spending inputs diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs index 9177ace4048..7216814cd10 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs @@ -135,7 +135,7 @@ impDijkstraSatisfyNativeScript :: , NativeScript era ~ DijkstraNativeScript era ) => Set.Set (KeyHash 'Witness) -> - TxBody era -> + TxBody l era -> NativeScript era -> ImpTestM era (Maybe (Map.Map (KeyHash 'Witness) (KeyPair 'Witness))) impDijkstraSatisfyNativeScript providedVKeyHashes txBody script = do 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..adc4de57cfd 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -17,10 +23,13 @@ import Cardano.Ledger.Dijkstra.Scripts ( DijkstraNativeScriptRaw, DijkstraPlutusPurpose, ) -import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (..), Tx (..)) +import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw (..)) import Cardano.Ledger.Dijkstra.TxCert import Data.Functor.Identity (Identity) -import Test.Cardano.Ledger.Conway.TreeDiff (ToExpr) +import qualified Data.TreeDiff.OMap as OMap +import Test.Cardano.Ledger.Conway.TreeDiff (Expr (..), ToExpr) +import Test.Cardano.Ledger.TreeDiff (ToExpr (..)) instance (forall a b. (ToExpr a, ToExpr b) => ToExpr (f a b)) => @@ -36,11 +45,76 @@ instance ToExpr (DijkstraPParams Identity DijkstraEra) instance ToExpr (DijkstraPParams StrictMaybe DijkstraEra) -instance ToExpr DijkstraTxBodyRaw +instance ToExpr (DijkstraTxBodyRaw l DijkstraEra) where + toExpr = \case + txBody@(DijkstraTxBodyRaw _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> + let DijkstraTxBodyRaw {..} = txBody + in Rec "DijkstraTxBodyRaw" $ + OMap.fromList + [ ("dtbrSpendInputs", toExpr dtbrSpendInputs) + , ("dtbrCollateralInputs", toExpr dtbrCollateralInputs) + , ("dtbrReferenceInputs", toExpr dtbrReferenceInputs) + , ("dtbrOutputs", toExpr dtbrOutputs) + , ("dtbrCollateralReturn", toExpr dtbrCollateralReturn) + , ("dtbrTotalCollateral", toExpr dtbrTotalCollateral) + , ("dtbrCerts", toExpr dtbrCerts) + , ("dtbrWithdrawals", toExpr dtbrWithdrawals) + , ("dtbrFee", toExpr dtbrFee) + , ("dtbrVldt", toExpr dtbrVldt) + , ("dtbrGuards", toExpr dtbrGuards) + , ("dtbrMint", toExpr dtbrMint) + , ("dtbrScriptIntegrityHash", toExpr dtbrScriptIntegrityHash) + , ("dtbrAuxDataHash", toExpr dtbrAuxDataHash) + , ("dtbrNetworkId", toExpr dtbrNetworkId) + , ("dtbrVotingProcedures", toExpr dtbrVotingProcedures) + , ("dtbrProposalProcedures", toExpr dtbrProposalProcedures) + , ("dtbrCurrentTreasuryValue", toExpr dtbrCurrentTreasuryValue) + , ("dtbrTreasuryDonation", toExpr dtbrTreasuryDonation) + ] + txBody@(DijkstraSubTxBodyRaw _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> + let DijkstraSubTxBodyRaw {..} = txBody + in Rec "DijkstraSubTxBodyRaw" $ + OMap.fromList + [ ("dstbrSpendInputs", toExpr dstbrSpendInputs) + , ("dstbrReferenceInputs", toExpr dstbrReferenceInputs) + , ("dstbrOutputs", toExpr dstbrOutputs) + , ("dstbrCerts", toExpr dstbrCerts) + , ("dstbrWithdrawals", toExpr dstbrWithdrawals) + , ("dstbrVldt", toExpr dstbrVldt) + , ("dstbrGuards", toExpr dstbrGuards) + , ("dstbrMint", toExpr dstbrMint) + , ("dstbrScriptIntegrityHash", toExpr dstbrScriptIntegrityHash) + , ("dstbrAuxDataHash", toExpr dstbrAuxDataHash) + , ("dstbrNetworkId", toExpr dstbrNetworkId) + , ("dstbrVotingProcedures", toExpr dstbrVotingProcedures) + , ("dstbrProposalProcedures", toExpr dstbrProposalProcedures) + , ("dstbrCurrentTreasuryValue", toExpr dstbrCurrentTreasuryValue) + , ("dstbrTreasuryDonation", toExpr dstbrTreasuryDonation) + ] -instance ToExpr (TxBody DijkstraEra) +instance ToExpr (TxBody l DijkstraEra) -instance ToExpr (Tx DijkstraEra) +instance ToExpr (DijkstraTx l DijkstraEra) where + toExpr = \case + txBody@(DijkstraTx _ _ _ _) -> + let DijkstraTx {..} = txBody + in Rec "DijkstraTx" $ + OMap.fromList + [ ("dtBody", toExpr dtBody) + , ("dtWits", toExpr dtWits) + , ("dtIsValid", toExpr dtIsValid) + , ("dtAuxData", toExpr dtAuxData) + ] + txBody@(DijkstraSubTx _ _ _) -> + let DijkstraSubTx {..} = txBody + in Rec "DijkstraSubTx" $ + OMap.fromList + [ ("dstBody", toExpr dstBody) + , ("dstWits", toExpr dstWits) + , ("dstAuxData", toExpr dstAuxData) + ] + +deriving newtype instance ToExpr (Tx l DijkstraEra) instance ToExpr DijkstraDelegCert diff --git a/eras/mary/impl/CHANGELOG.md b/eras/mary/impl/CHANGELOG.md index 6883396ba82..e99ffc98d92 100644 --- a/eras/mary/impl/CHANGELOG.md +++ b/eras/mary/impl/CHANGELOG.md @@ -1,8 +1,11 @@ # Version history for `cardano-ledger-mary` -## 1.9.0.1 +## 1.10.0.0 -* +* Add `burnedMultiAssets` +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance ## 1.9.0.0 diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index f0c3f4bf044..3fc0df2a8be 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-mary -version: 1.9.0.1 +version: 1.10.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs index cfd9c5d3e7f..24c8386eef1 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs @@ -60,8 +60,8 @@ instance TranslateEra MaryEra NewEpochState where , stashedAVVMAddresses = () } -instance TranslateEra MaryEra Tx where - type TranslationError MaryEra Tx = DecoderError +instance TranslateEra MaryEra (Tx TopTx) where + type TranslationError MaryEra (Tx TopTx) = DecoderError translateEra _ctx = translateEraThroughCBOR "AllegraTx" -------------------------------------------------------------------------------- diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs index f6e69dcc868..c92aa885f86 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,7 +15,7 @@ module Cardano.Ledger.Mary.Tx ( import Cardano.Ledger.Allegra.Tx (Tx (..), validateTimelock) import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR, ToCBOR) -import Cardano.Ledger.Core (EraTx (..)) +import Cardano.Ledger.Core (EraTx (..), HasEraTxLevel (..), STxTopLevel (..)) import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Mary.PParams () import Cardano.Ledger.Mary.TxAuxData () @@ -31,14 +33,18 @@ import Cardano.Ledger.Shelley.Tx ( witsShelleyTxL, ) import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro (Lens', lens) import NoThunks.Class (NoThunks) -- ======================================== +instance HasEraTxLevel Tx MaryEra where + toSTxLevel (MkMaryTx ShelleyTx {}) = STopTxOnly @MaryEra + instance EraTx MaryEra where - newtype Tx MaryEra = MkMaryTx {unMaryTx :: ShelleyTx MaryEra} + newtype Tx t MaryEra = MkMaryTx {unMaryTx :: ShelleyTx t MaryEra} deriving newtype (Eq, NFData, NoThunks, Show, ToCBOR, EncCBOR) deriving (Generic) @@ -61,11 +67,11 @@ instance EraTx MaryEra where getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx -instance EqRaw (Tx MaryEra) where +instance EqRaw (Tx t MaryEra) where eqRaw = shelleyTxEqRaw -maryTxL :: Lens' (Tx MaryEra) (ShelleyTx MaryEra) +maryTxL :: Lens' (Tx t MaryEra) (ShelleyTx t MaryEra) maryTxL = lens unMaryTx (\x y -> x {unMaryTx = y}) -instance DecCBOR (Annotator (Tx MaryEra)) where +instance Typeable t => DecCBOR (Annotator (Tx t MaryEra)) where decCBOR = fmap MkMaryTx <$> decCBOR diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs index f1a20014435..7bc2e205320 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -61,51 +62,41 @@ import Cardano.Ledger.TxIn (TxIn (..)) import Control.DeepSeq (NFData (..)) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Lens.Micro import NoThunks.Class (NoThunks (..)) class AllegraEraTxBody era => MaryEraTxBody era where - mintTxBodyL :: Lens' (TxBody era) MultiAsset + mintTxBodyL :: Lens' (TxBody l era) MultiAsset - mintedTxBodyF :: SimpleGetter (TxBody era) (Set PolicyID) + -- TODO: extract away from this type class into a standalone getter + mintedTxBodyF :: SimpleGetter (TxBody l era) (Set PolicyID) + mintedTxBodyF = mintTxBodyL . to policies + {-# INLINE mintedTxBodyF #-} - mintValueTxBodyF :: SimpleGetter (TxBody era) (Value era) - default mintValueTxBodyF :: Value era ~ MaryValue => SimpleGetter (TxBody era) (Value era) + mintValueTxBodyF :: SimpleGetter (TxBody l era) (Value era) + default mintValueTxBodyF :: Value era ~ MaryValue => SimpleGetter (TxBody l era) (Value era) mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) {-# INLINE mintValueTxBodyF #-} -- =========================================================================== -- Wrap it all up in a newtype, hiding the insides with a pattern constructor. -type MaryTxBodyRaw = AllegraTxBodyRaw MultiAsset MaryEra +type MaryTxBodyRaw l = AllegraTxBodyRaw MultiAsset l MaryEra --- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody MaryEra) +instance EqRaw (TxBody l MaryEra) -instance EqRaw (TxBody MaryEra) - -instance Memoized (TxBody MaryEra) where - type RawType (TxBody MaryEra) = MaryTxBodyRaw - -deriving newtype instance Eq (TxBody MaryEra) - -deriving newtype instance Show (TxBody MaryEra) - -deriving instance Generic (TxBody MaryEra) - -deriving newtype instance NoThunks (TxBody MaryEra) - -deriving newtype instance NFData (TxBody MaryEra) +deriving instance Generic (TxBody l MaryEra) deriving via - Mem MaryTxBodyRaw + Mem (MaryTxBodyRaw l) instance - DecCBOR (Annotator (TxBody MaryEra)) + Typeable l => DecCBOR (Annotator (TxBody l MaryEra)) -type instance MemoHashIndex MaryTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (MaryTxBodyRaw l) = EraIndependentTxBody -instance HashAnnotated (TxBody MaryEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l MaryEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -- | A pattern to keep the newtype and the MemoBytes hidden @@ -120,7 +111,7 @@ pattern MaryTxBody :: StrictMaybe (Update MaryEra) -> StrictMaybe TxAuxDataHash -> MultiAsset -> - TxBody MaryEra + TxBody TopTx MaryEra pattern MaryTxBody { mtbInputs , mtbOutputs @@ -171,18 +162,35 @@ pattern MaryTxBody {-# COMPLETE MaryTxBody #-} +instance EraTxLevel MaryEra where type STxLevel l MaryEra = STxTopLevel l MaryEra + +instance HasEraTxLevel (AllegraTxBodyRaw ma) MaryEra where + toSTxLevel AllegraTxBodyRaw {} = STopTxOnly + +instance HasEraTxLevel TxBody MaryEra where + toSTxLevel = toSTxLevel . getMemoRawType + +instance Memoized (TxBody l MaryEra) where + type RawType (TxBody l MaryEra) = AllegraTxBodyRaw MultiAsset l MaryEra + +emptyMaryTxBodyRaw :: MaryTxBodyRaw TopTx +emptyMaryTxBodyRaw = emptyAllegraTxBodyRaw + +basicMaryTxBody :: Typeable l => TxBody l MaryEra +basicMaryTxBody = mkMemoizedEra @MaryEra $ asSTxTopLevel emptyMaryTxBodyRaw + instance EraTxBody MaryEra where - newtype TxBody MaryEra = MkMaryTxBody (MemoBytes MaryTxBodyRaw) - deriving newtype (SafeToHash, ToCBOR) + newtype TxBody l MaryEra = MkMaryTxBody (MemoBytes (MaryTxBodyRaw l)) + deriving newtype (SafeToHash, ToCBOR, EncCBOR, Eq, Show, NoThunks, NFData) - mkBasicTxBody = mkMemoizedEra @MaryEra emptyAllegraTxBodyRaw + mkBasicTxBody = basicMaryTxBody inputsTxBodyL = - lensMemoRawType @MaryEra atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrInputs} -> atbrInputs) $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @MaryEra atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrOutputs} -> atbrOutputs) $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = @@ -190,7 +198,7 @@ instance EraTxBody MaryEra where {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType @MaryEra atbrAuxDataHash $ + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrAuxDataHash} -> atbrAuxDataHash) $ \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} @@ -201,11 +209,11 @@ instance EraTxBody MaryEra where {-# INLINEABLE allInputsTxBodyF #-} withdrawalsTxBodyL = - lensMemoRawType @MaryEra atbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrWithdrawals} -> atbrWithdrawals) $ \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @MaryEra atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrCerts} -> atbrCerts) $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -220,14 +228,13 @@ instance ShelleyEraTxBody MaryEra where instance AllegraEraTxBody MaryEra where vldtTxBodyL = - lensMemoRawType @MaryEra atbrValidityInterval $ + lensMemoRawType @MaryEra (\AllegraTxBodyRaw {atbrValidityInterval} -> atbrValidityInterval) $ \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} {-# INLINEABLE vldtTxBodyL #-} instance MaryEraTxBody MaryEra where mintTxBodyL = - lensMemoRawType @MaryEra atbrMint (\txBodyRaw mint -> txBodyRaw {atbrMint = mint}) + lensMemoRawType @MaryEra + (\AllegraTxBodyRaw {atbrMint} -> atbrMint) + (\txBodyRaw mint -> txBodyRaw {atbrMint = mint}) {-# INLINEABLE mintTxBodyL #-} - - mintedTxBodyF = to $ \txBody -> policies (atbrMint (getMemoRawType txBody)) - {-# INLINEABLE mintedTxBodyF #-} diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/UTxO.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/UTxO.hs index 5673612a09f..9b88dede9b1 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/UTxO.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/UTxO.hs @@ -8,6 +8,7 @@ module Cardano.Ledger.Mary.UTxO ( getConsumedMaryValue, getProducedMaryValue, + burnedMultiAssets, ) where import Cardano.Ledger.Coin (Coin) @@ -43,7 +44,8 @@ instance EraUTxO MaryEra where getConsumedValue = getConsumedMaryValue - getProducedValue = getProducedMaryValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (getProducedMaryValue pp isRegPoolId) getScriptsProvided _ tx = ScriptsProvided (tx ^. witsTxL . scriptTxWitsL) @@ -70,7 +72,7 @@ getConsumedMaryValue :: (Credential 'Staking -> Maybe Coin) -> (Credential 'DRepRole -> Maybe Coin) -> UTxO era -> - TxBody era -> + TxBody l era -> MaryValue getConsumedMaryValue pp lookupStakingDeposit lookupDRepDeposit utxo txBody = consumedValue <> MaryValue mempty mintedMultiAsset @@ -88,14 +90,16 @@ getProducedMaryValue :: PParams era -> -- | Check whether a pool with a supplied PoolStakeId is already registered. (KeyHash 'StakePool -> Bool) -> - TxBody era -> + TxBody TopTx era -> MaryValue getProducedMaryValue pp isPoolRegistered txBody = - shelleyProducedValue pp isPoolRegistered txBody <> MaryValue mempty burnedMultiAsset - where - burnedMultiAsset = - mapMaybeMultiAsset (\_ _ v -> if v < 0 then Just (negate v) else Nothing) $ - txBody ^. mintTxBodyL + shelleyProducedValue pp isPoolRegistered txBody <> burnedMultiAssets txBody + +burnedMultiAssets :: MaryEraTxBody era => TxBody l era -> MaryValue +burnedMultiAssets txBody = + MaryValue mempty $ + mapMaybeMultiAsset (\_ _ v -> if v < 0 then Just (negate v) else Nothing) $ + txBody ^. mintTxBodyL -- | Computes the set of script hashes required to unlock the transaction inputs and the -- withdrawals. Unlike the one from Shelley, this one also includes script hashes needed @@ -103,7 +107,7 @@ getProducedMaryValue pp isPoolRegistered txBody = getMaryScriptsNeeded :: (ShelleyEraTxBody era, MaryEraTxBody era) => UTxO era -> - TxBody era -> + TxBody l era -> ShelleyScriptsNeeded era getMaryScriptsNeeded u txBody = case getShelleyScriptsNeeded u txBody of diff --git a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs index 85c3e2d674e..c2c2409913b 100644 --- a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs +++ b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs @@ -23,25 +23,25 @@ spec = let v = eraProtVerLow @MaryEra describe "Ruby-based" $ beforeAllCddlFile 3 readMaryCddlFiles $ do cddlRoundTripCborSpec @(Value MaryEra) v "value" - cddlRoundTripAnnCborSpec @(TxBody MaryEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody MaryEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx MaryEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx MaryEra) v "transaction_body" cddlRoundTripAnnCborSpec @(Script MaryEra) v "native_script" cddlRoundTripCborSpec @(Script MaryEra) v "native_script" cddlRoundTripAnnCborSpec @(TxAuxData MaryEra) v "auxiliary_data" cddlRoundTripCborSpec @(TxAuxData MaryEra) v "auxiliary_data" describe "DecCBOR instances equivalence via CDDL" $ do - cddlDecoderEquivalenceSpec @(TxBody MaryEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx MaryEra) v "transaction_body" cddlDecoderEquivalenceSpec @(Script MaryEra) v "native_script" cddlDecoderEquivalenceSpec @(TxAuxData MaryEra) v "auxiliary_data" describe "Huddle" $ specWithHuddle maryCDDL 100 $ do huddleRoundTripCborSpec @(Value MaryEra) v "value" - huddleRoundTripAnnCborSpec @(TxBody MaryEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody MaryEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx MaryEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx MaryEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData MaryEra) v "auxiliary_data" huddleRoundTripCborSpec @(TxAuxData MaryEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Script MaryEra) v "native_script" huddleRoundTripCborSpec @(Script MaryEra) v "native_script" describe "DecCBOR instances equivalence via CDDL" $ do - huddleDecoderEquivalenceSpec @(TxBody MaryEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx MaryEra) v "transaction_body" huddleDecoderEquivalenceSpec @(Script MaryEra) v "native_script" huddleDecoderEquivalenceSpec @(TxAuxData MaryEra) v "auxiliary_data" diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs index dc270526818..127d0f14a01 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs @@ -53,7 +53,7 @@ instance Arbitrary AssetName where , (7, genShortByteString =<< choose (1, 32)) ] -instance Arbitrary (TxBody MaryEra) where +instance Arbitrary (TxBody TopTx MaryEra) where arbitrary = MaryTxBody <$> arbitrary @@ -244,4 +244,4 @@ hashOfDigitByteStrings = castHash . hashWith id <$> digitByteStrings deriving newtype instance Arbitrary (TransitionConfig MaryEra) -deriving newtype instance Arbitrary (Tx MaryEra) +deriving newtype instance Arbitrary (Tx TopTx MaryEra) diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Binary/Annotator.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Binary/Annotator.hs index b5bb186423c..c9bb7a052bc 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Binary/Annotator.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Binary/Annotator.hs @@ -9,10 +9,11 @@ module Test.Cardano.Ledger.Mary.Binary.Annotator ( ) where import Cardano.Ledger.Binary +import Cardano.Ledger.Core (TxLevel (..)) import Cardano.Ledger.Mary (MaryEra, Tx (..)) import Cardano.Ledger.Mary.TxBody import Test.Cardano.Ledger.Allegra.Binary.Annotator -deriving newtype instance DecCBOR (TxBody MaryEra) +deriving newtype instance DecCBOR (TxBody TopTx MaryEra) -deriving newtype instance DecCBOR (Tx MaryEra) +deriving newtype instance DecCBOR (Tx TopTx MaryEra) diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs index 02109737c3d..2736a126299 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs @@ -22,7 +22,7 @@ import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Mary.ImpTest mintBasicToken :: - (HasCallStack, MaryEraImp era) => ImpTestM era (Tx era) + (HasCallStack, MaryEraImp era) => ImpTestM era (Tx TopTx era) mintBasicToken = do addr <- freshKeyAddr_ keyHash <- freshKeyHash diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs index 49a9150a0c2..873ce9f8312 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs @@ -15,6 +15,7 @@ module Test.Cardano.Ledger.Mary.ImpTest ( import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Mary.Core import Cardano.Ledger.Mary.Value +import Data.Typeable (Typeable) import Lens.Micro ((&), (.~)) import Test.Cardano.Ledger.Allegra.ImpTest import Test.Cardano.Ledger.Imp.Common @@ -40,7 +41,7 @@ class instance MaryEraImp MaryEra -mkTokenMintingTx :: MaryEraImp era => ScriptHash -> ImpTestM era (Tx era) +mkTokenMintingTx :: (MaryEraImp era, Typeable l) => ScriptHash -> ImpTestM era (Tx l era) mkTokenMintingTx sh = do name <- arbitrary count <- choose (1, 10) diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/TreeDiff.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/TreeDiff.hs index 5be5a2362fd..49926d586c0 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/TreeDiff.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/TreeDiff.hs @@ -30,6 +30,6 @@ instance ToExpr AssetName where deriving newtype instance ToExpr (CompactForm MaryValue) -instance ToExpr (TxBody MaryEra) +instance ToExpr (TxBody TopTx MaryEra) -instance ToExpr (Tx MaryEra) +instance ToExpr (Tx TopTx MaryEra) diff --git a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal index d4be9942eb7..5f9b6ce42e7 100644 --- a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal +++ b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal @@ -47,7 +47,7 @@ library cardano-ledger-allegra:{cardano-ledger-allegra, testlib} ^>=1.9, cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.7, cardano-ledger-core:{cardano-ledger-core, tasty-compat} ^>=1.19, - cardano-ledger-mary:{cardano-ledger-mary, testlib} ^>=1.9, + cardano-ledger-mary:{cardano-ledger-mary, testlib} ^>=1.10, cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.12, cardano-ledger-shelley-test >=1.6, cardano-slotting, diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/AllegraEraGen.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/AllegraEraGen.hs index cf01156a5da..6d75a1b7661 100644 --- a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/AllegraEraGen.hs +++ b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/AllegraEraGen.hs @@ -105,7 +105,7 @@ genTxBody :: Coin -> StrictMaybe (Update AllegraEra) -> StrictMaybe TxAuxDataHash -> - Gen (TxBody AllegraEra, [Timelock AllegraEra]) + Gen (TxBody TopTx AllegraEra, [Timelock AllegraEra]) genTxBody slot ins outs cert wdrl fee upd ad = do validityInterval <- genValidityInterval slot pure diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/MaryEraGen.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/MaryEraGen.hs index 59714f8ad5f..5114f63a9d7 100644 --- a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/MaryEraGen.hs +++ b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/MaryEraGen.hs @@ -284,7 +284,7 @@ genTxBody :: Coin -> StrictMaybe (Update MaryEra) -> StrictMaybe TxAuxDataHash -> - Gen (TxBody MaryEra, [NativeScript MaryEra]) + Gen (TxBody TopTx MaryEra, [NativeScript MaryEra]) genTxBody pparams slot ins outs cert wdrl fee upd meta = do validityInterval <- genValidityInterval slot mint <- genMint diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs index 1b72b1be20c..70dae43a51e 100644 --- a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs @@ -38,7 +38,7 @@ import Test.Tasty.HUnit -- ==================================================================================================== -- Make a TxBody to test with -txM :: TxBody MaryEra +txM :: TxBody TopTx MaryEra txM = mkBasicTxBody & feeTxBodyL .~ Coin 6 diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/ScriptTranslation.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/ScriptTranslation.hs index bb2799c97dd..28a2ad86737 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/ScriptTranslation.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/ScriptTranslation.hs @@ -31,7 +31,7 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) bootstrapTxId :: S.TxId -bootstrapTxId = txIdTxBody @ShelleyEra mkBasicTxBody +bootstrapTxId = txIdTxBody $ mkBasicTxBody @ShelleyEra @TopTx fromRight :: HasCallStack => Either e a -> a fromRight (Right x) = x diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs index d2bdd145430..202abbde2d1 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs @@ -49,7 +49,7 @@ allegraTranslationTests = testGroup "Allegra translation binary compatibiliby tests" [ testProperty "Tx compatibility" $ - translateEraEncoding @AllegraEra @Tx NoGenesis toCBOR toCBOR + translateEraEncoding @AllegraEra @(Tx TopTx) NoGenesis toCBOR toCBOR , testProperty "ProposedPPUpdates compatibility" (testTranslation @S.ProposedPPUpdates) , testProperty "ShelleyGovState compatibility" $ translateEraEncoding @AllegraEra @S.ShelleyGovState NoGenesis toCBOR toCBOR diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs index b74f1f7206f..2ac956bb784 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs @@ -29,7 +29,7 @@ ignoreAllButUTxO = fmap (\(LedgerState (UTxOState utxo _ _ _ _ _) _) -> utxo) testMaryNoDelegLEDGER :: HasCallStack => UTxO MaryEra -> - Tx MaryEra -> + Tx TopTx MaryEra -> LedgerEnv MaryEra -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))) (UTxO MaryEra) -> Assertion diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs index 8bc964ec04d..d5aea9118a9 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs @@ -73,7 +73,7 @@ unboundedInterval = ValidityInterval SNothing SNothing bootstrapTxId :: TxId bootstrapTxId = txIdTxBody txb where - txb :: TxBody MaryEra + txb :: TxBody TopTx MaryEra txb = mkBasicTxBody initUTxO :: UTxO MaryEra @@ -105,7 +105,7 @@ makeMaryTxBody :: [ShelleyTxOut MaryEra] -> ValidityInterval -> MultiAsset -> - TxBody MaryEra + TxBody TopTx MaryEra makeMaryTxBody ins outs interval minted = mkBasicTxBody & inputsTxBodyL .~ Set.fromList ins @@ -161,7 +161,7 @@ tokensSimpleEx1 = MaryValue mempty mintSimpleEx1 <+> Val.inject aliceCoinSimpleE -- Mint a purple token bundle, consisting of thirteen plums and two amethysts. -- Give the bundle to Alice. -txbodySimpleEx1 :: TxBody MaryEra +txbodySimpleEx1 :: TxBody TopTx MaryEra txbodySimpleEx1 = makeMaryTxBody [mkTxInPartial bootstrapTxId 0] @@ -169,7 +169,7 @@ txbodySimpleEx1 = unboundedInterval mintSimpleEx1 -txSimpleEx1 :: Tx MaryEra +txSimpleEx1 :: Tx TopTx MaryEra txSimpleEx1 = mkBasicTx txbodySimpleEx1 & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) @@ -208,7 +208,7 @@ bobTokensSimpleEx2 = Map.singleton purplePolicyId (Map.singleton plum 5) -- Alice gives five plums to Bob. -txbodySimpleEx2 :: TxBody MaryEra +txbodySimpleEx2 :: TxBody TopTx MaryEra txbodySimpleEx2 = makeMaryTxBody [mkTxInPartial (txIdTxBody txbodySimpleEx1) 0] @@ -218,7 +218,7 @@ txbodySimpleEx2 = unboundedInterval mempty -txSimpleEx2 :: Tx MaryEra +txSimpleEx2 :: Tx TopTx MaryEra txSimpleEx2 = mkBasicTx txbodySimpleEx2 & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw) @@ -284,7 +284,7 @@ tokensTimeEx1 :: MaryValue tokensTimeEx1 = MaryValue mempty mintTimeEx1 <+> Val.inject aliceCoinsTimeEx1 -- Mint tokens -txbodyTimeEx1 :: StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra +txbodyTimeEx1 :: StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody TopTx MaryEra txbodyTimeEx1 s e = makeMaryTxBody [mkTxInPartial bootstrapTxId 0] @@ -292,10 +292,10 @@ txbodyTimeEx1 s e = (ValidityInterval s e) mintTimeEx1 -txbodyTimeEx1Valid :: TxBody MaryEra +txbodyTimeEx1Valid :: TxBody TopTx MaryEra txbodyTimeEx1Valid = txbodyTimeEx1 (SJust startInterval) (SJust stopInterval) -txTimeEx1 :: TxBody MaryEra -> Tx MaryEra +txTimeEx1 :: TxBody TopTx MaryEra -> Tx TopTx MaryEra txTimeEx1 txbody = mkBasicTx txbody & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) @@ -303,19 +303,19 @@ txTimeEx1 txbody = atw = mkWitnessesVKey (hashAnnotated txbody) [asWitness Cast.alicePay] stw = Map.fromList [(policyID boundedTimePolicyId, boundedTimePolicy)] -txTimeEx1Valid :: Tx MaryEra +txTimeEx1Valid :: Tx TopTx MaryEra txTimeEx1Valid = txTimeEx1 txbodyTimeEx1Valid -txTimeEx1InvalidLHSfixed :: Tx MaryEra +txTimeEx1InvalidLHSfixed :: Tx TopTx MaryEra txTimeEx1InvalidLHSfixed = txTimeEx1 $ txbodyTimeEx1 (SJust beforeStart) (SJust stopInterval) -txTimeEx1InvalidLHSopen :: Tx MaryEra +txTimeEx1InvalidLHSopen :: Tx TopTx MaryEra txTimeEx1InvalidLHSopen = txTimeEx1 $ txbodyTimeEx1 SNothing (SJust stopInterval) -txTimeEx1InvalidRHSfixed :: Tx MaryEra +txTimeEx1InvalidRHSfixed :: Tx TopTx MaryEra txTimeEx1InvalidRHSfixed = txTimeEx1 $ txbodyTimeEx1 (SJust startInterval) (SJust afterStop) -txTimeEx1InvalidRHSopen :: Tx MaryEra +txTimeEx1InvalidRHSopen :: Tx TopTx MaryEra txTimeEx1InvalidRHSopen = txTimeEx1 $ txbodyTimeEx1 (SJust startInterval) SNothing expectedUTxOTimeEx1 :: UTxO MaryEra @@ -343,7 +343,7 @@ aliceCoinsTimeEx2 :: Coin aliceCoinsTimeEx2 = aliceCoinSimpleEx1 <-> (feeEx <+> mintTimeEx2) -- Alice gives one token to Bob -txbodyTimeEx2 :: TxBody MaryEra +txbodyTimeEx2 :: TxBody TopTx MaryEra txbodyTimeEx2 = makeMaryTxBody [mkTxInPartial (txIdTxBody txbodyTimeEx1Valid) 0] @@ -353,7 +353,7 @@ txbodyTimeEx2 = unboundedInterval mempty -txTimeEx2 :: Tx MaryEra +txTimeEx2 :: Tx TopTx MaryEra txTimeEx2 = MkMaryTx $ ShelleyTx @@ -408,7 +408,7 @@ tokensSingWitEx1 :: MaryValue tokensSingWitEx1 = MaryValue mempty mintSingWitEx1 <+> Val.inject bobCoinsSingWitEx1 -- Bob pays the fees, but only alice can witness the minting -txbodySingWitEx1 :: TxBody MaryEra +txbodySingWitEx1 :: TxBody TopTx MaryEra txbodySingWitEx1 = makeMaryTxBody [mkTxInPartial bootstrapTxId 1] @@ -416,7 +416,7 @@ txbodySingWitEx1 = unboundedInterval mintSingWitEx1 -txSingWitEx1Valid :: Tx MaryEra +txSingWitEx1Valid :: Tx TopTx MaryEra txSingWitEx1Valid = mkBasicTx txbodySingWitEx1 & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) @@ -432,7 +432,7 @@ expectedUTxOSingWitEx1 = , (mkTxInPartial bootstrapTxId 0, ShelleyTxOut Cast.aliceAddr (Val.inject aliceInitCoin)) ] -txSingWitEx1Invalid :: Tx MaryEra +txSingWitEx1Invalid :: Tx TopTx MaryEra txSingWitEx1Invalid = mkBasicTx txbodySingWitEx1 & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) @@ -462,7 +462,7 @@ aliceTokensNegEx1 = MultiAsset $ Map.singleton purplePolicyId (Map.singleton amethyst 2) -txbodyNegEx1 :: TxBody MaryEra +txbodyNegEx1 :: TxBody TopTx MaryEra txbodyNegEx1 = makeMaryTxBody [mkTxInPartial (txIdTxBody txbodySimpleEx2) 0] @@ -470,7 +470,7 @@ txbodyNegEx1 = unboundedInterval mintNegEx1 -txNegEx1 :: Tx MaryEra +txNegEx1 :: Tx TopTx MaryEra txNegEx1 = mkBasicTx txbodyNegEx1 & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) @@ -506,7 +506,7 @@ aliceTokensNegEx2 = Map.singleton purplePolicyId (Map.fromList [(plum, -1), (amethyst, 2)]) -- Mint negative valued tokens -txbodyNegEx2 :: TxBody MaryEra +txbodyNegEx2 :: TxBody TopTx MaryEra txbodyNegEx2 = makeMaryTxBody [mkTxInPartial (txIdTxBody txbodySimpleEx2) 0] @@ -552,7 +552,7 @@ bigValue = bigOut :: ShelleyTxOut MaryEra bigOut = ShelleyTxOut Cast.aliceAddr $ MaryValue mempty bigValue <+> Val.inject minUtxoBigEx -txbodyWithBigValue :: TxBody MaryEra +txbodyWithBigValue :: TxBody TopTx MaryEra txbodyWithBigValue = makeMaryTxBody [mkTxInPartial bootstrapTxId 0] @@ -560,7 +560,7 @@ txbodyWithBigValue = unboundedInterval (bigValue <> smallValue) -txBigValue :: Tx MaryEra +txBigValue :: Tx TopTx MaryEra txBigValue = mkBasicTx txbodyWithBigValue & witsTxL .~ (mkBasicTxWits & addrTxWitsL .~ atw & scriptTxWitsL .~ stw) diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs index 39061c27b33..337d139b57b 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs @@ -53,7 +53,7 @@ maryTranslationTests = testGroup "Mary translation binary compatibiliby tests" [ testProperty "Tx compatibility" $ - translateEraEncoding @MaryEra @Tx NoGenesis toCBOR toCBOR + translateEraEncoding @MaryEra @(Tx TopTx) NoGenesis toCBOR toCBOR , testProperty "ProposedPPUpdates compatibility" (test @S.ProposedPPUpdates) , testProperty "ShelleyGovState compatibility" $ translateEraEncoding @MaryEra @S.ShelleyGovState NoGenesis toCBOR toCBOR diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 3e7d99ed2af..cb7f3d4a150 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.18.0.0 +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `HasEraTxLevel` instances for `Tx` and `TxBody` +* Add `EraTxLevel` instance * Add `EncCBOR` and `DecCBOR` instances to `ShelleyBbodyPredFailure` * Rename `poolParamsP` field to `stakePoolParamsP` in `RewardProvenancePool` * Move withdrawals-draining from `DELEGS` to `LEDGER` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs index cc5b5b4b848..f542661fd07 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs @@ -111,8 +111,8 @@ class Globals -> MempoolEnv era -> MempoolState era -> - Tx era -> - Either (ApplyTxError era) (MempoolState era, Validated (Tx era)) + Tx TopTx era -> + Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era)) ruleApplyTxValidation :: forall rule era. @@ -120,15 +120,15 @@ ruleApplyTxValidation :: , BaseM (EraRule rule era) ~ ShelleyBase , Environment (EraRule rule era) ~ LedgerEnv era , State (EraRule rule era) ~ MempoolState era - , Signal (EraRule rule era) ~ Tx era + , Signal (EraRule rule era) ~ Tx TopTx era , PredicateFailure (EraRule rule era) ~ PredicateFailure (EraRule "LEDGER" era) ) => ValidationPolicy -> Globals -> MempoolEnv era -> MempoolState era -> - Tx era -> - Either (ApplyTxError era) (MempoolState era, Validated (Tx era)) + Tx TopTx era -> + Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era)) ruleApplyTxValidation validationPolicy globals env state tx = let opts = ApplySTSOpts @@ -254,8 +254,8 @@ applyTx :: Globals -> MempoolEnv era -> MempoolState era -> - Tx era -> - Either (ApplyTxError era) (MempoolState era, Validated (Tx era)) + Tx TopTx era -> + Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era)) applyTx = applyTxValidation ValidateAll -- | Reapply a previously validated 'Tx'. @@ -269,7 +269,7 @@ reapplyTx :: Globals -> MempoolEnv era -> MempoolState era -> - Validated (Tx era) -> + Validated (Tx TopTx era) -> Either (ApplyTxError era) (MempoolState era) reapplyTx globals env state (Validated tx) = fst <$> applyTxValidation (ValidateSuchThat (notElem lblStatic)) globals env state tx diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs index 0a7d9520ebe..8327513f99e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs @@ -431,7 +431,7 @@ getRewardProvenance globals newEpochState = -- Transaction helpers -------------------------------------------------------------------------------- -addKeyWitnesses :: EraTx era => Tx era -> Set (WitVKey 'Witness) -> Tx era +addKeyWitnesses :: EraTx era => Tx t era -> Set (WitVKey 'Witness) -> Tx t era addKeyWitnesses tx newWits = tx & witsTxL . addrTxWitsL %~ Set.union newWits -------------------------------------------------------------------------------- diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs index 52decb53dcf..b5f7107289e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs @@ -135,7 +135,7 @@ instance Show Produced where -- | Compute the Coin part of what is consumed by a TxBody, itemized as a 'Consume' consumedTxBody :: (EraTxBody era, EraCertState era) => - TxBody era -> + TxBody l era -> PParams era -> CertState era -> UTxO era -> @@ -151,7 +151,7 @@ consumedTxBody txBody pp dpstate utxo = -- | Compute the Coin part of what is produced by a TxBody, itemized as a 'Produced' producedTxBody :: (EraTxBody era, EraCertState era) => - TxBody era -> + TxBody TopTx era -> PParams era -> CertState era -> Produced diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody.hs index 29cd91fff54..3969eca1784 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody.hs @@ -13,12 +13,12 @@ module Cardano.Ledger.Shelley.BlockBody ( ) where import Cardano.Crypto.Hash (Hash) -import Cardano.Ledger.Core (EraIndependentBlockBody, HASH, Tx) +import Cardano.Ledger.Core (EraIndependentBlockBody, HASH, TopTx, Tx) import Cardano.Ledger.Shelley.BlockBody.Internal import Data.Sequence.Strict (StrictSeq) shelleyBlockBodyHash :: ShelleyBlockBody era -> Hash HASH EraIndependentBlockBody shelleyBlockBodyHash = sbbHash -shelleyBlockBodyTxs :: ShelleyBlockBody era -> StrictSeq (Tx era) +shelleyBlockBodyTxs :: ShelleyBlockBody era -> StrictSeq (Tx TopTx era) shelleyBlockBodyTxs = sbbTxs diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs index 4f36a4c5486..56e055593de 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs @@ -82,7 +82,7 @@ import Lens.Micro hiding (ix) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) data ShelleyBlockBody era = ShelleyBlockBodyInternal - { sbbTxs :: !(StrictSeq (Tx era)) + { sbbTxs :: !(StrictSeq (Tx TopTx era)) , sbbHash :: Hash.Hash HASH EraIndependentBlockBody -- ^ Memoized hash to avoid recomputation. Lazy on purpose. , sbbTxsBodyBytes :: BSL.ByteString @@ -116,7 +116,7 @@ txSeqBlockBodyShelleyL :: , SafeToHash (TxWits era) , BlockBody era ~ ShelleyBlockBody era ) => - Lens' (BlockBody era) (StrictSeq (Tx era)) + Lens' (BlockBody era) (StrictSeq (Tx TopTx era)) txSeqBlockBodyShelleyL = lens sbbTxs (\_ s -> ShelleyBlockBody s) {-# INLINEABLE txSeqBlockBodyShelleyL #-} @@ -129,14 +129,14 @@ deriving via ] (ShelleyBlockBody era) instance - (Typeable era, NoThunks (Tx era)) => NoThunks (ShelleyBlockBody era) + (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (ShelleyBlockBody era) deriving stock instance - Show (Tx era) => + Show (Tx TopTx era) => Show (ShelleyBlockBody era) deriving stock instance - Eq (Tx era) => + Eq (Tx TopTx era) => Eq (ShelleyBlockBody era) -- =========================== @@ -144,14 +144,14 @@ deriving stock instance coreWitnessBytes :: (EraTx era, SafeToHash (TxWits era)) => - Tx era -> + Tx TopTx era -> ByteString coreWitnessBytes tx = originalBytes $ tx ^. witsTxL -coreBodyBytes :: EraTx era => Tx era -> ByteString +coreBodyBytes :: EraTx era => Tx TopTx era -> ByteString coreBodyBytes tx = originalBytes $ tx ^. bodyTxL -coreAuxDataBytes :: EraTx era => Tx era -> StrictMaybe ByteString +coreAuxDataBytes :: EraTx era => Tx TopTx era -> StrictMaybe ByteString coreAuxDataBytes tx = originalBytes <$> tx ^. auxDataTxL -- =========================== @@ -162,7 +162,7 @@ pattern ShelleyBlockBody :: ( EraTx era , SafeToHash (TxWits era) ) => - StrictSeq (Tx era) -> + StrictSeq (Tx TopTx era) -> ShelleyBlockBody era pattern ShelleyBlockBody xs <- ShelleyBlockBodyInternal xs _ _ _ _ @@ -238,7 +238,7 @@ auxDataSeqDecoder bodiesLength auxDataMap = do instance ( EraTx era , DecCBOR (Annotator (TxAuxData era)) - , DecCBOR (Annotator (TxBody era)) + , DecCBOR (Annotator (TxBody TopTx era)) , DecCBOR (Annotator (TxWits era)) ) => DecCBOR (Annotator (ShelleyBlockBody era)) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index 2121ef47ac9..9110e144933 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -27,15 +27,14 @@ import Data.Sequence.Strict type ShelleyTxSeq = ShelleyBlockBody pattern ShelleyTxSeq :: - forall era. ( EraTx era , SafeToHash (TxWits era) ) => - StrictSeq (Tx era) -> + StrictSeq (Tx TopTx era) -> ShelleyBlockBody era pattern ShelleyTxSeq s = ShelleyBlockBody s -txSeqTxns :: ShelleyBlockBody era -> StrictSeq (Tx era) +txSeqTxns :: ShelleyBlockBody era -> StrictSeq (Tx TopTx era) txSeqTxns = shelleyBlockBodyTxs bbHash :: EraBlockBody era => BlockBody era -> Hash HASH EraIndependentBlockBody diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs index dd725e8739b..63a8ddc5e34 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs @@ -38,9 +38,12 @@ module Cardano.Ledger.Shelley.Era ( import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), natVersion) import Cardano.Ledger.Coin (Coin) -import Cardano.Ledger.Core (EraRule, Value) +import Cardano.Ledger.Core (EraRule, EraTxLevel (..), STxTopLevel, Value) import Cardano.Ledger.Internal.Era (ShelleyEra) +instance EraTxLevel ShelleyEra where + type STxLevel l ShelleyEra = STxTopLevel l ShelleyEra + type instance Value ShelleyEra = Coin data ShelleyBBODY era diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs index 51096c7359b..5e8ac6f10cc 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -179,17 +179,13 @@ instance ( EraBlockBody era , Embed (EraRule "LEDGERS" era) (ShelleyBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) ) => STS (ShelleyBBODY era) where - type - State (ShelleyBBODY era) = - ShelleyBbodyState era + type State (ShelleyBBODY era) = ShelleyBbodyState era - type - Signal (ShelleyBBODY era) = - Block BHeaderView era + type Signal (ShelleyBBODY era) = Block BHeaderView era type Environment (ShelleyBBODY era) = BbodyEnv era @@ -208,7 +204,7 @@ bbodyTransition :: , EraBlockBody era , Embed (EraRule "LEDGERS" era) (ShelleyBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) ) => TransitionRule (ShelleyBBODY era) bbodyTransition = diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs index 2ef72ad354a..91211b62708 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs @@ -77,12 +77,12 @@ data DelegsEnv era = DelegsEnv -- ^ Lazy on purpose, because not all certificates need to know the current EpochNo , delegsIx :: TxIx , delegspp :: PParams era - , delegsTx :: Tx era + , delegsTx :: Tx TopTx era , delegsAccount :: ChainAccountState } deriving stock instance - ( Show (Tx era) + ( Show (Tx TopTx era) , Show (PParams era) ) => Show (DelegsEnv era) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs index bad82603a96..cbc566ed2cc 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs @@ -277,7 +277,7 @@ instance , Embed (EraRule "UTXOW" era) (ShelleyLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Environment (EraRule "DELEGS" era) ~ DelegsEnv era , State (EraRule "DELEGS" era) ~ CertState era , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) @@ -289,7 +289,7 @@ instance STS (ShelleyLEDGER era) where type State (ShelleyLEDGER era) = LedgerState era - type Signal (ShelleyLEDGER era) = Tx era + type Signal (ShelleyLEDGER era) = Tx TopTx era type Environment (ShelleyLEDGER era) = LedgerEnv era type BaseM (ShelleyLEDGER era) = ShelleyBase type PredicateFailure (ShelleyLEDGER era) = ShelleyLedgerPredFailure era @@ -314,7 +314,7 @@ ledgerTransition :: , Embed (EraRule "UTXOW" era) (ShelleyLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , EraRule "LEDGER" era ~ ShelleyLEDGER era , InjectRuleFailure "LEDGER" ShelleyLedgerPredFailure era ) => @@ -392,7 +392,7 @@ renderDepositEqualsObligationViolation :: , EraGov era , EraCertState era , Environment t ~ LedgerEnv era - , Signal t ~ Tx era + , Signal t ~ Tx TopTx era , State t ~ LedgerState era ) => AssertionViolation t -> diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs index 63426d07a15..372f325507c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs @@ -164,13 +164,13 @@ instance , Embed (EraRule "LEDGER" era) (ShelleyLEDGERS era) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Default (LedgerState era) ) => STS (ShelleyLEDGERS era) where type State (ShelleyLEDGERS era) = LedgerState era - type Signal (ShelleyLEDGERS era) = Seq (Tx era) + type Signal (ShelleyLEDGERS era) = Seq (Tx TopTx era) type Environment (ShelleyLEDGERS era) = ShelleyLedgersEnv era type BaseM (ShelleyLEDGERS era) = ShelleyBase type PredicateFailure (ShelleyLEDGERS era) = ShelleyLedgersPredFailure era @@ -183,7 +183,7 @@ ledgersTransition :: ( Embed (EraRule "LEDGER" era) (ShelleyLEDGERS era) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era ) => TransitionRule (ShelleyLEDGERS era) ledgersTransition = do diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs index a4b4ef13e9a..506c5afc387 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs @@ -40,9 +40,9 @@ showKeyHash (KeyHash hash) = take 10 (show hash) showCerts :: Show (TxCert era) => [TxCert era] -> String showCerts certs = unlines (map ((" " ++) . show) certs) -showTxCerts :: EraTxBody era => TxBody era -> String -showTxCerts txb = case (toList (txb ^. certsTxBodyL)) of - [] -> ("No TxCerts in this TxBody\n" ++ show txb) +showTxCerts :: EraTxBody era => TxBody t era -> String +showTxCerts txb = case toList (txb ^. certsTxBodyL) of + [] -> "No TxCerts in this TxBody\n" ++ show txb certs -> showCerts certs -- | Display a synopsis of a map to Coin @@ -58,7 +58,7 @@ produceEqualsConsumed :: PParams era -> CertState era -> UTxO era -> - TxBody era -> + TxBody TopTx era -> String produceEqualsConsumed pp dpstate utxo txb = let consumedValue = consumedTxBody txb pp dpstate utxo diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs index 7130d21f452..cb5372b5d8d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -290,7 +290,7 @@ instance STS (ShelleyUTXO era) where type State (ShelleyUTXO era) = UTxOState era - type Signal (ShelleyUTXO era) = Tx era + type Signal (ShelleyUTXO era) = Tx TopTx era type Environment (ShelleyUTXO era) = UtxoEnv era type BaseM (ShelleyUTXO era) = ShelleyBase type PredicateFailure (ShelleyUTXO era) = ShelleyUtxoPredFailure era @@ -330,7 +330,7 @@ instance "Deposit pot must not be negative (post)" (\_ st' -> utxosDeposited st' >= mempty) , let utxoBalance us = Val.inject (utxosDeposited us <> utxosFees us) <> sumUTxO (utxosUtxo us) - withdrawals :: TxBody era -> Value era + withdrawals :: TxBody TopTx era -> Value era withdrawals txb = Val.inject $ F.foldl' (<>) mempty $ unWithdrawals $ txb ^. withdrawalsTxBodyL in PostCondition "Should preserve value in the UTxO state" @@ -352,7 +352,7 @@ utxoInductive :: , BaseM (EraRule "UTXO" era) ~ ShelleyBase , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , Event (EraRule "UTXO" era) ~ UtxoEvent era , Environment (EraRule "PPUP" era) ~ PpupEnv era , State (EraRule "PPUP" era) ~ ShelleyGovState era @@ -420,7 +420,7 @@ utxoInductive = do -- > txttl txb ≥ slot validateTimeToLive :: (ShelleyEraTxBody era, ExactEra ShelleyEra era) => - TxBody era -> + TxBody TopTx era -> SlotNo -> Test (ShelleyUtxoPredFailure era) validateTimeToLive txb slot = @@ -434,7 +434,7 @@ validateTimeToLive txb slot = -- > txins txb ≠ ∅ validateInputSetEmptyUTxO :: EraTxBody era => - TxBody era -> + TxBody t era -> Test (ShelleyUtxoPredFailure era) validateInputSetEmptyUTxO txb = failureUnless (inputs /= Set.empty) InputSetEmptyUTxO @@ -447,7 +447,7 @@ validateInputSetEmptyUTxO txb = validateFeeTooSmallUTxO :: EraUTxO era => PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Test (ShelleyUtxoPredFailure era) validateFeeTooSmallUTxO pp tx utxo = @@ -497,7 +497,7 @@ validateWrongNetwork netId outputs = validateWrongNetworkWithdrawal :: EraTxBody era => Network -> - TxBody era -> + TxBody t era -> Test (ShelleyUtxoPredFailure era) validateWrongNetworkWithdrawal netId txb = failureUnless (null withdrawalsWrongNetwork) $ @@ -516,7 +516,7 @@ validateValueNotConservedUTxO :: PParams era -> UTxO era -> CertState era -> - TxBody era -> + TxBody TopTx era -> Test (ShelleyUtxoPredFailure era) validateValueNotConservedUTxO pp utxo certState txBody = failureUnless (consumedValue == producedValue) $ @@ -570,7 +570,7 @@ validateOutputBootAddrAttrsTooBig outputs = validateMaxTxSizeUTxO :: EraTx era => PParams era -> - Tx era -> + Tx l era -> Test (ShelleyUtxoPredFailure era) validateMaxTxSizeUTxO pp tx = failureUnless (txSize <= maxTxSize) $ @@ -592,7 +592,7 @@ updateUTxOState :: (EraTxBody era, EraStake era, EraCertState era, Monad m) => PParams era -> UTxOState era -> - TxBody era -> + TxBody TopTx era -> CertState era -> GovState era -> (Coin -> m ()) -> @@ -637,7 +637,7 @@ instance validSizeComputationCheck :: ( EraTx era , SafeToHash (TxWits era) - , Signal (rule era) ~ Tx era + , Signal (rule era) ~ Tx TopTx era ) => Assertion (rule era) validSizeComputationCheck = diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxow.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxow.hs index 0ae23df6d43..f4b4bec2c70 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxow.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxow.hs @@ -284,10 +284,10 @@ transitionRulesUTXOW :: , Embed (EraRule "UTXO" era) (EraRule "UTXOW" era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , STS (EraRule "UTXOW" era) , EraCertState era @@ -352,7 +352,7 @@ instance Embed (EraRule "UTXO" era) (ShelleyUTXOW era) , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era , EraRule "UTXOW" era ~ ShelleyUTXOW era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , EraGov era @@ -361,7 +361,7 @@ instance STS (ShelleyUTXOW era) where type State (ShelleyUTXOW era) = UTxOState era - type Signal (ShelleyUTXOW era) = Tx era + type Signal (ShelleyUTXOW era) = Tx TopTx era type Environment (ShelleyUTXOW era) = UtxoEnv era type BaseM (ShelleyUTXOW era) = ShelleyBase type PredicateFailure (ShelleyUTXOW era) = ShelleyUtxowPredFailure era @@ -371,7 +371,7 @@ instance {- ∀ s ∈ range(txscripts txw) ∩ Scriptnative), runNativeScript s tx -} validateFailedNativeScripts :: - EraTx era => ScriptsProvided era -> Tx era -> Test (ShelleyUtxowPredFailure era) + EraTx era => ScriptsProvided era -> Tx l era -> Test (ShelleyUtxowPredFailure era) validateFailedNativeScripts (ScriptsProvided scriptsProvided) tx = do let failedScripts = Map.filter -- we keep around only non-validating native scripts @@ -398,7 +398,7 @@ validateMissingScripts (ShelleyScriptsNeeded sNeeded) scriptsprovided = sProvided = Map.keysSet $ unScriptsProvided scriptsprovided -- | Determine if the UTxO witnesses in a given transaction are correct. -validateVerifiedWits :: EraTx era => Tx era -> Test (ShelleyUtxowPredFailure era) +validateVerifiedWits :: EraTx era => Tx l era -> Test (ShelleyUtxowPredFailure era) validateVerifiedWits tx = case failed <> failedBootstrap of [] -> pure () @@ -427,7 +427,7 @@ validateNeededWitnesses :: Set (KeyHash 'Witness) -> CertState era -> UTxO era -> - TxBody era -> + TxBody t era -> Test (ShelleyUtxowPredFailure era) validateNeededWitnesses witsKeyHashes certState utxo txBody = let needed = getWitsVKeyNeeded certState utxo txBody @@ -437,7 +437,7 @@ validateNeededWitnesses witsKeyHashes certState utxo txBody = -- | check metadata hash -- ((adh = ◇) ∧ (ad= ◇)) ∨ (adh = hashAD ad) -validateMetadata :: EraTx era => PParams era -> Tx era -> Test (ShelleyUtxowPredFailure era) +validateMetadata :: EraTx era => PParams era -> Tx l era -> Test (ShelleyUtxowPredFailure era) validateMetadata pp tx = let txBody = tx ^. bodyTxL pv = pp ^. ppProtocolVersionL @@ -467,7 +467,7 @@ validateMIRInsufficientGenesisSigs :: GenDelegs -> Word64 -> Set (KeyHash 'Witness) -> - Tx era -> + Tx TopTx era -> Test (ShelleyUtxowPredFailure era) validateMIRInsufficientGenesisSigs (GenDelegs genMapping) coreNodeQuorum witsKeyHashes tx = let genDelegates = diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs index 3e6a609b105..f6d98f38b4a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs @@ -252,7 +252,7 @@ evalMultiSig vhks = go -- | Script validator for native multi-signature scheme. validateMultiSig :: (ShelleyEraScript era, EraTx era, NativeScript era ~ MultiSig era) => - Tx era -> + Tx t era -> NativeScript era -> Bool validateMultiSig tx = diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs index a6b8156fc0b..a5c30a35b75 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs @@ -84,12 +84,12 @@ shelleyObligationCertState certState = } shelleyCertsTotalDepositsTxBody :: - EraTxBody era => PParams era -> ShelleyCertState era -> TxBody era -> Coin + EraTxBody era => PParams era -> ShelleyCertState era -> TxBody t era -> Coin shelleyCertsTotalDepositsTxBody pp ShelleyCertState {shelleyCertPState} = getTotalDepositsTxBody pp (`Map.member` psStakePools shelleyCertPState) shelleyCertsTotalRefundsTxBody :: - (EraTxBody era, EraAccounts era) => PParams era -> ShelleyCertState era -> TxBody era -> Coin + (EraTxBody era, EraAccounts era) => PParams era -> ShelleyCertState era -> TxBody t era -> Coin shelleyCertsTotalRefundsTxBody pp ShelleyCertState {shelleyCertDState} = getTotalRefundsTxBody pp diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs index ddfa399abe8..8073abe4258 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs @@ -84,7 +84,7 @@ import NoThunks.Class (NoThunks (..)) -- | Register the initial information in the 'NewEpochState'. -- --- HERE BE DRAGONS! This interfaced is intended to help in testing. +-- HERE BE DRAGONS! This interface is intended to help in testing and benchmarking. -- -- In production, the genesis should /not/ contain any initial information about accounts, stake -- pools or dreps. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index 7019bcfde05..6bb5cf315f8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -4,7 +4,10 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -54,89 +57,102 @@ import Cardano.Ledger.Shelley.TxAuxData () import Cardano.Ledger.Shelley.TxBody () import Cardano.Ledger.Shelley.TxWits () import Cardano.Ledger.Val ((<+>), (<×>)) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), deepseq) import Control.Monad.Trans.Fail.String (errorFail) import qualified Data.ByteString.Lazy as LBS import Data.Functor.Classes (Eq1 (..)) import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Typeable import Data.Word (Word32) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Lens.Micro (Lens', SimpleGetter, lens, to, (^.)) -import NoThunks.Class (NoThunks (..)) +import NoThunks.Class (InspectHeap (..), NoThunks (..)) -- ======================================================== -data ShelleyTx era = ShelleyTx - { stBody :: !(TxBody era) - , stWits :: !(TxWits era) - , stAuxData :: !(StrictMaybe (TxAuxData era)) - } - deriving (Generic) +data ShelleyTx l era where + ShelleyTx :: + { stBody :: !(TxBody TopTx era) + , stWits :: !(TxWits era) + , stAuxData :: !(StrictMaybe (TxAuxData era)) + } -> + ShelleyTx TopTx era instance - ( NFData (TxBody era) + ( NFData (TxBody l era) , NFData (TxWits era) , NFData (TxAuxData era) ) => - NFData (ShelleyTx era) + NFData (ShelleyTx l era) + where + rnf ShelleyTx {stBody, stWits, stAuxData} = + stBody `deepseq` stWits `deepseq` rnf stAuxData deriving instance ( Era era - , Eq (TxBody era) + , Eq (TxBody l era) , Eq (TxWits era) , Eq (TxAuxData era) ) => - Eq (ShelleyTx era) + Eq (ShelleyTx l era) deriving instance ( Era era - , Show (TxBody era) + , Show (TxBody l era) , Show (TxWits era) , Show (TxAuxData era) ) => - Show (ShelleyTx era) + Show (ShelleyTx l era) -instance - ( Era era - , NoThunks (TxAuxData era) - , NoThunks (TxBody era) - , NoThunks (TxWits era) - ) => - NoThunks (ShelleyTx era) +deriving via + InspectHeap (ShelleyTx l era) + instance + (Typeable era, Typeable l) => NoThunks (ShelleyTx l era) -- | `TxBody` setter and getter for `ShelleyTx`. -bodyShelleyTxL :: Lens' (ShelleyTx era) (TxBody era) +bodyShelleyTxL :: Lens' (ShelleyTx l era) (TxBody l era) bodyShelleyTxL = - lens stBody $ \tx txBody -> tx {stBody = txBody} + lens (\ShelleyTx {stBody} -> stBody) $ \tx txBody -> + case tx of + ShelleyTx {} -> tx {stBody = txBody} {-# INLINEABLE bodyShelleyTxL #-} -- | `TxWits` setter and getter for `ShelleyTx`. -witsShelleyTxL :: Lens' (ShelleyTx era) (TxWits era) +witsShelleyTxL :: Lens' (ShelleyTx l era) (TxWits era) witsShelleyTxL = - lens stWits $ \tx txWits -> tx {stWits = txWits} + lens (\ShelleyTx {stWits} -> stWits) $ \tx txWits -> + case tx of + ShelleyTx {} -> tx {stWits = txWits} {-# INLINEABLE witsShelleyTxL #-} -- | `TxAuxData` setter and getter for `ShelleyTx`. -auxDataShelleyTxL :: Lens' (ShelleyTx era) (StrictMaybe (TxAuxData era)) +auxDataShelleyTxL :: Lens' (ShelleyTx l era) (StrictMaybe (TxAuxData era)) auxDataShelleyTxL = - lens stAuxData $ \tx txAuxData -> tx {stAuxData = txAuxData} + lens (\ShelleyTx {stAuxData} -> stAuxData) $ \tx txAuxData -> + case tx of + ShelleyTx {} -> tx {stAuxData = txAuxData} {-# INLINEABLE auxDataShelleyTxL #-} -mkBasicShelleyTx :: EraTx era => TxBody era -> ShelleyTx era +mkBasicShelleyTx :: + (EraTx era, STxLevel l era ~ STxTopLevel l era) => + TxBody l era -> + ShelleyTx l era mkBasicShelleyTx txBody = - ShelleyTx - { stBody = txBody - , stWits = mkBasicTxWits - , stAuxData = SNothing - } + case toSTxLevel txBody of + STopTxOnly -> + ShelleyTx + { stBody = txBody + , stWits = mkBasicTxWits + , stAuxData = SNothing + } toCBORForSizeComputation :: - ( EncCBOR (TxBody era) + ( EncCBOR (TxBody l era) , EncCBOR (TxWits era) , EncCBOR (TxAuxData era) ) => - ShelleyTx era -> + ShelleyTx l era -> Encoding toCBORForSizeComputation ShelleyTx {stBody, stWits, stAuxData} = encodeListLen 3 @@ -145,7 +161,7 @@ toCBORForSizeComputation ShelleyTx {stBody, stWits, stAuxData} = <> encodeNullStrictMaybe encCBOR stAuxData -- | txsize computes the length of the serialised bytes (for estimations) -sizeShelleyTxF :: forall era. (HasCallStack, EraTx era) => SimpleGetter (ShelleyTx era) Word32 +sizeShelleyTxF :: forall era l. (HasCallStack, EraTx era) => SimpleGetter (ShelleyTx l era) Word32 sizeShelleyTxF = to $ errorFail @@ -156,24 +172,31 @@ sizeShelleyTxF = {-# INLINEABLE sizeShelleyTxF #-} instance - ( EraTxBody era + ( Typeable l + , EraTxBody era , EraTxWits era , EraTxAuxData era + , STxLevel l era ~ STxTopLevel l era ) => - DecCBOR (Annotator (ShelleyTx era)) + DecCBOR (Annotator (ShelleyTx l era)) where decCBOR = - decode $ - Ann (RecD ShelleyTx) - <*! From - <*! From - <*! D (sequence <$> decodeNullStrictMaybe decCBOR) - -instance DecCBOR (Annotator (Tx ShelleyEra)) where + withSTxTopLevelM @l @era $ \case + STopTxOnly -> + decode $ + Ann (RecD ShelleyTx) + <*! From + <*! From + <*! D (sequence <$> decodeNullStrictMaybe decCBOR) + +instance Typeable l => DecCBOR (Annotator (Tx l ShelleyEra)) where decCBOR = fmap MkShelleyTx <$> decCBOR +instance HasEraTxLevel Tx ShelleyEra where + toSTxLevel (MkShelleyTx ShelleyTx {}) = STopTxOnly @ShelleyEra + instance EraTx ShelleyEra where - newtype Tx ShelleyEra = MkShelleyTx {unShelleyTx :: ShelleyTx ShelleyEra} + newtype Tx l ShelleyEra = MkShelleyTx {unShelleyTx :: ShelleyTx l ShelleyEra} deriving newtype (Eq, EncCBOR, NFData, NoThunks, Show, ToCBOR) deriving (Generic) @@ -196,16 +219,16 @@ instance EraTx ShelleyEra where getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx -shelleyTxEqRaw :: EraTx era => Tx era -> Tx era -> Bool +shelleyTxEqRaw :: EraTx era => Tx l era -> Tx l era -> Bool shelleyTxEqRaw tx1 tx2 = eqRaw (tx1 ^. bodyTxL) (tx2 ^. bodyTxL) && eqRaw (tx1 ^. witsTxL) (tx2 ^. witsTxL) && liftEq eqRaw (tx1 ^. auxDataTxL) (tx2 ^. auxDataTxL) -instance EqRaw (Tx ShelleyEra) where +instance EqRaw (Tx l ShelleyEra) where eqRaw = shelleyTxEqRaw -shelleyTxL :: Lens' (Tx ShelleyEra) (ShelleyTx ShelleyEra) +shelleyTxL :: Lens' (Tx l ShelleyEra) (ShelleyTx l ShelleyEra) shelleyTxL = lens unShelleyTx (\x y -> x {unShelleyTx = y}) -------------------------------------------------------------------------------- @@ -213,8 +236,8 @@ shelleyTxL = lens unShelleyTx (\x y -> x {unShelleyTx = y}) -------------------------------------------------------------------------------- instance - (Era era, EncCBOR (TxWits era), EncCBOR (TxBody era), EncCBOR (TxAuxData era)) => - EncCBOR (ShelleyTx era) + (Era era, EncCBOR (TxWits era), EncCBOR (TxBody l era), EncCBOR (TxAuxData era)) => + EncCBOR (ShelleyTx l era) where encCBOR ShelleyTx {..} = encode $ @@ -224,27 +247,12 @@ instance !> E (encodeNullStrictMaybe encCBOR) stAuxData instance - ( Era era - , DecCBOR (TxBody era) - , DecCBOR (TxWits era) - , DecCBOR (TxAuxData era) - ) => - DecCBOR (ShelleyTx era) - where - decCBOR = - decode $ - RecD ShelleyTx - - ToCBOR (ShelleyTx era) + (Era era, EncCBOR (TxWits era), EncCBOR (TxBody l era), EncCBOR (TxAuxData era), Typeable l) => + ToCBOR (ShelleyTx l era) where toCBOR = toEraCBOR @era -- | Minimum fee calculation -shelleyMinFeeTx :: EraTx era => PParams era -> Tx era -> Coin +shelleyMinFeeTx :: EraTx era => PParams era -> Tx l era -> Coin shelleyMinFeeTx pp tx = (tx ^. sizeTxF <×> pp ^. ppMinFeeAL) <+> pp ^. ppMinFeeBL diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index 43992bdb97a..5c1c0f74355 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -4,10 +4,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -79,58 +82,65 @@ import Cardano.Ledger.Shelley.TxCert (ShelleyEraTxCert (..)) import Cardano.Ledger.Shelley.TxOut () import Cardano.Ledger.Slot (SlotNo (..)) import Cardano.Ledger.TxIn (TxIn) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), deepseq) import qualified Data.Map.Strict as Map import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable import GHC.Generics (Generic) import Lens.Micro -import NoThunks.Class (NoThunks (..)) +import NoThunks.Class (InspectHeap (..), NoThunks (..)) class (ShelleyEraTxCert era, EraTxBody era, AtMostEra "Babbage" era) => ShelleyEraTxBody era where - ttlTxBodyL :: ExactEra ShelleyEra era => Lens' (TxBody era) SlotNo + ttlTxBodyL :: ExactEra ShelleyEra era => Lens' (TxBody TopTx era) SlotNo - updateTxBodyL :: Lens' (TxBody era) (StrictMaybe (Update era)) + updateTxBodyL :: Lens' (TxBody TopTx era) (StrictMaybe (Update era)) -- ============================== -- The underlying type for TxBody -data ShelleyTxBodyRaw = ShelleyTxBodyRaw - { stbrInputs :: !(Set TxIn) - , stbrOutputs :: !(StrictSeq (TxOut ShelleyEra)) - , stbrCerts :: !(StrictSeq (TxCert ShelleyEra)) - , stbrWithdrawals :: !Withdrawals - , stbrFee :: !Coin - , stbrTtl :: !SlotNo - , stbrUpdate :: !(StrictMaybe (Update ShelleyEra)) - , stbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) - } - deriving (Generic) +data ShelleyTxBodyRaw l era where + ShelleyTxBodyRaw :: + { stbrInputs :: !(Set TxIn) + , stbrOutputs :: !(StrictSeq (TxOut era)) + , stbrCerts :: !(StrictSeq (TxCert era)) + , stbrWithdrawals :: !Withdrawals + , stbrFee :: !Coin + , stbrTtl :: !SlotNo + , stbrUpdate :: !(StrictMaybe (Update era)) + , stbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + } -> + ShelleyTxBodyRaw TopTx era + +instance HasEraTxLevel ShelleyTxBodyRaw ShelleyEra where + toSTxLevel ShelleyTxBodyRaw {} = STopTxOnly @ShelleyEra -deriving instance NoThunks ShelleyTxBodyRaw - -deriving instance NFData ShelleyTxBodyRaw +deriving via + InspectHeap (ShelleyTxBodyRaw l era) + instance + (Typeable era, Typeable l) => NoThunks (ShelleyTxBodyRaw l era) -deriving instance Eq ShelleyTxBodyRaw +instance EraTxBody era => NFData (ShelleyTxBodyRaw t era) where + rnf ShelleyTxBodyRaw {stbrWithdrawals, stbrUpdate, stbrAuxDataHash} = + stbrWithdrawals `deepseq` stbrUpdate `deepseq` rnf stbrAuxDataHash -deriving instance Show ShelleyTxBodyRaw +deriving instance EraTxBody era => Eq (ShelleyTxBodyRaw l era) --- | Encodes memoized bytes created upon construction. -instance EncCBOR (TxBody ShelleyEra) +deriving instance EraTxBody era => Show (ShelleyTxBodyRaw l era) -instance DecCBOR ShelleyTxBodyRaw where +instance Typeable l => DecCBOR (ShelleyTxBodyRaw l ShelleyEra) where decCBOR = - decode - ( SparseKeyed + mkSTxTopLevelM @l $ + decode $ + SparseKeyed "TxBody" basicShelleyTxBodyRaw boxBody [(0, "inputs"), (1, "outputs"), (2, "fee"), (3, "ttl")] - ) -instance DecCBOR (Annotator ShelleyTxBodyRaw) where +instance Typeable l => DecCBOR (Annotator (ShelleyTxBodyRaw l ShelleyEra)) where decCBOR = pure <$> decCBOR -- ================================================================= @@ -141,7 +151,7 @@ instance DecCBOR (Annotator ShelleyTxBodyRaw) where -- | Choose a de-serialiser when given the key (of type Word). -- Wrap it in a Field which pairs it with its update function which -- changes only the field being deserialised. -boxBody :: Word -> Field ShelleyTxBodyRaw +boxBody :: EraTxBody era => Word -> Field (ShelleyTxBodyRaw t era) boxBody 0 = field (\x tx -> tx {stbrInputs = x}) From boxBody 1 = field (\x tx -> tx {stbrOutputs = x}) From boxBody 4 = field (\x tx -> tx {stbrCerts = x}) From @@ -155,7 +165,9 @@ boxBody n = invalidField n -- | Tells how to serialise each field, and what tag to label it with in the -- serialisation. boxBody and txSparse should be Duals, visually inspect -- The key order looks strange but was choosen for backward compatibility. -txSparse :: ShelleyTxBodyRaw -> Encode ('Closed 'Sparse) ShelleyTxBodyRaw +txSparse :: + EraTxBody era => + ShelleyTxBodyRaw t era -> Encode ('Closed 'Sparse) (ShelleyTxBodyRaw t era) txSparse (ShelleyTxBodyRaw input output cert wdrl fee ttl update hash) = Keyed (\i o f t c w u h -> ShelleyTxBodyRaw i o c w f t u h) !> Key 0 (To input) -- We don't have to send these in ShelleyTxBodyRaw order @@ -169,7 +181,7 @@ txSparse (ShelleyTxBodyRaw input output cert wdrl fee ttl update hash) = -- The initial TxBody. We will overide some of these fields as we build a TxBody, -- adding one field at a time, using optional serialisers, inside the Pattern. -basicShelleyTxBodyRaw :: ShelleyTxBodyRaw +basicShelleyTxBodyRaw :: ShelleyTxBodyRaw TopTx era basicShelleyTxBodyRaw = ShelleyTxBodyRaw { stbrInputs = Set.empty @@ -182,20 +194,23 @@ basicShelleyTxBodyRaw = , stbrAuxDataHash = SNothing } -instance EncCBOR ShelleyTxBodyRaw where +instance EraTxBody era => EncCBOR (ShelleyTxBodyRaw l era) where encCBOR = encode . txSparse -instance Memoized (TxBody ShelleyEra) where - type RawType (TxBody ShelleyEra) = ShelleyTxBodyRaw +instance Memoized (TxBody l ShelleyEra) where + type RawType (TxBody l ShelleyEra) = ShelleyTxBodyRaw l ShelleyEra + +instance EqRaw (TxBody l ShelleyEra) -instance EqRaw (TxBody ShelleyEra) +instance HasEraTxLevel TxBody ShelleyEra where + toSTxLevel = toSTxLevel . getMemoRawType instance EraTxBody ShelleyEra where - newtype TxBody ShelleyEra = MkShelleyTxBody (MemoBytes ShelleyTxBodyRaw) + newtype TxBody l ShelleyEra = MkShelleyTxBody (MemoBytes (ShelleyTxBodyRaw l ShelleyEra)) deriving (Generic) - deriving newtype (SafeToHash, ToCBOR) + deriving newtype (SafeToHash, ToCBOR, EncCBOR) - mkBasicTxBody = mkMemoizedEra @ShelleyEra basicShelleyTxBodyRaw + mkBasicTxBody = asSTxTopLevel $ mkMemoizedEra @ShelleyEra basicShelleyTxBodyRaw spendableInputsTxBodyF = inputsTxBodyL {-# INLINE spendableInputsTxBodyF #-} @@ -204,13 +219,13 @@ instance EraTxBody ShelleyEra where {-# INLINE allInputsTxBodyF #-} inputsTxBodyL = - lensMemoRawType @ShelleyEra stbrInputs $ - \txBodyRaw inputs -> txBodyRaw {stbrInputs = inputs} + lensMemoRawType @ShelleyEra (\ShelleyTxBodyRaw {stbrInputs} -> stbrInputs) $ + \txBodyRaw@ShelleyTxBodyRaw {} inputs -> txBodyRaw {stbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType @ShelleyEra stbrOutputs $ - \txBodyRaw outputs -> txBodyRaw {stbrOutputs = outputs} + lensMemoRawType @ShelleyEra (\ShelleyTxBodyRaw {stbrOutputs} -> stbrOutputs) $ + \txBodyRaw@ShelleyTxBodyRaw {} outputs -> txBodyRaw {stbrOutputs = outputs} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = @@ -219,18 +234,18 @@ instance EraTxBody ShelleyEra where {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType @ShelleyEra stbrAuxDataHash $ - \txBodyRaw auxDataHash -> txBodyRaw {stbrAuxDataHash = auxDataHash} + lensMemoRawType @ShelleyEra (\ShelleyTxBodyRaw {stbrAuxDataHash} -> stbrAuxDataHash) $ + \txBodyRaw@ShelleyTxBodyRaw {} auxDataHash -> txBodyRaw {stbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} withdrawalsTxBodyL = - lensMemoRawType @ShelleyEra stbrWithdrawals $ - \txBodyRaw withdrawals -> txBodyRaw {stbrWithdrawals = withdrawals} + lensMemoRawType @ShelleyEra (\ShelleyTxBodyRaw {stbrWithdrawals} -> stbrWithdrawals) $ + \txBodyRaw@ShelleyTxBodyRaw {} withdrawals -> txBodyRaw {stbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType @ShelleyEra stbrCerts $ - \txBodyRaw certs -> txBodyRaw {stbrCerts = certs} + lensMemoRawType @ShelleyEra (\ShelleyTxBodyRaw {stbrCerts} -> stbrCerts) $ + \txBodyRaw@ShelleyTxBodyRaw {} certs -> txBodyRaw {stbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -244,18 +259,18 @@ instance ShelleyEraTxBody ShelleyEra where lensMemoRawType @ShelleyEra stbrUpdate $ \txBodyRaw update -> txBodyRaw {stbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} -deriving newtype instance NoThunks (TxBody ShelleyEra) +deriving newtype instance Typeable l => NoThunks (TxBody l ShelleyEra) -deriving newtype instance NFData (TxBody ShelleyEra) +deriving newtype instance NFData (TxBody l ShelleyEra) -deriving instance Show (TxBody ShelleyEra) +deriving instance Show (TxBody l ShelleyEra) -deriving instance Eq (TxBody ShelleyEra) +deriving instance Eq (TxBody l ShelleyEra) deriving via - Mem ShelleyTxBodyRaw + Mem (ShelleyTxBodyRaw l ShelleyEra) instance - DecCBOR (Annotator (TxBody ShelleyEra)) + Typeable l => DecCBOR (Annotator (TxBody l ShelleyEra)) -- | Pattern for use by external users pattern ShelleyTxBody :: @@ -267,7 +282,7 @@ pattern ShelleyTxBody :: SlotNo -> StrictMaybe (Update ShelleyEra) -> StrictMaybe TxAuxDataHash -> - TxBody ShelleyEra + TxBody TopTx ShelleyEra pattern ShelleyTxBody { stbInputs , stbOutputs @@ -316,15 +331,15 @@ pattern ShelleyTxBody -- ========================================= -type instance MemoHashIndex ShelleyTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (ShelleyTxBodyRaw t era) = EraIndependentTxBody -instance HashAnnotated (TxBody ShelleyEra) EraIndependentTxBody where +instance HashAnnotated (TxBody l ShelleyEra) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -- =============================================================== -- | Count number of Genesis keys supplied in the `updateTxBodyL` field. -getShelleyGenesisKeyHashCountTxBody :: ShelleyEraTxBody era => TxBody era -> Int +getShelleyGenesisKeyHashCountTxBody :: ShelleyEraTxBody era => TxBody TopTx era -> Int getShelleyGenesisKeyHashCountTxBody txBody = case txBody ^. updateTxBodyL of SJust (Update (ProposedPPUpdates m) _) -> Map.size m diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/UTxO.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/UTxO.hs index 9122e8b1b89..6ae734c8e0a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/UTxO.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/UTxO.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -103,7 +104,7 @@ txinsScriptHashes txInps (UTxO u) = foldr add Set.empty txInps getShelleyScriptsNeeded :: EraTxBody era => UTxO era -> - TxBody era -> + TxBody l era -> ShelleyScriptsNeeded era getShelleyScriptsNeeded u txBody = ShelleyScriptsNeeded @@ -124,7 +125,7 @@ shelleyConsumed :: PParams era -> CertState era -> UTxO era -> - TxBody era -> + TxBody l era -> Value era shelleyConsumed pp certState = getConsumedValue @@ -138,7 +139,7 @@ produced :: (EraUTxO era, EraCertState era) => PParams era -> CertState era -> - TxBody era -> + TxBody l era -> Value era produced pp certState = getProducedValue pp (flip Map.member $ certState ^. certPStateL . psStakePoolsL) @@ -148,7 +149,7 @@ shelleyProducedValue :: PParams era -> -- | Check whether a pool with a supplied PoolStakeId is already registered. (KeyHash 'StakePool -> Bool) -> - TxBody era -> + TxBody TopTx era -> Value era shelleyProducedValue pp isRegPoolId txBody = sumAllValue (txBody ^. outputsTxBodyL) @@ -162,7 +163,7 @@ getConsumedCoin :: PParams era -> (Credential 'Staking -> Maybe Coin) -> UTxO era -> - TxBody era -> + TxBody l era -> Coin getConsumedCoin pp lookupRefund utxo txBody = {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds dpstate tx -} @@ -183,7 +184,8 @@ instance EraUTxO ShelleyEra where getConsumedValue pp lookupKeyDeposit _ = getConsumedCoin pp lookupKeyDeposit - getProducedValue = shelleyProducedValue + getProducedValue pp isRegPoolId txBody = + withTopTxLevelOnly txBody (shelleyProducedValue pp isRegPoolId) getScriptsProvided _ tx = ScriptsProvided (tx ^. witsTxL . scriptTxWitsL) @@ -196,7 +198,7 @@ instance EraUTxO ShelleyEra where getMinFeeTxUtxo pp tx _ = getShelleyMinFeeTxUtxo pp tx -- We don't consider the reference scripts in the calculation before Conway -getShelleyMinFeeTxUtxo :: EraTx era => PParams era -> Tx era -> Coin +getShelleyMinFeeTxUtxo :: EraTx era => PParams era -> Tx l era -> Coin getShelleyMinFeeTxUtxo pparams tx = getMinFeeTx pparams tx 0 -- | Collect the set of hashes of keys that needs to sign a @@ -205,7 +207,7 @@ getShelleyMinFeeTxUtxo pparams tx = getMinFeeTx pparams tx 0 witsVKeyNeededGenDelegs :: forall era. ShelleyEraTxBody era => - TxBody era -> + TxBody TopTx era -> GenDelegs -> Set (KeyHash 'Witness) witsVKeyNeededGenDelegs txBody (GenDelegs genDelegs) = @@ -224,10 +226,9 @@ witsVKeyNeededGenDelegs txBody (GenDelegs genDelegs) = -- | Extract witnesses from UTxO and TxBody. Does not enforce witnesses for governance -- related Keys, i.e. `GenDelegs` getShelleyWitsVKeyNeededNoGov :: - forall era. EraTx era => UTxO era -> - TxBody era -> + TxBody l era -> Set (KeyHash 'Witness) getShelleyWitsVKeyNeededNoGov utxo' txBody = certAuthors @@ -272,12 +273,13 @@ getShelleyWitsVKeyNeededNoGov utxo' txBody = Just vkeyWit -> Set.insert vkeyWit ans getShelleyWitsVKeyNeeded :: - forall era. - (EraTx era, ShelleyEraTxBody era, EraCertState era) => + (EraTx era, ShelleyEraTxBody era, EraCertState era, STxLevel l era ~ STxTopLevel l era) => CertState era -> UTxO era -> - TxBody era -> + TxBody l era -> Set (KeyHash 'Witness) getShelleyWitsVKeyNeeded certState utxo txBody = - getShelleyWitsVKeyNeededNoGov utxo txBody - `Set.union` witsVKeyNeededGenDelegs txBody (dsGenDelegs (certState ^. certDStateL)) + case toSTxLevel txBody of + STopTxOnly -> + getShelleyWitsVKeyNeededNoGov utxo txBody + `Set.union` witsVKeyNeededGenDelegs txBody (dsGenDelegs (certState ^. certDStateL)) diff --git a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs index d9be36d5dac..f737afb3a66 100644 --- a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs +++ b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs @@ -45,8 +45,8 @@ spec = cddlRoundTripCborSpec @Addr v "address" cddlRoundTripCborSpec @RewardAccount v "reward_account" cddlRoundTripCborSpec @(Credential 'Staking) v "stake_credential" - cddlRoundTripAnnCborSpec @(TxBody ShelleyEra) v "transaction_body" - cddlRoundTripCborSpec @(TxBody ShelleyEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxBody TopTx ShelleyEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody TopTx ShelleyEra) v "transaction_body" cddlRoundTripCborSpec @(TxOut ShelleyEra) v "transaction_output" cddlRoundTripCborSpec @StakePoolRelay v "relay" cddlRoundTripCborSpec @(TxCert ShelleyEra) v "certificate" @@ -58,14 +58,14 @@ spec = cddlRoundTripCborSpec @(Update ShelleyEra) v "update" cddlRoundTripCborSpec @(ProposedPPUpdates ShelleyEra) v "proposed_protocol_parameter_updates" cddlRoundTripCborSpec @(PParamsUpdate ShelleyEra) v "protocol_param_update" - cddlRoundTripAnnCborSpec @(Tx ShelleyEra) v "transaction" - cddlRoundTripCborSpec @(Tx ShelleyEra) v "transaction" + cddlRoundTripAnnCborSpec @(Tx TopTx ShelleyEra) v "transaction" + cddlRoundTripCborSpec @(Tx TopTx ShelleyEra) v "transaction" describe "DecCBOR instances equivalence via CDDL" $ do cddlDecoderEquivalenceSpec @BootstrapWitness v "bootstrap_witness" - cddlDecoderEquivalenceSpec @(TxBody ShelleyEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxBody TopTx ShelleyEra) v "transaction_body" cddlDecoderEquivalenceSpec @(TxAuxData ShelleyEra) v "transaction_metadata" cddlDecoderEquivalenceSpec @(MultiSig ShelleyEra) v "multisig_script" - cddlDecoderEquivalenceSpec @(Tx ShelleyEra) v "transaction" + cddlDecoderEquivalenceSpec @(Tx TopTx ShelleyEra) v "transaction" describe "Huddle" $ specWithHuddle shelleyCDDL 100 $ do huddleRoundTripCborSpec @Addr v "address" @@ -76,8 +76,8 @@ spec = huddleRoundTripCborSpec @BootstrapWitness v "bootstrap_witness" huddleRoundTripCborSpec @RewardAccount v "reward_account" huddleRoundTripCborSpec @(Credential 'Staking) v "stake_credential" - huddleRoundTripAnnCborSpec @(TxBody ShelleyEra) v "transaction_body" - huddleRoundTripCborSpec @(TxBody ShelleyEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxBody TopTx ShelleyEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody TopTx ShelleyEra) v "transaction_body" huddleRoundTripCborSpec @(TxOut ShelleyEra) v "transaction_output" huddleRoundTripCborSpec @StakePoolRelay v "relay" huddleRoundTripCborSpec @(TxCert ShelleyEra) v "certificate" @@ -89,13 +89,13 @@ spec = huddleRoundTripCborSpec @(Update ShelleyEra) v "update" huddleRoundTripCborSpec @(ProposedPPUpdates ShelleyEra) v "proposed_protocol_parameter_updates" huddleRoundTripCborSpec @(PParamsUpdate ShelleyEra) v "protocol_param_update" - huddleRoundTripAnnCborSpec @(Tx ShelleyEra) v "transaction" - huddleRoundTripCborSpec @(Tx ShelleyEra) v "transaction" + huddleRoundTripAnnCborSpec @(Tx TopTx ShelleyEra) v "transaction" + huddleRoundTripCborSpec @(Tx TopTx ShelleyEra) v "transaction" huddleRoundTripAnnCborSpec @(TxWits ShelleyEra) v "transaction_witness_set" huddleRoundTripCborSpec @(TxWits ShelleyEra) v "transaction_witness_set" describe "DecCBOR instances equivalence via CDDL" $ do huddleDecoderEquivalenceSpec @BootstrapWitness v "bootstrap_witness" - huddleDecoderEquivalenceSpec @(TxBody ShelleyEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxBody TopTx ShelleyEra) v "transaction_body" huddleDecoderEquivalenceSpec @(TxAuxData ShelleyEra) v "transaction_metadata" huddleDecoderEquivalenceSpec @(MultiSig ShelleyEra) v "multisig_script" - huddleDecoderEquivalenceSpec @(Tx ShelleyEra) v "transaction" + huddleDecoderEquivalenceSpec @(Tx TopTx ShelleyEra) v "transaction" diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs index 41256a8d9da..c4c47dd301a 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs @@ -490,7 +490,7 @@ instance Arbitrary StakeProportion where newtype StakeProportion = StakeProportion Rational deriving (Show) -instance Arbitrary (TxBody ShelleyEra) where +instance Arbitrary (TxBody TopTx ShelleyEra) where arbitrary = ShelleyTxBody <$> arbitrary @@ -503,11 +503,11 @@ instance Arbitrary (TxBody ShelleyEra) where <*> arbitrary genTx :: - ( Arbitrary (TxBody era) + ( Arbitrary (TxBody TopTx era) , Arbitrary (TxAuxData era) , Arbitrary (TxWits era) ) => - Gen (ShelleyTx era) + Gen (ShelleyTx TopTx era) genTx = ShelleyTx <$> arbitrary @@ -699,17 +699,17 @@ instance instance ( EraTx era - , Arbitrary (TxBody era) + , Arbitrary (TxBody TopTx era) , Arbitrary (Value era) , Arbitrary (TxAuxData era) , Arbitrary (Script era) , Arbitrary (TxWits era) ) => - Arbitrary (ShelleyTx era) + Arbitrary (ShelleyTx TopTx era) where arbitrary = genTx -deriving newtype instance Arbitrary (Tx ShelleyEra) +deriving newtype instance Arbitrary (Tx TopTx ShelleyEra) instance ( Era era @@ -767,7 +767,7 @@ instance EncCBOR RawSeed where instance ( EraBlockBody era , BlockBody era ~ ShelleyBlockBody era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , SafeToHash (TxWits era) ) => Arbitrary (ShelleyBlockBody era) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/Annotator.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/Annotator.hs index 308fc883a71..7609d5760ce 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/Annotator.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/Annotator.hs @@ -20,9 +20,10 @@ import Cardano.Ledger.Binary import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes (decodeMemoized) -import Cardano.Ledger.Shelley (ShelleyEra, Tx (..)) +import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.BlockBody.Internal import Cardano.Ledger.Shelley.Scripts +import Cardano.Ledger.Shelley.Tx (ShelleyTx (..), Tx (..)) import Cardano.Ledger.Shelley.TxAuxData import Cardano.Ledger.Shelley.TxBody import Cardano.Ledger.Shelley.TxWits hiding (mapTraverseableDecoderA) @@ -38,7 +39,7 @@ import Test.Cardano.Ledger.Shelley.Arbitrary () instance ( EraTx era - , DecCBOR (TxBody era) + , DecCBOR (TxBody TopTx era) , DecCBOR (TxAuxData era) , DecCBOR (TxWits era) ) => @@ -73,9 +74,24 @@ instance hash = hashShelleySegWits bodiesBytes witsBytes auxDataBytes pure $ ShelleyBlockBodyInternal txs hash bodiesBytes witsBytes auxDataBytes -deriving newtype instance DecCBOR (TxBody ShelleyEra) +instance + ( Era era + , DecCBOR (TxBody TopTx era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTx TopTx era) + where + decCBOR = + decode $ + RecD ShelleyTx + DecCBOR (ShelleyTxAuxData era) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs index 7bb4c47b038..ebea81e73ef 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs @@ -79,7 +79,7 @@ import Test.Cardano.Ledger.Shelley.Arbitrary (RawSeed (..)) data LedgerExamples era = LedgerExamples { -- tx - leTx :: Tx era + leTx :: Tx TopTx era , leApplyTxError :: ApplyTxError era , -- protocol parameters lePParams :: PParams era @@ -102,7 +102,7 @@ deriving instance , Eq (PParams era) , Eq (PParamsUpdate era) , EraGov era - , Eq (Tx era) + , Eq (Tx TopTx era) , Eq (PredicateFailure (EraRule "LEDGER" era)) , Eq (StashedAVVMAddresses era) , Eq (TranslationContext era) @@ -131,9 +131,9 @@ mkLedgerExamples :: , Default (StashedAVVMAddresses era) , AtMostEra "Mary" era ) => - (TxBody era -> [KeyPair 'Witness] -> TxWits era) -> + (TxBody TopTx era -> [KeyPair 'Witness] -> TxWits era) -> Value era -> - TxBody era -> + TxBody TopTx era -> TxAuxData era -> TranslationContext era -> LedgerExamples era @@ -178,10 +178,10 @@ mkLedgerExamples exampleTx :: forall era. EraTx era => - (TxBody era -> [KeyPair 'Witness] -> TxWits era) -> - TxBody era -> + (TxBody TopTx era -> [KeyPair 'Witness] -> TxWits era) -> + TxBody TopTx era -> TxAuxData era -> - Tx era + Tx TopTx era exampleTx mkWitnesses txBody auxData = mkBasicTx @era txBody & witsTxL @@ -320,7 +320,7 @@ testShelleyGenesis = exampleCoin :: Coin exampleCoin = Coin 10 -exampleTxBodyShelley :: TxBody ShelleyEra +exampleTxBodyShelley :: TxBody TopTx ShelleyEra exampleTxBodyShelley = ShelleyTxBody exampleTxIns @@ -434,13 +434,13 @@ exampleByronAddress = AddrBootstrap (BootstrapAddress byronAddr) mkWitnessesPreAlonzo :: EraTx era => Proxy era -> - TxBody era -> + TxBody TopTx era -> [KeyPair 'Witness] -> ShelleyTxWits era mkWitnessesPreAlonzo _ txBody keyPairWits = mempty { addrWits = - mkWitnessesVKey (coerce (hashAnnotated txBody)) keyPairWits + mkWitnessesVKey (coerce (txIdTxBody txBody)) keyPairWits } -- | @mkKeyPair'@ from @Test.Cardano.Ledger.Shelley.Utils@ doesn't work for real diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index ae47aa1130e..dfb0c840828 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -425,7 +425,7 @@ class , -- For the LEDGER rule STS (EraRule "LEDGER" era) , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , Eq (PredicateFailure (EraRule "LEDGER" era)) @@ -503,7 +503,7 @@ class -- | Set of Witnesses that have already been satisfied Set.Set (KeyHash 'Witness) -> -- | The transaction body that the script will be applied to - TxBody era -> + TxBody l era -> NativeScript era -> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))) @@ -521,9 +521,9 @@ class SpecWith (ImpInit (LedgerSpec era)) -> SpecWith (ImpInit (LedgerSpec era)) - fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era) + fixupTx :: HasCallStack => Tx TopTx era -> ImpTestM era (Tx TopTx era) - expectTxSuccess :: HasCallStack => Tx era -> ImpTestM era () + expectTxSuccess :: HasCallStack => Tx TopTx era -> ImpTestM era () genRegTxCert :: Credential 'Staking -> ImpTestM era (TxCert era) @@ -547,7 +547,7 @@ impSatisfyMNativeScripts :: ShelleyEraImp era => Set.Set (KeyHash 'Witness) -> -- | Set of Witnesses that have already been satisfied - TxBody era -> + TxBody l era -> -- | The transaction body that the scripts will be applied to Int -> -- | Number of scripts to satisfy @@ -832,7 +832,7 @@ instance -- KeyHashes for Shelley Key witnesses that are required. impWitsVKeyNeeded :: EraUTxO era => - TxBody era -> + TxBody l era -> ImpTestM era ( Set.Set BootstrapAddress -- Byron Based Addresses @@ -851,7 +851,7 @@ impWitsVKeyNeeded txBody = do pure (bootAddrs, allKeyHashes Set.\\ bootKeyHashes) data ImpTestEnv era = ImpTestEnv - { iteFixup :: Tx era -> ImpTestM era (Tx era) + { iteFixup :: Tx TopTx era -> ImpTestM era (Tx TopTx era) , itePostSubmitTxHook :: forall t. Globals -> @@ -868,7 +868,7 @@ data ImpTestEnv era = ImpTestEnv ImpM t () } -iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era)) +iteFixupL :: Lens' (ImpTestEnv era) (Tx TopTx era -> ImpTestM era (Tx TopTx era)) iteFixupL = lens iteFixup (\x y -> x {iteFixup = y}) itePostSubmitTxHookL :: @@ -976,7 +976,7 @@ impAddNativeScript nativeScript = do impNativeScriptsRequired :: EraUTxO era => - Tx era -> + Tx l era -> ImpTestM era (Map ScriptHash (NativeScript era)) impNativeScriptsRequired tx = do utxo <- getUTxO @@ -988,8 +988,8 @@ impNativeScriptsRequired tx = do -- | Modifies transaction by adding necessary scripts addNativeScriptTxWits :: ShelleyEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) addNativeScriptTxWits tx = impAnn "addNativeScriptTxWits" $ do scriptsRequired <- impNativeScriptsRequired tx utxo <- getUTxO @@ -1004,8 +1004,8 @@ updateAddrTxWits :: ( HasCallStack , ShelleyEraImp era ) => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do let txBody = tx ^. bodyTxL txBodyHash = hashAnnotated txBody @@ -1040,8 +1040,8 @@ updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do -- | This fixup step ensures that there are enough funds in the transaction. addRootTxIn :: ShelleyEraImp era => - Tx era -> - ImpTestM era (Tx era) + Tx l era -> + ImpTestM era (Tx l era) addRootTxIn tx = impAnn "addRootTxIn" $ do rootTxIn <- fst <$> getImpRootTxOut pure $ @@ -1050,10 +1050,8 @@ addRootTxIn tx = impAnn "addRootTxIn" $ do impNativeScriptKeyPairs :: ShelleyEraImp era => - Tx era -> - ImpTestM - era - (Map (KeyHash 'Witness) (KeyPair 'Witness)) + Tx l era -> + ImpTestM era (Map (KeyHash 'Witness) (KeyPair 'Witness)) impNativeScriptKeyPairs tx = do scriptsRequired <- impNativeScriptsRequired tx let nativeScripts = Map.elems scriptsRequired @@ -1061,7 +1059,7 @@ impNativeScriptKeyPairs tx = do keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts pure . mconcat $ catMaybes keyPairs -fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era) +fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx TopTx era -> ImpTestM era (Tx TopTx era) fixupTxOuts tx = do pp <- getsNES $ nesEsL . curPParamsEpochStateL let @@ -1080,8 +1078,8 @@ fixupTxOuts tx = do fixupFees :: (ShelleyEraImp era, HasCallStack) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) fixupFees txOriginal = impAnn "fixupFees" $ do -- Fee will be overwritten later on, unless it wasn't set to zero to begin with: let tx = txOriginal & bodyTxL . feeTxBodyL .~ zero @@ -1130,7 +1128,7 @@ fixupFees txOriginal = impAnn "fixupFees" $ do pure txWithFee -- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not. -fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era) +fixupAuxDataHash :: (EraTx era, Applicative m) => Tx l era -> m (Tx l era) fixupAuxDataHash tx | SNothing <- tx ^. bodyTxL . auxDataHashTxBodyL , SJust auxData <- tx ^. auxDataTxL = @@ -1140,8 +1138,8 @@ fixupAuxDataHash tx shelleyFixupTx :: forall era. (ShelleyEraImp era, HasCallStack) => - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) shelleyFixupTx = addNativeScriptTxWits >=> fixupAuxDataHash @@ -1154,7 +1152,7 @@ shelleyFixupTx = impShelleyExpectTxSuccess :: forall era. (ShelleyEraImp era, HasCallStack) => - Tx era -> + Tx TopTx era -> ImpTestM era () impShelleyExpectTxSuccess tx = do utxo <- getsNES utxoL @@ -1165,7 +1163,7 @@ impShelleyExpectTxSuccess tx = do impAnn "Outputs should be in UTxO" $ expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs] -logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era () +logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx TopTx era -> ImpTestM era () logFeeMismatch tx = do pp <- getsNES $ nesEsL . curPParamsEpochStateL utxo <- getsNES utxoL @@ -1175,10 +1173,10 @@ logFeeMismatch tx = do logDoc $ "Estimated fee " <> ansiExpr feeUsed <> " while required fee is " <> ansiExpr feeMin -submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () +submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx TopTx era -> ImpTestM era () submitTx_ = void . submitTx -submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era) +submitTx :: (HasCallStack, ShelleyEraImp era) => Tx TopTx era -> ImpTestM era (Tx TopTx era) submitTx tx = trySubmitTx tx >>= expectRightDeepExpr . first fst trySubmitTx :: @@ -1186,8 +1184,10 @@ trySubmitTx :: ( ShelleyEraImp era , HasCallStack ) => - Tx era -> - ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era)) + Tx TopTx era -> + ImpTestM + era + (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era)) trySubmitTx tx = do txFixed <- asks iteFixup >>= ($ tx) logToExpr txFixed @@ -1233,7 +1233,7 @@ submitFailingTx :: ( HasCallStack , ShelleyEraImp era ) => - Tx era -> + Tx TopTx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx tx = submitFailingTxM tx . const . pure @@ -1245,8 +1245,8 @@ submitFailingTxM :: ( HasCallStack , ShelleyEraImp era ) => - Tx era -> - (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) -> + Tx TopTx era -> + (Tx TopTx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) -> ImpTestM era () submitFailingTxM tx mkExpectedFailures = do (predFailures, fixedUpTx) <- expectLeftDeepExpr =<< trySubmitTx tx @@ -1570,12 +1570,12 @@ getProtVer = getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL submitTxAnn :: (HasCallStack, ShelleyEraImp era) => String -> - Tx era -> - ImpTestM era (Tx era) + Tx TopTx era -> + ImpTestM era (Tx TopTx era) submitTxAnn msg tx = impAnn msg (trySubmitTx tx >>= expectRightDeepExpr) submitTxAnn_ :: - (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () + (HasCallStack, ShelleyEraImp era) => String -> Tx TopTx era -> ImpTestM era () submitTxAnn_ msg = void . submitTxAnn msg getRewardAccountFor :: @@ -1727,14 +1727,14 @@ registerAndRetirePoolToMakeReward stakingCred = do -- | Compose given function with the configured fixup withCustomFixup :: - ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) -> + ((Tx TopTx era -> ImpTestM era (Tx TopTx era)) -> Tx TopTx era -> ImpTestM era (Tx TopTx era)) -> ImpTestM era a -> ImpTestM era a withCustomFixup f = local $ iteFixupL %~ f -- | Replace all fixup with the given function withFixup :: - (Tx era -> ImpTestM era (Tx era)) -> + (Tx TopTx era -> ImpTestM era (Tx TopTx era)) -> ImpTestM era a -> ImpTestM era a withFixup f = withCustomFixup (const f) @@ -1745,14 +1745,14 @@ withNoFixup = withFixup pure -- | Apply given fixup function before the configured fixup withPreFixup :: - (Tx era -> ImpTestM era (Tx era)) -> + (Tx TopTx era -> ImpTestM era (Tx TopTx era)) -> ImpTestM era a -> ImpTestM era a withPreFixup f = withCustomFixup (f >=>) -- | Apply given fixup function after the configured fixup withPostFixup :: - (Tx era -> ImpTestM era (Tx era)) -> + (Tx TopTx era -> ImpTestM era (Tx TopTx era)) -> ImpTestM era a -> ImpTestM era a withPostFixup f = withCustomFixup (>=> f) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs index 6af354ed4a7..ac672f3ec32 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -27,6 +28,7 @@ import Cardano.Ledger.Shelley.TxCert import Cardano.Ledger.Shelley.TxOut import Cardano.Ledger.Shelley.TxWits import Cardano.Ledger.Shelley.UTxO +import Data.TreeDiff.OMap as OMap import Test.Cardano.Ledger.TreeDiff -- PParams @@ -88,9 +90,21 @@ instance (EraTxOut era, ToExpr (Value era)) => ToExpr (ShelleyTxOut era) where toExpr (ShelleyTxOut x y) = App "ShelleyTxOut" [toExpr x, toExpr y] -- TxBody -instance ToExpr ShelleyTxBodyRaw - -instance ToExpr (TxBody ShelleyEra) +instance ToExpr (ShelleyTxBodyRaw TopTx ShelleyEra) where + toExpr ShelleyTxBodyRaw {..} = + Rec "ShelleyTxBodyRaw" $ + OMap.fromList + [ ("inputs", toExpr stbrInputs) + , ("outputs", toExpr stbrOutputs) + , ("certs", toExpr stbrCerts) + , ("withdrawals", toExpr stbrWithdrawals) + , ("fee", toExpr stbrFee) + , ("ttl", toExpr stbrTtl) + , ("update", toExpr stbrUpdate) + , ("auxDataHash", toExpr stbrAuxDataHash) + ] + +instance ToExpr (TxBody TopTx ShelleyEra) -- PoolRank instance ToExpr Likelihood @@ -101,10 +115,18 @@ instance ToExpr NonMyopic instance ( ToExpr (TxAuxData era) - , ToExpr (TxBody era) + , ToExpr (TxBody TopTx era) , ToExpr (TxWits era) ) => - ToExpr (ShelleyTx era) + ToExpr (ShelleyTx TopTx era) + where + toExpr ShelleyTx {..} = + Rec "ShelleyTx" $ + OMap.fromList + [ ("body", toExpr stBody) + , ("wits", toExpr stWits) + , ("auxData", toExpr stAuxData) + ] -- RewardUpdate @@ -295,4 +317,4 @@ instance ToExpr (State (EraRule "LEDGERS" era)) => ToExpr (ShelleyBbodyState era) -instance ToExpr (Tx ShelleyEra) +instance ToExpr (Tx TopTx ShelleyEra) diff --git a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs index 5612114f8d4..770882dae63 100644 --- a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs +++ b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs @@ -113,7 +113,7 @@ genTriple :: ) => Proxy era -> Int -> - IO (GenEnv MockCrypto era, ChainState era, GenEnv MockCrypto era -> IO (Tx era)) + IO (GenEnv MockCrypto era, ChainState era, GenEnv MockCrypto era -> IO (Tx TopTx era)) genTriple proxy n = do let ge = genEnv proxy defaultConstants cs <- genChainState n ge diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs index b63ddbb8b91..7206a8d6fe7 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs @@ -129,7 +129,7 @@ ledgerEnv = LedgerEnv (SlotNo 0) Nothing minBound ppsBench (ChainAccountState (C testLEDGER :: LedgerState ShelleyEra -> - Tx ShelleyEra -> + Tx TopTx ShelleyEra -> LedgerEnv ShelleyEra -> () testLEDGER initSt tx env = do @@ -138,7 +138,7 @@ testLEDGER initSt tx env = do Right _ -> () Left e -> error $ show e -txbSpendOneUTxO :: TxBody ShelleyEra +txbSpendOneUTxO :: TxBody TopTx ShelleyEra txbSpendOneUTxO = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -154,7 +154,7 @@ txbSpendOneUTxO = SNothing SNothing -txSpendOneUTxO :: Tx ShelleyEra +txSpendOneUTxO :: Tx TopTx ShelleyEra txSpendOneUTxO = mkBasicTx txbSpendOneUTxO & witsTxL @@ -194,7 +194,7 @@ stakeKeyRegistrations keys = -- Create a transaction body given a sequence of certificates. -- It spends the genesis coin given by the index ix. -txbFromCerts :: TxIx -> StrictSeq (TxCert ShelleyEra) -> TxBody ShelleyEra +txbFromCerts :: TxIx -> StrictSeq (TxCert ShelleyEra) -> TxBody TopTx ShelleyEra txbFromCerts ix regCerts = ShelleyTxBody (Set.fromList [TxIn genesisId ix]) @@ -207,9 +207,9 @@ txbFromCerts ix regCerts = SNothing makeSimpleTx :: - TxBody ShelleyEra -> + TxBody TopTx ShelleyEra -> [KeyPair 'Witness] -> - Tx ShelleyEra + Tx TopTx ShelleyEra makeSimpleTx txbody keysAddr = mkBasicTx mkBasicTxBody & bodyTxL .~ txbody @@ -217,7 +217,7 @@ makeSimpleTx txbody keysAddr = & auxDataTxL .~ SNothing -- Create a transaction that registers stake credentials. -txRegStakeKeys :: TxIx -> [KeyPair 'Staking] -> Tx ShelleyEra +txRegStakeKeys :: TxIx -> [KeyPair 'Staking] -> Tx TopTx ShelleyEra txRegStakeKeys ix keys = makeSimpleTx (txbFromCerts ix $ stakeKeyRegistrations keys) @@ -227,7 +227,7 @@ initLedgerState :: Integer -> LedgerState ShelleyEra initLedgerState n = LedgerState (initUTxO n) def makeLEDGERState :: - HasCallStack => LedgerState ShelleyEra -> Tx ShelleyEra -> LedgerState ShelleyEra + HasCallStack => LedgerState ShelleyEra -> Tx TopTx ShelleyEra -> LedgerState ShelleyEra makeLEDGERState start tx = let st = applySTS @(ShelleyLEDGER ShelleyEra) (TRC (ledgerEnv, start, tx)) in case runShelleyBase st of @@ -260,7 +260,7 @@ ledgerRegisterStakeKeys x y state = -- Create a transaction body that de-registers stake credentials, -- corresponding to the keys seeded with (RawSeed x 0 0 0 0) to (RawSeed y 0 0 0 0) -txbDeRegStakeKey :: Word64 -> Word64 -> TxBody ShelleyEra +txbDeRegStakeKey :: Word64 -> Word64 -> TxBody TopTx ShelleyEra txbDeRegStakeKey x y = ShelleyTxBody (Set.fromList [mkTxInPartial genesisId 1]) @@ -276,7 +276,7 @@ txbDeRegStakeKey x y = -- Create a transaction that deregisters stake credentials numbered x through y. -- It spends the genesis coin indexed by 1. -txDeRegStakeKeys :: Word64 -> Word64 -> Tx ShelleyEra +txDeRegStakeKeys :: Word64 -> Word64 -> Tx TopTx ShelleyEra txDeRegStakeKeys x y = makeSimpleTx (txbDeRegStakeKey x y) @@ -298,7 +298,7 @@ ledgerDeRegisterStakeKeys x y state = -- Create a transaction body that withdrawals from reward accounts, -- corresponding to the keys seeded with (RawSeed x 0 0 0 0) to (RawSeed y 0 0 0 0). -txbWithdrawals :: Word64 -> Word64 -> TxBody ShelleyEra +txbWithdrawals :: Word64 -> Word64 -> TxBody TopTx ShelleyEra txbWithdrawals x y = ShelleyTxBody (Set.fromList [mkTxInPartial genesisId 1]) @@ -315,7 +315,7 @@ txbWithdrawals x y = -- Create a transaction that withdrawals from a reward accounts. -- It spends the genesis coin indexed by 1. -txWithdrawals :: Word64 -> Word64 -> Tx ShelleyEra +txWithdrawals :: Word64 -> Word64 -> Tx TopTx ShelleyEra txWithdrawals x y = makeSimpleTx (txbWithdrawals x y) @@ -369,7 +369,7 @@ poolRegCerts :: [KeyPair 'StakePool] -> StrictSeq (TxCert ShelleyEra) poolRegCerts = StrictSeq.fromList . fmap (RegPoolTxCert . mkStakePoolParams) -- Create a transaction that registers stake pools. -txRegStakePools :: TxIx -> [KeyPair 'StakePool] -> Tx ShelleyEra +txRegStakePools :: TxIx -> [KeyPair 'StakePool] -> Tx TopTx ShelleyEra txRegStakePools ix keys = makeSimpleTx (txbFromCerts ix $ poolRegCerts keys) @@ -415,7 +415,7 @@ ledgerReRegisterStakePools x y state = -- Create a transaction body that retires stake pools, -- corresponding to the keys seeded with (RawSeed x 1 0 0 0) to (RawSeed y 1 0 0 0) -txbRetireStakePool :: Word64 -> Word64 -> TxBody ShelleyEra +txbRetireStakePool :: Word64 -> Word64 -> TxBody TopTx ShelleyEra txbRetireStakePool x y = ShelleyTxBody (Set.fromList [mkTxInPartial genesisId 1]) @@ -433,7 +433,7 @@ txbRetireStakePool x y = -- Create a transaction that retires stake pools x through y. -- It spends the genesis coin indexed by 1. -txRetireStakePool :: Word64 -> Word64 -> Tx ShelleyEra +txRetireStakePool :: Word64 -> Word64 -> Tx TopTx ShelleyEra txRetireStakePool x y = makeSimpleTx (txbRetireStakePool x y) @@ -463,7 +463,7 @@ ledgerStateWithNkeysMpools n m = -- Create a transaction body that delegates several keys to ONE stake pool, -- corresponding to the keys seeded with (RawSeed n 0 0 0 0) to (RawSeed m 0 0 0 0) -txbDelegate :: Word64 -> Word64 -> TxBody ShelleyEra +txbDelegate :: Word64 -> Word64 -> TxBody TopTx ShelleyEra txbDelegate n m = ShelleyTxBody (Set.fromList [mkTxInPartial genesisId 2]) @@ -480,7 +480,7 @@ txbDelegate n m = SNothing -- Create a transaction that delegates stake. -txDelegate :: Word64 -> Word64 -> Tx ShelleyEra +txDelegate :: Word64 -> Word64 -> Tx TopTx ShelleyEra txDelegate n m = makeSimpleTx (txbDelegate n m) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index 9e62b47773e..ef276d00be8 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -81,7 +81,7 @@ type TxGen era = ChainAccountState -> LedgerState era -> SlotNo -> - Gen (Seq (Tx era)) + Gen (Seq (Tx TopTx era)) -- | Generate a valid block. genBlock :: diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs index b9e4730cdc3..03c2d01e647 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs @@ -113,12 +113,12 @@ import Test.QuickCheck (Gen, choose, shuffle) type MinLEDGER_STS era = ( Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase , State (EraRule "LEDGERS" era) ~ LedgerState era - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , STS (EraRule "LEDGER" era) ) @@ -137,10 +137,10 @@ type MinUTXO_STS era = , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , State (EraRule "UTXOW" era) ~ UTxOState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , State (EraRule "UTXO" era) ~ UTxOState era , Environment (EraRule "UTXO" era) ~ UtxoEnv era - , Signal (EraRule "UTXO" era) ~ Tx era + , Signal (EraRule "UTXO" era) ~ Tx TopTx era ) class Show (TxOut era) => MinGenTxout era where @@ -190,7 +190,7 @@ class Coin -> StrictMaybe (Update era) -> StrictMaybe TxAuxDataHash -> - Gen (TxBody era, [Script era]) + Gen (TxBody TopTx era, [Script era]) -- | Generate era-specific auxiliary data genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData era)) @@ -200,17 +200,17 @@ class UTxO era -> PParams era -> TxWits era -> - TxBody era -> + TxBody TopTx era -> Coin -> -- | This overrides the existing TxFee Set TxIn -> -- | This is to be Unioned with the existing TxIn TxOut era -> -- | This is to be Appended to the end of the existing TxOut - TxBody era + TxBody TopTx era -- | Union the TxIn with the existing TxIn in the TxBody - addInputs :: TxBody era -> Set TxIn -> TxBody era + addInputs :: TxBody TopTx era -> Set TxIn -> TxBody TopTx era addInputs txb _ins = txb genEraPParamsUpdate :: Constants -> PParams era -> Gen (PParamsUpdate era) @@ -222,7 +222,7 @@ class -- use Test.Cardano.Ledger.Shelley.Generator.Update(genDecentralisationParam) in your instance. genEraTxWits :: - (UTxO era, TxBody era, ScriptInfo era) -> + (UTxO era, TxBody TopTx era, ScriptInfo era) -> Set (WitVKey 'Witness) -> Map ScriptHash (Script era) -> TxWits era @@ -233,10 +233,10 @@ class -- | Construct a transaction given its constituent parts. constructTx :: - TxBody era -> + TxBody TopTx era -> TxWits era -> StrictMaybe (TxAuxData era) -> - Tx era + Tx TopTx era constructTx txBody txWits txAuxData = mkBasicTx txBody & witsTxL .~ txWits & auxDataTxL .~ txAuxData @@ -246,18 +246,18 @@ class -- | A final opportunity to tweak things when the generator is done. Possible uses -- 1) Add tracing when debugging on a per Era basis - genEraDone :: UTxO era -> PParams era -> Tx era -> Gen (Tx era) + genEraDone :: UTxO era -> PParams era -> Tx TopTx era -> Gen (Tx TopTx era) genEraDone _utxo _pp x = pure x -- | A final opportunity to tweak things at the block level. Possible uses -- 2) Run a test that might decide to 'discard' the test, because we got unlucky, and a rare unfixible condition has occurred. - genEraTweakBlock :: PParams era -> Seq (Tx era) -> Gen (Seq (Tx era)) + genEraTweakBlock :: PParams era -> Seq (Tx TopTx era) -> Gen (Seq (Tx TopTx era)) genEraTweakBlock _pp seqTx = pure seqTx - hasFailedScripts :: Tx era -> Bool + hasFailedScripts :: Tx TopTx era -> Bool hasFailedScripts = const False - feeOrCollateral :: Tx era -> UTxO era -> Coin + feeOrCollateral :: Tx TopTx era -> UTxO era -> Coin feeOrCollateral tx _ = tx ^. bodyTxL . feeTxBodyL {------------------------------------------------------------------------------ @@ -321,7 +321,7 @@ allScripts c = -- ========================================================= data Label t where - Body' :: Label (TxBody era) + Body' :: Label (TxBody TopTx era) Wits' :: Label (TxWits era) class Sets (x :: Label t) y where diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/ShelleyEraGen.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/ShelleyEraGen.hs index fbf58aa8b88..1c02a13eca4 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/ShelleyEraGen.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/ShelleyEraGen.hs @@ -108,7 +108,7 @@ genTxBody :: Coin -> StrictMaybe (Update ShelleyEra) -> StrictMaybe TxAuxDataHash -> - Gen (TxBody ShelleyEra, [MultiSig ShelleyEra]) + Gen (TxBody TopTx ShelleyEra, [MultiSig ShelleyEra]) genTxBody _pparams slot inputs outputs certs withdrawals fee update adHash = do ttl <- genTimeToLive slot return diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs index 233ef0bc776..46466866f38 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs @@ -87,7 +87,7 @@ instance , Embed (EraRule "UTXOW" era) (ShelleyLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "UTXOW" era) ~ Tx TopTx era , Environment (EraRule "DELEGS" era) ~ DelegsEnv era , State (EraRule "DELEGS" era) ~ CertState era , Signal (EraRule "DELEGS" era) ~ Seq (TxCert era) @@ -149,9 +149,9 @@ instance where genAndApplyTx :: HasCallStack => - (LedgerState era, [Tx era]) -> + (LedgerState era, [Tx TopTx era]) -> TxIx -> - Gen (LedgerState era, [Tx era]) + Gen (LedgerState era, [Tx TopTx era]) genAndApplyTx (ls', txs) txIx = do let ledgerEnv = LedgerEnv slotNo (Just epochNo) txIx pParams reserves tx <- genTx ge ledgerEnv ls' diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs index 071b35fcd7e..dd8adef138b 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs @@ -119,7 +119,7 @@ genTx :: GenEnv c era -> LedgerEnv era -> LedgerState era -> - Gen (Tx era) + Gen (Tx TopTx era) genTx ge@( GenEnv keySpace@KeySpace_ @@ -354,7 +354,7 @@ genNextDelta :: UTxO era -> PParams era -> KeySpace c era -> - Tx era -> + Tx TopTx era -> Int -> Delta era -> Gen (Delta era) @@ -475,7 +475,7 @@ genNextDeltaTilFixPoint :: UTxO era -> PParams era -> KeySpace c era -> - Tx era -> + Tx TopTx era -> Gen (Delta era) genNextDeltaTilFixPoint scriptinfo initialfee keys scripts utxo pparams keySpace tx = do addrs <- genRecipients @era 1 keys scripts @@ -494,9 +494,9 @@ applyDelta :: [KeyPair 'Witness] -> Map ScriptHash (Script era) -> KeySpace c era -> - Tx era -> + Tx TopTx era -> Delta era -> - Tx era + Tx TopTx era applyDelta utxo scriptinfo @@ -553,8 +553,8 @@ converge :: UTxO era -> PParams era -> KeySpace c era -> - Tx era -> - Gen (Tx era) + Tx TopTx era -> + Gen (Tx TopTx era) converge scriptinfo initialfee @@ -642,7 +642,7 @@ mkScriptWits payScripts stakeScripts = mkTxWits :: forall era. EraGen era => - (UTxO era, TxBody era, ScriptInfo era) -> + (UTxO era, TxBody TopTx era, ScriptInfo era) -> Map (KeyHash 'Payment) (KeyPair 'Payment) -> Map (KeyHash 'Staking) (KeyPair 'Staking) -> [KeyPair 'Witness] -> diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs index 764738a1295..ff32841386c 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs @@ -68,7 +68,7 @@ commonTests :: , State (EraRule "TICKN" era) ~ TicknState , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , Environment (EraRule "TICKN" era) ~ TicknEnv - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , Signal (EraRule "TICKN" era) ~ Bool , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase , AtMostEra "Alonzo" era @@ -82,7 +82,7 @@ commonTests :: , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , Environment (EraRule "TICK" era) ~ () - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGERS" era) ~ LedgerState era , Environment (EraRule "BBODY" era) ~ BbodyEnv era , Signal (EraRule "TICK" era) ~ SlotNo diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index 03ec7389b48..5794b976a5e 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -99,7 +99,7 @@ tests :: , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era) , GovState era ~ ShelleyGovState era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , STS (EraRule "LEDGER" era) @@ -120,7 +120,7 @@ adaPreservationProps :: , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era) , GovState era ~ ShelleyGovState era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , STS (EraRule "LEDGER" era) @@ -282,7 +282,7 @@ checkPreservation SourceSignalTarget {source, target, signal = block} count = "\n\n******** Transaction " ++ show ix ++ " " - ++ show (hashAnnotated (tx ^. bodyTxL)) + ++ show (hashAnnotated @_ @EraIndependentTxBody (tx ^. bodyTxL)) ++ "\nfee :" ++ show (tx ^. bodyTxL . feeTxBodyL) ++ "\nwithdrawals:" @@ -312,7 +312,7 @@ utxoDepositsIncreaseByFeesWithdrawals :: forall era. ( ChainProperty era , EraGen era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era @@ -356,7 +356,7 @@ potsSumIncreaseWithdrawalsPerTx :: ( ChainProperty era , EraGen era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , STS (EraRule "LEDGER" era) @@ -388,7 +388,7 @@ potsSumIncreaseByRewardsPerTx :: ( ChainProperty era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , STS (EraRule "LEDGER" era) ) => @@ -423,7 +423,7 @@ potsRewardsDecreaseByWithdrawalsPerTx :: , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , STS (EraRule "LEDGER" era) ) => SourceSignalTarget (CHAIN era) -> @@ -462,7 +462,7 @@ preserveBalance :: forall era. ( ChainProperty era , EraGen era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era @@ -503,7 +503,7 @@ preserveBalanceRestricted :: ( ChainProperty era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , STS (EraRule "LEDGER" era) ) => @@ -541,7 +541,7 @@ preserveOutputsTx :: , EraGen era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , STS (EraRule "LEDGER" era) ) => @@ -567,7 +567,7 @@ preserveOutputsTx SourceSignalTarget {source = chainSt, signal = block} = canRestrictUTxO :: forall era. ( ChainProperty era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era @@ -612,14 +612,14 @@ withdrawals (Block _ blockBody) = txFees :: forall era. ( EraGen era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era ) => Trace (EraRule "LEDGER" era) -> Coin txFees ledgerTr = foldMap - (\sst -> feeOrCollateral @era (signal sst :: Tx era) (source sst ^. utxoL :: UTxO era)) + (\sst -> feeOrCollateral @era (signal sst :: Tx TopTx era) (source sst ^. utxoL :: UTxO era)) (sourceSignalTargets ledgerTr) -- | Check that deposits are always non-negative diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs index 21bc3024aca..743dbd8b022 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs @@ -136,7 +136,7 @@ relevantCasesAreCoveredForTrace :: Trace (CHAIN era) -> Property relevantCasesAreCoveredForTrace tr = do - let blockTxs :: Block (BHeader MockCrypto) era -> [Tx era] + let blockTxs :: Block (BHeader MockCrypto) era -> [Tx TopTx era] blockTxs Block {blockBody} = toList $ blockBody ^. txSeqBlockBodyL bs = traceSignals OldestFirst tr txs = concatMap blockTxs bs @@ -258,7 +258,7 @@ certsByTx :: ( ShelleyEraTxBody era , EraTx era ) => - [Tx era] -> + [Tx TopTx era] -> [[TxCert era]] certsByTx txs = toList . view certsTxBodyL . view bodyTxL <$> txs @@ -286,16 +286,16 @@ txScriptOutputsRatio txoutsList = _ -> Sum 0 ) -hasWithdrawal :: (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool +hasWithdrawal :: (ShelleyEraTxBody era, EraTx era) => Tx TopTx era -> Bool hasWithdrawal tx = not . null $ unWithdrawals (tx ^. bodyTxL . withdrawalsTxBodyL) -hasPParamUpdate :: (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool +hasPParamUpdate :: (ShelleyEraTxBody era, EraTx era) => Tx TopTx era -> Bool hasPParamUpdate tx = ppUpdates (tx ^. bodyTxL . updateTxBodyL) where ppUpdates SNothing = False ppUpdates (SJust (Update (ProposedPPUpdates ppUpd) _)) = Map.size ppUpd > 0 -hasMetadata :: EraTx era => Tx era -> Bool +hasMetadata :: EraTx era => Tx TopTx era -> Bool hasMetadata tx = f (tx ^. bodyTxL . auxDataHashTxBodyL) where f SNothing = False @@ -348,7 +348,7 @@ propAbstractSizeBoundsBytes = property $ do (genEnv @era @MockCrypto p defaultConstants) genesisLedgerSt $ \tr -> do - let txs :: [Tx era] + let txs :: [Tx TopTx era] txs = traceSignals OldestFirst tr all (\tx -> txSizeBound tx >= numBytes tx) txs where @@ -382,7 +382,7 @@ propAbstractSizeNotTooBig = property $ do (genEnv @era @MockCrypto p defaultConstants) genesisLedgerSt $ \tr -> do - let txs :: [Tx era] + let txs :: [Tx TopTx era] txs = traceSignals OldestFirst tr all notTooBig txs where @@ -433,7 +433,7 @@ epochsInTrace bs' txSizeBound :: forall era. EraTx era => - Tx era -> + Tx TopTx era -> Integer txSizeBound tx = numInputs * inputSize + numOutputs * outputSize + toInteger rest where diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs index 3fda07e1caa..de39a7e8a98 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs @@ -69,7 +69,7 @@ tests :: , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era) , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , STS (EraRule "LEDGER" era) ) => TestTree @@ -94,7 +94,7 @@ eliminateTxInputs :: , EraGen era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , STS (EraRule "LEDGER" era) ) => @@ -124,7 +124,7 @@ newEntriesAndUniqueTxIns :: , EraGen era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , STS (EraRule "LEDGER" era) ) => @@ -157,7 +157,7 @@ requiredMSigSignaturesSubset :: forall era. ( ChainProperty era , EraGen era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era @@ -180,7 +180,7 @@ requiredMSigSignaturesSubset SourceSignalTarget {source = chainSt, signal = bloc existsReqKeyComb keyHashes msig = any (\kl -> Set.fromList kl `Set.isSubsetOf` keyHashes) (scriptKeyCombinations (Proxy @era) msig) - keyHashSet :: Tx era -> Set (KeyHash 'Witness) + keyHashSet :: Tx TopTx era -> Set (KeyHash 'Witness) keyHashSet tx_ = Set.map witVKeyHash (tx_ ^. witsTxL . addrTxWitsL) @@ -196,10 +196,10 @@ noDoubleSpend SourceSignalTarget {signal = block} = where txs = toList $ blockBody block ^. txSeqBlockBodyL - getDoubleInputs :: [Tx era] -> [(Tx era, [Tx era])] + getDoubleInputs :: [Tx TopTx era] -> [(Tx TopTx era, [Tx TopTx era])] getDoubleInputs [] = [] getDoubleInputs (t : ts) = lookForDoubleSpends t ts ++ getDoubleInputs ts - lookForDoubleSpends :: Tx era -> [Tx era] -> [(Tx era, [Tx era])] + lookForDoubleSpends :: Tx TopTx era -> [Tx TopTx era] -> [(Tx TopTx era, [Tx TopTx era])] lookForDoubleSpends _ [] = [] lookForDoubleSpends tx_j ts = [(tx_j, doubles) | not (null doubles)] diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs index 7bd0b16c726..cee31a9d5d7 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs @@ -81,7 +81,7 @@ incrStakeComputationTest :: , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity , STS (EraRule "LEDGER" era) - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era ) => TestTree @@ -97,7 +97,7 @@ incrStakeComp :: , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , STS (EraRule "LEDGER" era) - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , ShelleyEraAccounts era ) => diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index feb95dcec54..6a8f6e45065 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -144,7 +144,7 @@ ledgerTraceFromBlock :: , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era ) => ChainState era -> Block (BHeader MockCrypto) era -> @@ -167,7 +167,7 @@ ledgerTraceFromBlockWithRestrictedUTxO :: , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era ) => ChainState era -> Block (BHeader MockCrypto) era -> @@ -251,7 +251,7 @@ ledgerTraceBase :: ) => ChainState era -> Block (BHeader MockCrypto) era -> - (ChainState era, LedgerEnv era, LedgerState era, [Tx era]) + (ChainState era, LedgerEnv era, LedgerState era, [Tx TopTx era]) ledgerTraceBase chainSt Block {blockHeader = BHeader bhb _, blockBody} = ( tickedChainSt , LedgerEnv slot Nothing minBound pp_ (esChainAccountState nes) diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs index e9de22d7960..4a932f6c61f 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs @@ -159,7 +159,7 @@ addFees newFees cs = cs {chainNes = nes} newUTxO :: forall era. (EraTx era, EraStake era) => - TxBody era -> + TxBody TopTx era -> ChainState era -> ChainState era newUTxO txb cs = cs {chainNes = nes'} diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/GenesisDelegation.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/GenesisDelegation.hs index 49e4aba5657..5afa31f954b 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/GenesisDelegation.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/GenesisDelegation.hs @@ -106,7 +106,7 @@ newGenesisVrfKH = hashVerKeyVRF @MockCrypto (vrfVerKey (mkVRFKeyPair @MockCrypto feeTx1 :: Coin feeTx1 = Coin 1 -txbodyEx1 :: TxBody ShelleyEra +txbodyEx1 :: TxBody TopTx ShelleyEra txbodyEx1 = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -127,7 +127,7 @@ txbodyEx1 = aliceCoinEx1 = aliceInitCoin <-> Val.inject feeTx1 aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 -txEx1 :: ShelleyTx ShelleyEra +txEx1 :: ShelleyTx TopTx ShelleyEra txEx1 = ShelleyTx txbodyEx1 txwits SNothing where txwits :: ShelleyTxWits ShelleyEra diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs index d442587406f..d9f7e30b9bc 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs @@ -107,7 +107,7 @@ ir = StakeAddressesMIR $ Map.fromList [(Cast.aliceSHK, toDeltaCoin aliceMIRCoin) feeTx1 :: Coin feeTx1 = Coin 1 -txbodyEx1 :: MIRPot -> TxBody ShelleyEra +txbodyEx1 :: MIRPot -> TxBody TopTx ShelleyEra txbodyEx1 pot = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -135,7 +135,7 @@ sufficientMIRWits = mirWits [0 .. 4] insufficientMIRWits :: [KeyPair 'Witness] insufficientMIRWits = mirWits [0 .. 3] -txEx1 :: [KeyPair 'Witness] -> MIRPot -> ShelleyTx ShelleyEra +txEx1 :: [KeyPair 'Witness] -> MIRPot -> ShelleyTx TopTx ShelleyEra txEx1 txwits pot = ShelleyTx (txbodyEx1 pot) diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs index bb5d2188723..d9c1fd29e41 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs @@ -167,7 +167,7 @@ dariaMIR = Coin 99 feeTx1 :: Coin feeTx1 = Coin 3 -txbodyEx1 :: TxBody ShelleyEra +txbodyEx1 :: TxBody TopTx ShelleyEra txbodyEx1 = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -197,7 +197,7 @@ txbodyEx1 = SNothing SNothing -txEx1 :: ShelleyTx ShelleyEra +txEx1 :: ShelleyTx TopTx ShelleyEra txEx1 = ShelleyTx txbodyEx1 @@ -273,7 +273,7 @@ aliceCoinEx2Ptr = aliceCoinEx1 <-> (aliceCoinEx2Base <+> feeTx2) -- | The transaction delegates Alice's and Bob's stake to Alice's pool. -- Additionally, we split Alice's ADA between a base address and a pointer address. -txbodyEx2 :: TxBody ShelleyEra +txbodyEx2 :: TxBody TopTx ShelleyEra txbodyEx2 = ShelleyTxBody { stbInputs = Set.fromList [TxIn (txIdTxBody txbodyEx1) minBound] @@ -294,7 +294,7 @@ txbodyEx2 = , stbMDHash = SNothing } -txEx2 :: ShelleyTx ShelleyEra +txEx2 :: ShelleyTx TopTx ShelleyEra txEx2 = ShelleyTx txbodyEx2 @@ -423,7 +423,7 @@ feeTx4 = Coin 5 aliceCoinEx4Base :: Coin aliceCoinEx4Base = aliceCoinEx2Base <-> feeTx4 -txbodyEx4 :: TxBody ShelleyEra +txbodyEx4 :: TxBody TopTx ShelleyEra txbodyEx4 = ShelleyTxBody { stbInputs = Set.fromList [TxIn (txIdTxBody txbodyEx2) minBound] @@ -438,7 +438,7 @@ txbodyEx4 = , stbMDHash = SNothing } -txEx4 :: ShelleyTx ShelleyEra +txEx4 :: ShelleyTx TopTx ShelleyEra txEx4 = ShelleyTx txbodyEx4 @@ -817,7 +817,7 @@ bobAda10 = <+> Coin 7 <-> feeTx10 -txbodyEx10 :: TxBody ShelleyEra +txbodyEx10 :: TxBody TopTx ShelleyEra txbodyEx10 = ShelleyTxBody (Set.fromList [mkTxInPartial genesisId 1]) @@ -829,7 +829,7 @@ txbodyEx10 = SNothing SNothing -txEx10 :: ShelleyTx ShelleyEra +txEx10 :: ShelleyTx TopTx ShelleyEra txEx10 = ShelleyTx txbodyEx10 @@ -882,7 +882,7 @@ aliceCoinEx11Ptr = aliceCoinEx4Base <-> feeTx11 aliceRetireEpoch :: EpochNo aliceRetireEpoch = EpochNo 5 -txbodyEx11 :: TxBody ShelleyEra +txbodyEx11 :: TxBody TopTx ShelleyEra txbodyEx11 = ShelleyTxBody (Set.fromList [TxIn (txIdTxBody txbodyEx4) minBound]) @@ -894,7 +894,7 @@ txbodyEx11 = SNothing SNothing -txEx11 :: ShelleyTx ShelleyEra +txEx11 :: ShelleyTx TopTx ShelleyEra txEx11 = ShelleyTx txbodyEx11 diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs index 6ccbdbd2da8..f4b94777be2 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs @@ -89,7 +89,7 @@ feeTx1 = Coin 3 aliceCoinEx1 :: Coin aliceCoinEx1 = aliceInitCoin <-> Coin 250 <-> feeTx1 -txbodyEx1 :: TxBody ShelleyEra +txbodyEx1 :: TxBody TopTx ShelleyEra txbodyEx1 = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -101,7 +101,7 @@ txbodyEx1 = SNothing SNothing -txEx1 :: ShelleyTx ShelleyEra +txEx1 :: ShelleyTx TopTx ShelleyEra txEx1 = ShelleyTx txbodyEx1 @@ -159,7 +159,7 @@ aliceCoinEx2 = aliceCoinEx1 <-> feeTx2 newPoolParams :: StakePoolParams newPoolParams = Cast.aliceStakePoolParams {sppCost = Coin 500} -txbodyEx2 :: TxBody ShelleyEra +txbodyEx2 :: TxBody TopTx ShelleyEra txbodyEx2 = ShelleyTxBody (Set.fromList [TxIn (txIdTxBody txbodyEx1) minBound]) @@ -175,7 +175,7 @@ txbodyEx2 = SNothing SNothing -txEx2 :: ShelleyTx ShelleyEra +txEx2 :: ShelleyTx TopTx ShelleyEra txEx2 = ShelleyTx txbodyEx2 diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs index 17de9b7bc2b..13c48736bf9 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs @@ -176,7 +176,7 @@ aliceStakePoolParams' = Cast.aliceStakePoolParams {sppRewardAccount = RewardAcco bobStakePoolParams' :: StakePoolParams bobStakePoolParams' = Cast.bobStakePoolParams {sppRewardAccount = RewardAccount Testnet Cast.carlSHK} -txbodyEx1 :: TxBody ShelleyEra +txbodyEx1 :: TxBody TopTx ShelleyEra txbodyEx1 = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -198,7 +198,7 @@ txbodyEx1 = SNothing SNothing -txEx1 :: ShelleyTx ShelleyEra +txEx1 :: ShelleyTx TopTx ShelleyEra txEx1 = ShelleyTx txbodyEx1 diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Updates.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Updates.hs index f0512dedc5b..cb1b30861d7 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Updates.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Updates.hs @@ -118,7 +118,7 @@ feeTx1 = Coin 1 aliceCoinEx1 :: Coin aliceCoinEx1 = aliceInitCoin <-> feeTx1 -txbodyEx1 :: TxBody ShelleyEra +txbodyEx1 :: TxBody TopTx ShelleyEra txbodyEx1 = ShelleyTxBody (Set.fromList [TxIn genesisId minBound]) @@ -130,7 +130,7 @@ txbodyEx1 = (SJust (Update ppVotes1 (EpochNo 0))) SNothing -txEx1 :: ShelleyTx ShelleyEra +txEx1 :: ShelleyTx TopTx ShelleyEra txEx1 = ShelleyTx txbodyEx1 @@ -193,7 +193,7 @@ feeTx2 = Coin 1 aliceCoinEx2 :: Coin aliceCoinEx2 = aliceCoinEx1 <-> feeTx2 -txbodyEx2 :: TxBody ShelleyEra +txbodyEx2 :: TxBody TopTx ShelleyEra txbodyEx2 = ShelleyTxBody (Set.fromList [TxIn (txIdTxBody txbodyEx1) minBound]) @@ -205,7 +205,7 @@ txbodyEx2 = (SJust updateEx3B) SNothing -txEx2 :: ShelleyTx ShelleyEra +txEx2 :: ShelleyTx TopTx ShelleyEra txEx2 = ShelleyTx txbodyEx2 @@ -269,7 +269,7 @@ feeTx3 = Coin 1 aliceCoinEx3 :: Coin aliceCoinEx3 = aliceCoinEx2 <-> feeTx3 -txbodyEx3 :: TxBody ShelleyEra +txbodyEx3 :: TxBody TopTx ShelleyEra txbodyEx3 = ShelleyTxBody (Set.fromList [TxIn (txIdTxBody txbodyEx2) minBound]) @@ -281,7 +281,7 @@ txbodyEx3 = (SJust (Update ppVotes3 (EpochNo 1))) SNothing -txEx3 :: ShelleyTx ShelleyEra +txEx3 :: ShelleyTx TopTx ShelleyEra txEx3 = ShelleyTx txbodyEx3 diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Fees.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Fees.hs index ba399c8cac0..07463a1b21b 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Fees.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Fees.hs @@ -79,7 +79,7 @@ import Test.Cardano.Ledger.Shelley.Utils ( import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -sizeTest :: HasCallStack => BSL.ByteString -> Tx ShelleyEra -> Assertion +sizeTest :: HasCallStack => BSL.ByteString -> Tx TopTx ShelleyEra -> Assertion sizeTest b16 tx = do Base16.encode (Plain.serialize tx) @?= b16 (tx ^. sizeTxF) @?= (fromIntegral @Int64 @Word32 (BSL.length b16) `div` 2) @@ -155,7 +155,7 @@ carlPay = KeyPair vk sk -- | Simple Transaction which consumes one UTxO and creates one UTxO -- | and has one witness -txbSimpleUTxO :: TxBody ShelleyEra +txbSimpleUTxO :: TxBody TopTx ShelleyEra txbSimpleUTxO = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -168,7 +168,7 @@ txbSimpleUTxO = , stbMDHash = SNothing } -txSimpleUTxO :: Tx ShelleyEra +txSimpleUTxO :: Tx TopTx ShelleyEra txSimpleUTxO = mkBasicTx txbSimpleUTxO & witsTxL @@ -183,7 +183,7 @@ txSimpleUTxOBytes16 = -- | Transaction which consumes two UTxO and creates five UTxO -- | and has two witness -txbMutiUTxO :: TxBody ShelleyEra +txbMutiUTxO :: TxBody TopTx ShelleyEra txbMutiUTxO = ShelleyTxBody { stbInputs = @@ -207,7 +207,7 @@ txbMutiUTxO = , stbMDHash = SNothing } -txMutiUTxO :: Tx ShelleyEra +txMutiUTxO :: Tx TopTx ShelleyEra txMutiUTxO = MkShelleyTx $ ShelleyTx @@ -229,7 +229,7 @@ txMutiUTxOBytes16 = "83a4008282582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c1113140082582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131401018582583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a82583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df761482583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df76181e825839000d2a471489a90f2910ec67ded8e215bfcd669bae77e7f9ab15850abd4e130c0bdeb7768edf2e8f85007fd52073e3dc1871f4c47f9dfca92e1828825839000d2a471489a90f2910ec67ded8e215bfcd669bae77e7f9ab15850abd4e130c0bdeb7768edf2e8f85007fd52073e3dc1871f4c47f9dfca92e18320218c7030aa1008282582037139648f2c22bbf1d0ef9af37cfebc9014b1e0e2a55be87c4b3b231a8d84d2658405ef09b22172cd28678e76e600e899886852e03567e2e72b4815629471e736a0cd424dc71cdaa0d0403371d79ea3d0cb7f28cb0740ebfcd8947343eba99a6aa088258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e5840ea98ef8052776aa5c182621cfd2ec91011d327527fc2531be9e1a8356c10f25f3fe5a5a7f549a0dc3b17c4ad8e4b8673b63a87977ac899b675f3ce3d6badae01f6" -- | Transaction which registers a stake key -txbRegisterStake :: TxBody ShelleyEra +txbRegisterStake :: TxBody TopTx ShelleyEra txbRegisterStake = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -242,7 +242,7 @@ txbRegisterStake = , stbMDHash = SNothing } -txRegisterStake :: Tx ShelleyEra +txRegisterStake :: Tx TopTx ShelleyEra txRegisterStake = MkShelleyTx $ ShelleyTx @@ -259,7 +259,7 @@ txRegisterStakeBytes16 = "83a5008182582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131400018182583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a02185e030a048182008200581cc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df76a100818258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e58403271792b002eb39bcb133668e851a5ffba9c13ad2b5c5a7bbc850a17de8309cbb9649d9e90eb4c9cc82f28f204408d513ccc575ce1f61808f67793429ff1880ef6" -- | Transaction which delegates a stake key -txbDelegateStake :: TxBody ShelleyEra +txbDelegateStake :: TxBody TopTx ShelleyEra txbDelegateStake = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -275,7 +275,7 @@ txbDelegateStake = , stbMDHash = SNothing } -txDelegateStake :: Tx ShelleyEra +txDelegateStake :: Tx TopTx ShelleyEra txDelegateStake = MkShelleyTx $ ShelleyTx @@ -295,7 +295,7 @@ txDelegateStakeBytes16 = "83a5008182582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131400018182583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a02185e030a048183028200581c4e130c0bdeb7768edf2e8f85007fd52073e3dc1871f4c47f9dfca92e581c5d43e1f1048b2619f51abc0cf505e4d4f9cb84becefd468d1a2fe335a100828258209921fa37a7d167aab519bb937d7ac6e522ad6d259a6173523357b971e05f41ff58403bad563c201b4f62448db12711af2d916776194b5176e9d312d07a328ce7780a63032dce887abc67985629b7aeabb0c334e84094f44d7e51ae51b5c799a83c0d8258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e584064aef85b046d2d0072cd64844e9f13d86651a1db74d356a10ecd7fb35a664fc466e543ea55cfbffd74025dc092d62c4b22d7e2de4decb4f049df354cfae9790af6" -- | Transaction which de-registers a stake key -txbDeregisterStake :: TxBody ShelleyEra +txbDeregisterStake :: TxBody TopTx ShelleyEra txbDeregisterStake = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -308,7 +308,7 @@ txbDeregisterStake = , stbMDHash = SNothing } -txDeregisterStake :: Tx ShelleyEra +txDeregisterStake :: Tx TopTx ShelleyEra txDeregisterStake = MkShelleyTx $ ShelleyTx @@ -325,7 +325,7 @@ txDeregisterStakeBytes16 = "83a5008182582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131400018182583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a02185e030a048182018200581cc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df76a100818258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e5840409db925fa592b7f4c76e44d738789f4b0ffb2b9cf4567af127121d635491b4eb736e8c92571f1329f14d06aad7ec42ca654ae65eb63b0b01d30cc4454aee80cf6" -- | Transaction which registers a stake pool -txbRegisterPool :: TxBody ShelleyEra +txbRegisterPool :: TxBody TopTx ShelleyEra txbRegisterPool = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -338,7 +338,7 @@ txbRegisterPool = , stbMDHash = SNothing } -txRegisterPool :: Tx ShelleyEra +txRegisterPool :: Tx TopTx ShelleyEra txRegisterPool = MkShelleyTx $ ShelleyTx @@ -355,7 +355,7 @@ txRegisterPoolBytes16 = "83a5008182582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131400018182583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a02185e030a04818a03581c5d43e1f1048b2619f51abc0cf505e4d4f9cb84becefd468d1a2fe33558208e61e1fa4855ea3aa0b8881a9e2e453c8c73536bdaabb64d36de86ee5a02519a0105d81e82010a581de0c6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df7681581cc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df76818301f66872656c61792e696f826a616c6963652e706f6f6c427b7da100818258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e5840165c6aa107571daafb1f9093d3cdc184a4068e8ff9243715c13335feb3652dc0d817b3b015a9929c9d83a0dd406fe71658fdccbf7925d2fff316237b499c2003f6" -- | Transaction which retires a stake pool -txbRetirePool :: TxBody ShelleyEra +txbRetirePool :: TxBody TopTx ShelleyEra txbRetirePool = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -368,7 +368,7 @@ txbRetirePool = , stbMDHash = SNothing } -txRetirePool :: Tx ShelleyEra +txRetirePool :: Tx TopTx ShelleyEra txRetirePool = MkShelleyTx $ ShelleyTx @@ -389,7 +389,7 @@ txRetirePoolBytes16 = md :: Era era => ShelleyTxAuxData era md = ShelleyTxAuxData $ Map.singleton 0 (List [I 5, S "hello"]) -txbWithMD :: TxBody ShelleyEra +txbWithMD :: TxBody TopTx ShelleyEra txbWithMD = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -402,7 +402,7 @@ txbWithMD = , stbMDHash = SJust $ hashTxAuxData @ShelleyEra md } -txWithMD :: Tx ShelleyEra +txWithMD :: Tx TopTx ShelleyEra txWithMD = MkShelleyTx $ ShelleyTx @@ -430,7 +430,7 @@ msig = ] ) -txbWithMultiSig :: TxBody ShelleyEra +txbWithMultiSig :: TxBody TopTx ShelleyEra txbWithMultiSig = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] -- acting as if this is multi-sig @@ -443,7 +443,7 @@ txbWithMultiSig = , stbMDHash = SNothing } -txWithMultiSig :: Tx ShelleyEra +txWithMultiSig :: Tx TopTx ShelleyEra txWithMultiSig = MkShelleyTx $ ShelleyTx @@ -460,7 +460,7 @@ txWithMultiSigBytes16 = "83a4008182582003170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c11131400018182583900e9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371fc6852b6aaed73bcf346a57ef99adae3000b51c7c59faaeb15993df760a02185e030aa2008282582037139648f2c22bbf1d0ef9af37cfebc9014b1e0e2a55be87c4b3b231a8d84d265840e3b8f50632325fbd1f82202ce5a8b4672bd96c50a338d70c0aa96720f6f7fbf60e0ce708f3a7e28faa0d78dc437a0b61e02205ddb1db22d02ba35b37a7fe03068258204628aaf16d6e1baa061d1296419542cb09287c639163d0fdbdac0ff23699797e584089c20cb6246483bbd0b2006f658597eff3e8ab3b8a6e9b22cb3c5b95cf0d3a2b96107acef88319fa2dd0fb28adcfdb330bb99f1f0058918a75d951ca9b73660c0181830302838200581ce9686d801fa32aeb4390c2f2a53bb0314a9c744c46a2cada394a371f8200581c0d2a471489a90f2910ec67ded8e215bfcd669bae77e7f9ab15850abd8200581cd0671052191a58c554eee27808b2b836a03ca369ca7a847f8c37d6f9f6" -- | Transaction with a Reward Withdrawal -txbWithWithdrawal :: TxBody ShelleyEra +txbWithWithdrawal :: TxBody TopTx ShelleyEra txbWithWithdrawal = ShelleyTxBody { stbInputs = Set.fromList [TxIn genesisId minBound] @@ -474,7 +474,7 @@ txbWithWithdrawal = , stbMDHash = SNothing } -txWithWithdrawal :: Tx ShelleyEra +txWithWithdrawal :: Tx TopTx ShelleyEra txWithWithdrawal = MkShelleyTx $ ShelleyTx diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/MultiSigExamples.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/MultiSigExamples.hs index 2e6dbf1e27e..6f0adfc16d0 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/MultiSigExamples.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/MultiSigExamples.hs @@ -123,7 +123,7 @@ aliceAndBobOrCarlOrDaria = initTxBody :: [(Addr, Value ShelleyEra)] -> - TxBody ShelleyEra + TxBody TopTx ShelleyEra initTxBody addrs = ShelleyTxBody (Set.fromList [TxIn genesisId minBound, TxIn genesisId (mkTxIxPartial 1)]) @@ -139,7 +139,7 @@ makeTxBody :: [TxIn] -> [(Addr, Value ShelleyEra)] -> Withdrawals -> - TxBody ShelleyEra + TxBody TopTx ShelleyEra makeTxBody inp addrCs wdrl = ShelleyTxBody (Set.fromList inp) @@ -152,11 +152,11 @@ makeTxBody inp addrCs wdrl = SNothing makeTx :: - TxBody ShelleyEra -> + TxBody TopTx ShelleyEra -> [KeyPair 'Witness] -> Map ScriptHash (MultiSig ShelleyEra) -> Maybe (ShelleyTxAuxData ShelleyEra) -> - Tx ShelleyEra + Tx TopTx ShelleyEra makeTx txBody keyPairs msigs auxData = mkBasicTx txBody & witsTxL .~ txWits diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index 27c74d63b18..b2e8d985d5d 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -196,7 +196,7 @@ testVRF = mkVRFKeyPair (RawSeed 0 0 0 0 5) testVRFKH :: VRFVerKeyHash r testVRFKH = hashVerKeyVRF @MockCrypto $ vrfVerKey testVRF -testTxb :: TxBody ShelleyEra +testTxb :: TxBody TopTx ShelleyEra testTxb = ShelleyTxBody Set.empty @@ -981,7 +981,7 @@ tests = sig = unsoundPureSignedKES () 0 (testBHB @ShelleyEra) (kesSignKey testKESKeys) bh = BHeader (testBHB @ShelleyEra) sig tout = StrictSeq.singleton $ ShelleyTxOut @ShelleyEra testAddrE (Coin 2) - txb :: Word64 -> TxBody ShelleyEra + txb :: Word64 -> TxBody TopTx ShelleyEra txb s = ShelleyTxBody (Set.fromList [genesisTxIn1]) @@ -992,7 +992,7 @@ tests = (SlotNo s) SNothing SNothing - txb1, txb2, txb3, txb4, txb5 :: TxBody ShelleyEra + txb1, txb2, txb3, txb4, txb5 :: TxBody TopTx ShelleyEra txb1 = txb 500 txb2 = txb 501 txb3 = txb 502 @@ -1001,7 +1001,7 @@ tests = w1 = mkWitnessVKey (hashAnnotated txb1) testKey1 w2 = mkWitnessVKey (hashAnnotated txb1) testKey2 ws = Set.fromList [w1, w2] - tx1, tx2, tx3, tx4, tx5 :: Tx ShelleyEra + tx1, tx2, tx3, tx4, tx5 :: Tx TopTx ShelleyEra tx1 = mkBasicTx txb1 & witsTxL @ShelleyEra .~ (mkBasicTxWits @ShelleyEra & addrTxWitsL .~ Set.singleton w1) diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs index 2f66e99a18e..5e366fa4972 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs @@ -230,7 +230,7 @@ testCheckLeaderVal = testLEDGER :: HasCallStack => LedgerState ShelleyEra -> - Tx ShelleyEra -> + Tx TopTx ShelleyEra -> LedgerEnv ShelleyEra -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER ShelleyEra))) (LedgerState ShelleyEra) -> Assertion @@ -254,7 +254,7 @@ data AliceToBob = AliceToBob , signers :: [KeyPair 'Witness] } -aliceGivesBobLovelace :: AliceToBob -> Tx ShelleyEra +aliceGivesBobLovelace :: AliceToBob -> Tx TopTx ShelleyEra aliceGivesBobLovelace AliceToBob { input @@ -320,7 +320,7 @@ ledgerEnv = LedgerEnv (SlotNo 0) Nothing minBound pp (ChainAccountState (Coin 0) testInvalidTx :: NonEmpty (PredicateFailure (ShelleyLEDGER ShelleyEra)) -> - Tx ShelleyEra -> + Tx TopTx ShelleyEra -> Assertion testInvalidTx errs tx = testLEDGER ledgerState tx ledgerEnv (Left errs) diff --git a/libs/cardano-ledger-api/CHANGELOG.md b/libs/cardano-ledger-api/CHANGELOG.md index 0a1941d50a1..995f02c5780 100644 --- a/libs/cardano-ledger-api/CHANGELOG.md +++ b/libs/cardano-ledger-api/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.13.0.0 +* Add `TxLevel` argument to `Tx` and `TxBody` +* Add `EraTxLevel` instance * Add `AnyEraScript` * Add `AnyEraSpendingPurpose`, `AnyEraMintingPurpose`, `AnyEraCertifyingPurpose`, `AnyEraRewardingPurpose`, `AnyEraVotingPurpose`, `AnyEraProposingPurpose`, `AnyEraGuardingPurpose` patterns * Re-export `DijkstraEraScript`, `toGuardingPurpose` and `GuardingPurpose` pattern diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index be80b3da8c7..50bdac43436 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -67,7 +67,7 @@ library cardano-ledger-conway >=1.19, cardano-ledger-core:{cardano-ledger-core, internal} >=1.17, cardano-ledger-dijkstra >=0.2, - cardano-ledger-mary ^>=1.9, + cardano-ledger-mary ^>=1.10, cardano-ledger-shelley ^>=1.18, cardano-strict-containers, containers, 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..e28e81f6b2b 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Era.hs @@ -72,42 +72,47 @@ module Cardano.Ledger.Api.Era ( import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Allegra.Scripts (translateTimelock, upgradeMultiSig) import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..)) -import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..), ValidityInterval (..)) +import Cardano.Ledger.Allegra.TxBody ( + AllegraEraTxBody (..), + AllegraTxBodyRaw (..), + ValidityInterval (..), + ) import qualified Cardano.Ledger.Allegra.TxBody as Allegra (TxBody (..)) import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (appExtraEntropy), appD) import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript, upgradePlutusPurposeAsIx) import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..), AlonzoTxAuxDataRaw (..)) -import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody (..), TxBody (..)) +import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody (..), AlonzoTxBodyRaw (..), TxBody (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..), unRedeemers) import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Babbage.PParams (upgradeBabbagePParams) import Cardano.Ledger.Babbage.Tx +import Cardano.Ledger.Babbage.TxBody (BabbageTxBodyRaw (..)) import Cardano.Ledger.BaseTypes (StrictMaybe (..), isSJust) import Cardano.Ledger.Binary (mkSized, unsafeMapSized) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway (ConwayEra, Tx (..)) import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) -import Cardano.Ledger.Conway.TxBody (TxBody (..)) +import Cardano.Ledger.Conway.TxBody (ConwayTxBodyRaw (..), TxBody (..)) import Cardano.Ledger.Conway.TxCert (ConwayTxCertUpgradeError) import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.Scripts -import Cardano.Ledger.Dijkstra.Tx (Tx (..)) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (..), Tx (..)) import Cardano.Ledger.Dijkstra.TxBody (TxBody (..), upgradeProposals) import Cardano.Ledger.Dijkstra.TxCert (DijkstraTxCertUpgradeError) import Cardano.Ledger.Internal.Era (EraHasName (..)) import Cardano.Ledger.Keys (HasKeyRole (..)) import Cardano.Ledger.Mary (MaryEra, TxBody (..)) import Cardano.Ledger.Mary.TxBody (MaryEraTxBody (..)) -import Cardano.Ledger.MemoBytes (mkMemoizedEra) +import Cardano.Ledger.MemoBytes (getMemoRawType, mkMemoizedEra) import Cardano.Ledger.Plutus.Data (upgradeData) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.PParams import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) import Cardano.Ledger.Shelley.TxAuxData (ShelleyTxAuxData (..)) -import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody (..)) +import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody (..), ShelleyTxBodyRaw (..)) import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..)) import Cardano.Ledger.Slot (SlotNo) import Control.Arrow (left) @@ -196,16 +201,16 @@ class -- Use `binaryUpgradeTx` instead, if you need to preserve the serialised form. upgradeTx :: EraTx (PreviousEra era) => - Tx (PreviousEra era) -> - Either (TxUpgradeError era) (Tx era) + Tx l (PreviousEra era) -> + Either (TxUpgradeError era) (Tx l era) -- | Upgrade a transaction body from the previous era. -- /Warning/ - This may not preserve the underlying binary representation. -- Use `binaryUpgradeTxBody` instead, if you need to preserve the serialised form. upgradeTxBody :: EraTxBody (PreviousEra era) => - TxBody (PreviousEra era) -> - Either (TxBodyUpgradeError era) (TxBody era) + TxBody l (PreviousEra era) -> + Either (TxBodyUpgradeError era) (TxBody l era) -- | Upgrade txAuxData from the previous era. -- /Warning/ - This may not preserve the underlying binary representation. @@ -250,19 +255,21 @@ instance EraApi AllegraEra where <*> pure (upgradeTxWits txwits) <*> pure (fmap upgradeTxAuxData txAux) - upgradeTxBody txBody = do - certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL) - pure $ - Allegra.AllegraTxBody - { Allegra.atbInputs = txBody ^. inputsTxBodyL - , Allegra.atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL) - , Allegra.atbCerts = certs - , Allegra.atbWithdrawals = txBody ^. withdrawalsTxBodyL - , Allegra.atbTxFee = txBody ^. feeTxBodyL - , Allegra.atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL) - , Allegra.atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL) - , Allegra.atbAuxDataHash = txBody ^. auxDataHashTxBodyL - } + upgradeTxBody txBody = + case getMemoRawType txBody of + ShelleyTxBodyRaw {} -> do + certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL) + pure . asSTxTopLevel $ + Allegra.AllegraTxBody + { Allegra.atbInputs = txBody ^. inputsTxBodyL + , Allegra.atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL) + , Allegra.atbCerts = certs + , Allegra.atbWithdrawals = txBody ^. withdrawalsTxBodyL + , Allegra.atbTxFee = txBody ^. feeTxBodyL + , Allegra.atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL) + , Allegra.atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL) + , Allegra.atbAuxDataHash = txBody ^. auxDataHashTxBodyL + } upgradeTxAuxData (ShelleyTxAuxData md) = AllegraTxAuxData md mempty @@ -285,20 +292,22 @@ instance EraApi MaryEra where <*> pure (upgradeTxWits txwits) <*> pure (fmap upgradeTxAuxData txAux) - upgradeTxBody atb = do - certs <- traverse upgradeTxCert (Allegra.atbCerts atb) - pure $ - MaryTxBody - { mtbInputs = Allegra.atbInputs atb - , mtbOutputs = upgradeTxOut <$> Allegra.atbOutputs atb - , mtbCerts = certs - , mtbWithdrawals = Allegra.atbWithdrawals atb - , mtbTxFee = Allegra.atbTxFee atb - , mtbValidityInterval = Allegra.atbValidityInterval atb - , mtbUpdate = upgradeUpdate () <$> Allegra.atbUpdate atb - , mtbAuxDataHash = Allegra.atbAuxDataHash atb - , mtbMint = mempty - } + upgradeTxBody atb = + case getMemoRawType atb of + AllegraTxBodyRaw {} -> do + certs <- traverse upgradeTxCert (Allegra.atbCerts atb) + pure $ + MaryTxBody + { mtbInputs = Allegra.atbInputs atb + , mtbOutputs = upgradeTxOut <$> Allegra.atbOutputs atb + , mtbCerts = certs + , mtbWithdrawals = Allegra.atbWithdrawals atb + , mtbTxFee = Allegra.atbTxFee atb + , mtbValidityInterval = Allegra.atbValidityInterval atb + , mtbUpdate = upgradeUpdate () <$> Allegra.atbUpdate atb + , mtbAuxDataHash = Allegra.atbAuxDataHash atb + , mtbMint = mempty + } upgradeTxAuxData (AllegraTxAuxData md scripts) = AllegraTxAuxData md $ upgradeScript <$> scripts @@ -333,58 +342,60 @@ instance EraApi AlonzoEra where <*> pure (fmap upgradeTxAuxData aux) upgradeTxBody - MaryTxBody - { mtbInputs - , mtbOutputs - , mtbCerts - , mtbWithdrawals - , mtbTxFee - , mtbValidityInterval - , mtbUpdate - , mtbAuxDataHash - , mtbMint - } = do - certs <- - traverse - (left absurd . upgradeTxCert) - mtbCerts - - updates <- traverse upgradeUpdateEither mtbUpdate - pure $ - AlonzoTxBody - { atbInputs = mtbInputs - , atbOutputs = upgradeTxOut <$> mtbOutputs - , atbCerts = certs - , atbWithdrawals = mtbWithdrawals - , atbTxFee = mtbTxFee - , atbValidityInterval = mtbValidityInterval - , atbUpdate = updates - , atbAuxDataHash = mtbAuxDataHash - , atbMint = mtbMint - , atbCollateral = mempty - , atbReqSignerHashes = mempty - , atbScriptIntegrityHash = SNothing - , atbTxNetworkId = SNothing - } - where - upgradeUpdateEither :: - Update MaryEra -> - Either AlonzoTxBodyUpgradeError (Update AlonzoEra) - upgradeUpdateEither (Update pp epoch) = - Update <$> upgradeProposedPPUpdates pp <*> pure epoch - - upgradeProposedPPUpdates :: - ProposedPPUpdates MaryEra -> - Either AlonzoTxBodyUpgradeError (ProposedPPUpdates AlonzoEra) - upgradeProposedPPUpdates (ProposedPPUpdates m) = - ProposedPPUpdates - <$> traverse - ( \ppu -> do - when (isSJust $ ppu ^. ppuMinUTxOValueL) $ - Left ATBUEMinUTxOUpdated - pure $ upgradePParamsUpdate def ppu - ) - m + txb = + case getMemoRawType txb of + AllegraTxBodyRaw + { atbrInputs + , atbrOutputs + , atbrCerts + , atbrWithdrawals + , atbrFee + , atbrValidityInterval + , atbrUpdate + , atbrAuxDataHash + , atbrMint + } -> do + certs <- + traverse + (left absurd . upgradeTxCert) + atbrCerts + + updates <- traverse upgradeUpdateEither atbrUpdate + pure $ + AlonzoTxBody + { atbInputs = atbrInputs + , atbOutputs = upgradeTxOut <$> atbrOutputs + , atbCerts = certs + , atbWithdrawals = atbrWithdrawals + , atbTxFee = atbrFee + , atbValidityInterval = atbrValidityInterval + , atbUpdate = updates + , atbAuxDataHash = atbrAuxDataHash + , atbMint = atbrMint + , atbCollateral = mempty + , atbReqSignerHashes = mempty + , atbScriptIntegrityHash = SNothing + , atbTxNetworkId = SNothing + } + where + upgradeUpdateEither :: + Update MaryEra -> + Either AlonzoTxBodyUpgradeError (Update AlonzoEra) + upgradeUpdateEither (Update pp epoch) = + Update <$> upgradeProposedPPUpdates pp <*> pure epoch + + upgradeProposedPPUpdates :: + ProposedPPUpdates MaryEra -> + Either AlonzoTxBodyUpgradeError (ProposedPPUpdates AlonzoEra) + upgradeProposedPPUpdates (ProposedPPUpdates m) = + ProposedPPUpdates + <$> traverse + ( \ppu -> do + when (isSJust $ ppu ^. ppuMinUTxOValueL) $ + Left ATBUEMinUTxOUpdated + pure $ upgradePParamsUpdate def ppu + ) + m upgradeTxAuxData (AllegraTxAuxData md scripts) = mkMemoizedEra @AllegraEra $ @@ -458,57 +469,59 @@ instance EraApi BabbageEra where <*> pure valid <*> pure (fmap upgradeTxAuxData aux) - upgradeTxBody txBody = do - certs <- - traverse - (left absurd . upgradeTxCert) - (txBody ^. certsTxBodyL) - updates <- traverse upgradeUpdateEither (txBody ^. updateTxBodyL) - pure $ - BabbageTxBody - { btbInputs = txBody ^. inputsTxBodyL - , btbOutputs = - mkSized (eraProtVerLow @BabbageEra) . upgradeTxOut <$> (txBody ^. outputsTxBodyL) - , btbCerts = certs - , btbWithdrawals = txBody ^. withdrawalsTxBodyL - , btbTxFee = txBody ^. feeTxBodyL - , btbValidityInterval = txBody ^. vldtTxBodyL - , btbUpdate = updates - , btbAuxDataHash = txBody ^. auxDataHashTxBodyL - , btbMint = txBody ^. mintTxBodyL - , btbCollateral = txBody ^. collateralInputsTxBodyL - , btbReqSignerHashes = txBody ^. reqSignerHashesTxBodyL - , btbScriptIntegrityHash = txBody ^. scriptIntegrityHashTxBodyL - , btbTxNetworkId = txBody ^. networkIdTxBodyL - , btbReferenceInputs = mempty - , btbCollateralReturn = SNothing - , btbTotalCollateral = SNothing - } - where - upgradeUpdateEither :: - Update AlonzoEra -> - Either BabbageTxBodyUpgradeError (Update BabbageEra) - upgradeUpdateEither (Update pp epoch) = - Update <$> upgradeProposedPPUpdates pp <*> pure epoch - - -- Note that here we use 'upgradeBabbagePParams False' in order to - -- preserve 'CoinsPerUTxOWord', in spite of the value now being - -- semantically incorrect. Anything else will result in an invalid - -- transaction. - upgradeProposedPPUpdates :: - ProposedPPUpdates AlonzoEra -> - Either BabbageTxBodyUpgradeError (ProposedPPUpdates BabbageEra) - upgradeProposedPPUpdates (ProposedPPUpdates m) = - ProposedPPUpdates - <$> traverse - ( \(PParamsUpdate pphkd) -> do - when (isSJust $ appD pphkd) $ - Left BTBUEUpdatesD - when (isSJust $ appExtraEntropy pphkd) $ - Left BTBUEUpdatesExtraEntropy - pure . PParamsUpdate $ upgradeBabbagePParams False pphkd - ) - m + upgradeTxBody txBody = + case getMemoRawType txBody of + AlonzoTxBodyRaw {} -> do + certs <- + traverse + (left absurd . upgradeTxCert) + (txBody ^. certsTxBodyL) + updates <- traverse upgradeUpdateEither (txBody ^. updateTxBodyL) + pure $ + BabbageTxBody + { btbInputs = txBody ^. inputsTxBodyL + , btbOutputs = + mkSized (eraProtVerLow @BabbageEra) . upgradeTxOut <$> (txBody ^. outputsTxBodyL) + , btbCerts = certs + , btbWithdrawals = txBody ^. withdrawalsTxBodyL + , btbTxFee = txBody ^. feeTxBodyL + , btbValidityInterval = txBody ^. vldtTxBodyL + , btbUpdate = updates + , btbAuxDataHash = txBody ^. auxDataHashTxBodyL + , btbMint = txBody ^. mintTxBodyL + , btbCollateral = txBody ^. collateralInputsTxBodyL + , btbReqSignerHashes = txBody ^. reqSignerHashesTxBodyL + , btbScriptIntegrityHash = txBody ^. scriptIntegrityHashTxBodyL + , btbTxNetworkId = txBody ^. networkIdTxBodyL + , btbReferenceInputs = mempty + , btbCollateralReturn = SNothing + , btbTotalCollateral = SNothing + } + where + upgradeUpdateEither :: + Update AlonzoEra -> + Either BabbageTxBodyUpgradeError (Update BabbageEra) + upgradeUpdateEither (Update pp epoch) = + Update <$> upgradeProposedPPUpdates pp <*> pure epoch + + -- Note that here we use 'upgradeBabbagePParams False' in order to + -- preserve 'CoinsPerUTxOWord', in spite of the value now being + -- semantically incorrect. Anything else will result in an invalid + -- transaction. + upgradeProposedPPUpdates :: + ProposedPPUpdates AlonzoEra -> + Either BabbageTxBodyUpgradeError (ProposedPPUpdates BabbageEra) + upgradeProposedPPUpdates (ProposedPPUpdates m) = + ProposedPPUpdates + <$> traverse + ( \(PParamsUpdate pphkd) -> do + when (isSJust $ appD pphkd) $ + Left BTBUEUpdatesD + when (isSJust $ appExtraEntropy pphkd) $ + Left BTBUEUpdatesExtraEntropy + pure . PParamsUpdate $ upgradeBabbagePParams False pphkd + ) + m upgradeTxAuxData = translateAlonzoTxAuxData @@ -544,33 +557,35 @@ instance EraApi ConwayEra where <*> pure valid <*> pure (fmap upgradeTxAuxData aux) - upgradeTxBody btb = do - when (isSJust (btbUpdate btb)) $ Left CTBUEContainsUpdate - certs <- traverse (left CTBUETxCert . upgradeTxCert) (btbCerts btb) - let (duplicates, certsOSet) = OSet.fromStrictSeqDuplicates certs - unless (null duplicates) $ Left $ CTBUEContainsDuplicateCerts duplicates - pure $ - ConwayTxBody - { ctbSpendInputs = btbInputs btb - , ctbOutputs = unsafeMapSized upgradeTxOut <$> btbOutputs btb - , ctbCerts = certsOSet - , ctbWithdrawals = btbWithdrawals btb - , ctbTxfee = btbTxFee btb - , ctbVldt = btbValidityInterval btb - , ctbAdHash = btbAuxDataHash btb - , ctbMint = btbMint btb - , ctbCollateralInputs = btbCollateral btb - , ctbReqSignerHashes = btbReqSignerHashes btb - , ctbScriptIntegrityHash = btbScriptIntegrityHash btb - , ctbTxNetworkId = btbTxNetworkId btb - , ctbReferenceInputs = btbReferenceInputs btb - , ctbCollateralReturn = unsafeMapSized upgradeTxOut <$> btbCollateralReturn btb - , ctbTotalCollateral = btbTotalCollateral btb - , ctbCurrentTreasuryValue = SNothing - , ctbProposalProcedures = OSet.empty - , ctbVotingProcedures = VotingProcedures mempty - , ctbTreasuryDonation = Coin 0 - } + upgradeTxBody btb = + case getMemoRawType btb of + BabbageTxBodyRaw {} -> do + when (isSJust (btbUpdate btb)) $ Left CTBUEContainsUpdate + certs <- traverse (left CTBUETxCert . upgradeTxCert) (btbCerts btb) + let (duplicates, certsOSet) = OSet.fromStrictSeqDuplicates certs + unless (null duplicates) $ Left $ CTBUEContainsDuplicateCerts duplicates + pure $ + ConwayTxBody + { ctbSpendInputs = btbInputs btb + , ctbOutputs = unsafeMapSized upgradeTxOut <$> btbOutputs btb + , ctbCerts = certsOSet + , ctbWithdrawals = btbWithdrawals btb + , ctbTxfee = btbTxFee btb + , ctbVldt = btbValidityInterval btb + , ctbAdHash = btbAuxDataHash btb + , ctbMint = btbMint btb + , ctbCollateralInputs = btbCollateral btb + , ctbReqSignerHashes = btbReqSignerHashes btb + , ctbScriptIntegrityHash = btbScriptIntegrityHash btb + , ctbTxNetworkId = btbTxNetworkId btb + , ctbReferenceInputs = btbReferenceInputs btb + , ctbCollateralReturn = unsafeMapSized upgradeTxOut <$> btbCollateralReturn btb + , ctbTotalCollateral = btbTotalCollateral btb + , ctbCurrentTreasuryValue = SNothing + , ctbProposalProcedures = OSet.empty + , ctbVotingProcedures = VotingProcedures mempty + , ctbTreasuryDonation = Coin 0 + } upgradeTxAuxData = translateAlonzoTxAuxData @@ -593,36 +608,38 @@ instance EraApi DijkstraEra where type TxBodyUpgradeError DijkstraEra = DijkstraTxBodyUpgradeError upgradeTx (MkConwayTx (AlonzoTx b w valid aux)) = fmap MkDijkstraTx $ - AlonzoTx + DijkstraTx <$> upgradeTxBody b <*> pure (upgradeTxWits w) <*> pure valid <*> pure (fmap upgradeTxAuxData aux) - upgradeTxBody ConwayTxBody {..} = do - certs <- traverse (left DTBUETxCert . upgradeTxCert) $ OSet.toStrictSeq ctbCerts - pure $ - DijkstraTxBody - { dtbSpendInputs = ctbSpendInputs - , dtbOutputs = unsafeMapSized upgradeTxOut <$> ctbOutputs - , dtbCerts = OSet.fromStrictSeq certs - , dtbWithdrawals = ctbWithdrawals - , dtbTxfee = ctbTxfee - , dtbVldt = ctbVldt - , dtbAdHash = ctbAdHash - , dtbMint = ctbMint - , dtbCollateralInputs = ctbCollateralInputs - , dtbGuards = OSet.fromSet $ Set.map (KeyHashObj . coerceKeyRole) ctbReqSignerHashes - , dtbScriptIntegrityHash = ctbScriptIntegrityHash - , dtbTxNetworkId = ctbTxNetworkId - , dtbReferenceInputs = ctbReferenceInputs - , dtbCollateralReturn = unsafeMapSized upgradeTxOut <$> ctbCollateralReturn - , dtbTotalCollateral = ctbTotalCollateral - , dtbCurrentTreasuryValue = ctbCurrentTreasuryValue - , dtbProposalProcedures = OSet.mapL upgradeProposals ctbProposalProcedures - , dtbVotingProcedures = coerce ctbVotingProcedures - , dtbTreasuryDonation = ctbTreasuryDonation - } + upgradeTxBody txBody = + case getMemoRawType txBody of + ConwayTxBodyRaw {..} -> do + certs <- traverse (left DTBUETxCert . upgradeTxCert) $ OSet.toStrictSeq ctbrCerts + pure $ + DijkstraTxBody + { dtbSpendInputs = ctbrSpendInputs + , dtbOutputs = unsafeMapSized upgradeTxOut <$> ctbrOutputs + , dtbCerts = OSet.fromStrictSeq certs + , dtbWithdrawals = ctbrWithdrawals + , dtbTxfee = ctbrFee + , dtbVldt = ctbrVldt + , dtbAdHash = ctbrAuxDataHash + , dtbMint = ctbrMint + , dtbCollateralInputs = ctbrCollateralInputs + , dtbGuards = OSet.fromSet $ Set.map (KeyHashObj . coerceKeyRole) ctbrReqSignerHashes + , dtbScriptIntegrityHash = ctbrScriptIntegrityHash + , dtbTxNetworkId = ctbrNetworkId + , dtbReferenceInputs = ctbrReferenceInputs + , dtbCollateralReturn = unsafeMapSized upgradeTxOut <$> ctbrCollateralReturn + , dtbTotalCollateral = ctbrTotalCollateral + , dtbCurrentTreasuryValue = ctbrCurrentTreasuryValue + , dtbProposalProcedures = OSet.mapL upgradeProposals ctbrProposalProcedures + , dtbVotingProcedures = coerce ctbrVotingProcedures + , dtbTreasuryDonation = ctbrTreasuryDonation + } upgradeTxWits atw = AlonzoTxWits diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx.hs index 46faf69353a..387e5a7ae6a 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx.hs @@ -11,6 +11,7 @@ -- -- Let's start by defining the GHC extensions and imports. -- +-- >>> :set -XTypeApplications -- >>> :set -XScopedTypeVariables -- >>> import Test.QuickCheck -- >>> import qualified Data.Sequence.Strict as StrictSeq @@ -25,7 +26,7 @@ -- quickCheck $ \(txOut :: TxOut BabbageEra) -> -- let -- -- Defining a Babbage era transaction body with a single random transaction output --- txBody = mkBasicTxBody +-- txBody = mkBasicTxBody @_ @TopTx -- & outputsTxBodyL <>~ StrictSeq.singleton txOut -- -- Defining a basic transaction with our transaction body -- tx = mkBasicTx txBody @@ -90,7 +91,7 @@ import Cardano.Ledger.Api.Tx.Body import Cardano.Ledger.Api.Tx.Cert import Cardano.Ledger.Api.Tx.Wits import Cardano.Ledger.Babbage.Collateral (mkCollateralTxIn) -import Cardano.Ledger.Core (EraTx (..), binaryUpgradeTx, txIdTx) +import Cardano.Ledger.Core (EraTx (..), TxLevel (..), binaryUpgradeTx, txIdTx) import Cardano.Ledger.State (UTxO (..), txouts) import Cardano.Ledger.Tools (calcMinFeeTx, estimateMinFeeTx, setMinFeeTx, setMinFeeTxUtxo) import Control.Monad (join) @@ -98,8 +99,8 @@ import qualified Data.Map as Map import Lens.Micro class (EraTx era, AnyEraTxBody era, AnyEraTxWits era, AnyEraTxAuxData era) => AnyEraTx era where - isValidTxG :: SimpleGetter (Tx era) (Maybe IsValid) - default isValidTxG :: AlonzoEraTx era => SimpleGetter (Tx era) (Maybe IsValid) + isValidTxG :: SimpleGetter (Tx TopTx era) (Maybe IsValid) + default isValidTxG :: AlonzoEraTx era => SimpleGetter (Tx TopTx era) (Maybe IsValid) isValidTxG = isValidTxL . to Just instance AnyEraTx ShelleyEra where @@ -120,7 +121,7 @@ instance AnyEraTx ConwayEra instance AnyEraTx DijkstraEra -- | Construct all of the unspent outputs that will be produced by this transaction -producedTxOuts :: AnyEraTx era => Tx era -> UTxO era +producedTxOuts :: AnyEraTx era => Tx TopTx era -> UTxO era producedTxOuts tx = case tx ^. isValidTxG of Just (IsValid False) -> 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 22c512bd3ff..30a8e4b04fc 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 @@ -88,6 +88,7 @@ module Cardano.Ledger.Api.Tx.Body ( import Cardano.Ledger.Address (Withdrawals (..)) import Cardano.Ledger.Allegra.Core (AllegraEraTxBody (..)) +import Cardano.Ledger.Allegra.Scripts (invalidBeforeL, invalidHereAfterL) import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody (..), ScriptIntegrityHash) import Cardano.Ledger.Api.Era import Cardano.Ledger.Api.Scripts @@ -95,7 +96,7 @@ import Cardano.Ledger.Api.Tx.Cert import Cardano.Ledger.Api.Tx.Out import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..)) -import Cardano.Ledger.BaseTypes (Network, SlotNo, StrictMaybe (..), strictMaybeToMaybe) +import Cardano.Ledger.BaseTypes (Network, strictMaybeToMaybe) import Cardano.Ledger.Binary.Decoding (Sized) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Governance ( @@ -108,6 +109,7 @@ import Cardano.Ledger.Core ( EraTxBody (..), PParams, TxAuxDataHash (..), + TxLevel (..), Value, binaryUpgradeTxBody, txIdTxBody, @@ -128,96 +130,96 @@ import qualified Data.OSet.Strict as OSet (fromSet) import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) import qualified Data.Set as Set (map) -import Lens.Micro (Lens', SimpleGetter, lens, to) +import Lens.Micro (SimpleGetter, to) class (EraTxBody era, AnyEraTxOut era, AnyEraTxCert era) => AnyEraTxBody era where - updateTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe (Update era))) + updateTxBodyG :: SimpleGetter (TxBody TopTx era) (Maybe (Maybe (Update era))) updateTxBodyG = to (const Nothing) - vldtTxBodyG :: SimpleGetter (TxBody era) ValidityInterval + vldtTxBodyG :: SimpleGetter (TxBody TopTx era) ValidityInterval default vldtTxBodyG :: - AllegraEraTxBody era => SimpleGetter (TxBody era) ValidityInterval + AllegraEraTxBody era => SimpleGetter (TxBody TopTx era) ValidityInterval vldtTxBodyG = vldtTxBodyL - mintTxBodyG :: SimpleGetter (TxBody era) (Maybe MultiAsset) + mintTxBodyG :: SimpleGetter (TxBody l era) (Maybe MultiAsset) default mintTxBodyG :: - MaryEraTxBody era => SimpleGetter (TxBody era) (Maybe MultiAsset) + MaryEraTxBody era => SimpleGetter (TxBody l era) (Maybe MultiAsset) mintTxBodyG = mintTxBodyL . to Just - collateralInputsTxBodyG :: SimpleGetter (TxBody era) (Maybe (Set TxIn)) + collateralInputsTxBodyG :: SimpleGetter (TxBody TopTx era) (Maybe (Set TxIn)) default collateralInputsTxBodyG :: - AlonzoEraTxBody era => SimpleGetter (TxBody era) (Maybe (Set TxIn)) + AlonzoEraTxBody era => SimpleGetter (TxBody TopTx era) (Maybe (Set TxIn)) collateralInputsTxBodyG = collateralInputsTxBodyL . to Just scriptIntegrityHashTxBodyG :: - SimpleGetter (TxBody era) (Maybe (Maybe ScriptIntegrityHash)) + SimpleGetter (TxBody l era) (Maybe (Maybe ScriptIntegrityHash)) default scriptIntegrityHashTxBodyG :: AlonzoEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe ScriptIntegrityHash)) + SimpleGetter (TxBody l era) (Maybe (Maybe ScriptIntegrityHash)) scriptIntegrityHashTxBodyG = scriptIntegrityHashTxBodyL . to (Just . strictMaybeToMaybe) - networkIdTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe Network)) + networkIdTxBodyG :: SimpleGetter (TxBody l era) (Maybe (Maybe Network)) default networkIdTxBodyG :: AlonzoEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe Network)) + SimpleGetter (TxBody l era) (Maybe (Maybe Network)) networkIdTxBodyG = networkIdTxBodyL . to (Just . strictMaybeToMaybe) - sizedOutputsTxBodyG :: SimpleGetter (TxBody era) (Maybe (StrictSeq (Sized (TxOut era)))) + sizedOutputsTxBodyG :: SimpleGetter (TxBody l era) (Maybe (StrictSeq (Sized (TxOut era)))) default sizedOutputsTxBodyG :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (Maybe (StrictSeq (Sized (TxOut era)))) + SimpleGetter (TxBody l era) (Maybe (StrictSeq (Sized (TxOut era)))) sizedOutputsTxBodyG = sizedOutputsTxBodyL . to Just - referenceInputsTxBodyG :: SimpleGetter (TxBody era) (Maybe (Set TxIn)) + referenceInputsTxBodyG :: SimpleGetter (TxBody l era) (Maybe (Set TxIn)) default referenceInputsTxBodyG :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Set TxIn)) + SimpleGetter (TxBody l era) (Maybe (Set TxIn)) referenceInputsTxBodyG = referenceInputsTxBodyL . to Just - totalCollateralTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe Coin)) + totalCollateralTxBodyG :: SimpleGetter (TxBody TopTx era) (Maybe (Maybe Coin)) default totalCollateralTxBodyG :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe Coin)) + SimpleGetter (TxBody TopTx era) (Maybe (Maybe Coin)) totalCollateralTxBodyG = totalCollateralTxBodyL . to (Just . strictMaybeToMaybe) - collateralReturnTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe (TxOut era))) + collateralReturnTxBodyG :: SimpleGetter (TxBody TopTx era) (Maybe (Maybe (TxOut era))) default collateralReturnTxBodyG :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe (TxOut era))) + SimpleGetter (TxBody TopTx era) (Maybe (Maybe (TxOut era))) collateralReturnTxBodyG = collateralReturnTxBodyL . to (Just . strictMaybeToMaybe) - sizedCollateralReturnTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe (Sized (TxOut era)))) + sizedCollateralReturnTxBodyG :: SimpleGetter (TxBody TopTx era) (Maybe (Maybe (Sized (TxOut era)))) default sizedCollateralReturnTxBodyG :: BabbageEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe (Sized (TxOut era)))) + SimpleGetter (TxBody TopTx era) (Maybe (Maybe (Sized (TxOut era)))) sizedCollateralReturnTxBodyG = sizedCollateralReturnTxBodyL . to (Just . strictMaybeToMaybe) - currentTreasuryValueTxBodyG :: SimpleGetter (TxBody era) (Maybe (Maybe Coin)) + currentTreasuryValueTxBodyG :: SimpleGetter (TxBody l era) (Maybe (Maybe Coin)) default currentTreasuryValueTxBodyG :: ConwayEraTxBody era => - SimpleGetter (TxBody era) (Maybe (Maybe Coin)) + SimpleGetter (TxBody l era) (Maybe (Maybe Coin)) currentTreasuryValueTxBodyG = currentTreasuryValueTxBodyL . to (Just . strictMaybeToMaybe) - votingProceduresTxBodyG :: SimpleGetter (TxBody era) (Maybe (VotingProcedures era)) + votingProceduresTxBodyG :: SimpleGetter (TxBody l era) (Maybe (VotingProcedures era)) default votingProceduresTxBodyG :: ConwayEraTxBody era => - SimpleGetter (TxBody era) (Maybe (VotingProcedures era)) + SimpleGetter (TxBody l era) (Maybe (VotingProcedures era)) votingProceduresTxBodyG = votingProceduresTxBodyL . to Just - proposalProceduresTxBodyG :: SimpleGetter (TxBody era) (Maybe (OSet (ProposalProcedure era))) + proposalProceduresTxBodyG :: SimpleGetter (TxBody l era) (Maybe (OSet (ProposalProcedure era))) default proposalProceduresTxBodyG :: ConwayEraTxBody era => - SimpleGetter (TxBody era) (Maybe (OSet (ProposalProcedure era))) + SimpleGetter (TxBody l era) (Maybe (OSet (ProposalProcedure era))) proposalProceduresTxBodyG = proposalProceduresTxBodyL . to Just - treasuryDonationTxBodyG :: SimpleGetter (TxBody era) (Maybe Coin) - default treasuryDonationTxBodyG :: ConwayEraTxBody era => SimpleGetter (TxBody era) (Maybe Coin) + treasuryDonationTxBodyG :: SimpleGetter (TxBody l era) (Maybe Coin) + default treasuryDonationTxBodyG :: ConwayEraTxBody era => SimpleGetter (TxBody l era) (Maybe Coin) treasuryDonationTxBodyG = treasuryDonationTxBodyL . to Just - guardsTxBodyG :: SimpleGetter (TxBody era) (Maybe (OSet (Credential Guard))) + guardsTxBodyG :: SimpleGetter (TxBody l era) (Maybe (OSet (Credential Guard))) default guardsTxBodyG :: DijkstraEraTxBody era => - SimpleGetter (TxBody era) (Maybe (OSet (Credential Guard))) + SimpleGetter (TxBody l era) (Maybe (OSet (Credential Guard))) guardsTxBodyG = guardsTxBodyL . to Just instance AnyEraTxBody ShelleyEra where @@ -331,35 +333,9 @@ evalBalanceTxBody :: -- | The UTxO relevant to the transaction. UTxO era -> -- | The transaction being evaluated for balance. - TxBody era -> + TxBody l era -> -- | The difference between what the transaction consumes and what it produces. Value era evalBalanceTxBody pp lookupKeyRefund lookupDRepRefund isRegPoolId utxo txBody = getConsumedValue pp lookupKeyRefund lookupDRepRefund utxo txBody <-> getProducedValue pp isRegPoolId txBody - --- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'Maybe SlotNo'. -invalidBeforeL :: Lens' ValidityInterval (Maybe SlotNo) -invalidBeforeL = lens g s - where - g :: ValidityInterval -> Maybe SlotNo - g (ValidityInterval ma _) = - case ma of - SNothing -> Nothing - SJust a -> Just a - - s :: ValidityInterval -> Maybe SlotNo -> ValidityInterval - s (ValidityInterval _ b) a = ValidityInterval (maybe SNothing SJust a) b - --- | Lens to access the 'invalidHereAfter' field of a 'ValidityInterval' as a 'Maybe SlotNo'. -invalidHereAfterL :: Lens' ValidityInterval (Maybe SlotNo) -invalidHereAfterL = lens g s - where - g :: ValidityInterval -> Maybe SlotNo - g (ValidityInterval _ mb) = - case mb of - SNothing -> Nothing - SJust b -> Just b - - s :: ValidityInterval -> Maybe SlotNo -> ValidityInterval - s (ValidityInterval ma _) = ValidityInterval ma . maybe SNothing SJust diff --git a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx.hs b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx.hs index af00f69d64c..56bcff5175b 100644 --- a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx.hs +++ b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx.hs @@ -12,6 +12,7 @@ import Cardano.Ledger.Api.Era import Cardano.Ledger.Api.PParams import Cardano.Ledger.Api.Tx import Cardano.Ledger.Binary +import Cardano.Ledger.Core (TxLevel (..)) import Cardano.Ledger.Hashes (extractHash, hashAnnotated, hashKey) import Cardano.Ledger.Keys (makeBootstrapWitness) import Cardano.Ledger.Val (Val ((<×>))) @@ -27,13 +28,13 @@ import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), KeyPair (..), mkWitn txSpec :: forall era. ( EraTx era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , Arbitrary (PParams era) ) => Spec txSpec = describe (eraName @era) $ do describe "estimateMinFeeTx" $ do - prop "no Bootstrap" $ \(pp :: PParams era) (tx :: Tx era) keyPairsList -> + prop "no Bootstrap" $ \(pp :: PParams era) (tx :: Tx TopTx era) keyPairsList -> let txBody = tx ^. bodyTxL txBodyHash = hashAnnotated txBody @@ -45,7 +46,7 @@ txSpec = describe (eraName @era) $ do in estimateMinFeeTx pp tx (Map.size keyPairs) 0 0 === (setMinFeeTx pp txSigned 0 ^. bodyTxL . feeTxBodyL) - prop "with Bootstrap" $ \(pp :: PParams era) (tx :: Tx era) keyPairsList byronKeyPairsList -> + prop "with Bootstrap" $ \(pp :: PParams era) (tx :: Tx TopTx era) keyPairsList byronKeyPairsList -> let txBody = tx ^. bodyTxL txBodyHash = hashAnnotated txBody diff --git a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs index 185c741bf4b..aad076cd917 100644 --- a/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs +++ b/libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/Tx/Body.hs @@ -28,7 +28,7 @@ totalTxDeposits :: (EraTxBody era, EraCertState era) => PParams era -> CertState era -> - TxBody era -> + TxBody l era -> Coin totalTxDeposits pp dpstate txb = numKeys <×> pp ^. ppKeyDepositL <+> snd (foldl' accum (regpools, Coin 0) certs) @@ -47,7 +47,7 @@ keyTxRefunds :: (EraTxBody era, ShelleyEraTxCert era, EraCertState era) => PParams era -> CertState era -> - TxBody era -> + TxBody l era -> Coin keyTxRefunds pp dpstate tx = case foldl' accum (initAccountsMap, Set.empty, mempty) certs of @@ -77,7 +77,7 @@ evaluateTransactionBalance :: PParams era -> CertState era -> UTxO era -> - TxBody era -> + TxBody TopTx era -> Value era evaluateTransactionBalance pp dpstate utxo txBody = evaluateTransactionBalanceShelley pp dpstate utxo txBody <> (txBody ^. mintValueTxBodyF) @@ -87,7 +87,7 @@ evaluateTransactionBalanceShelley :: PParams era -> CertState era -> UTxO era -> - TxBody era -> + TxBody TopTx era -> Value era evaluateTransactionBalanceShelley pp dpstate utxo txBody = consumed <-> produced where @@ -103,10 +103,10 @@ evaluateTransactionBalanceShelley pp dpstate utxo txBody = consumed <-> produced -- | Randomly lookup pool params and staking credentials to add them as unregistration and -- undelegation certificates respectively. genTxBodyFrom :: - (EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) => + (EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody l era), EraCertState era) => CertState era -> UTxO era -> - Gen (TxBody era) + Gen (TxBody l era) genTxBodyFrom certState (UTxO u) = do txBody <- arbitrary inputs <- sublistOf (Map.keys u) @@ -128,14 +128,19 @@ genTxBodyFrom certState (UTxO u) = do ) propEvalBalanceTxBody :: - (EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) => + ( EraUTxO era + , MaryEraTxBody era + , ShelleyEraTxCert era + , Arbitrary (TxBody TopTx era) + , EraCertState era + ) => PParams era -> CertState era -> UTxO era -> Property propEvalBalanceTxBody pp certState utxo = property $ - forAll (genTxBodyFrom certState utxo) $ \txBody -> + forAll (genTxBodyFrom @_ @TopTx certState utxo) $ \txBody -> evalBalanceTxBody pp lookupKeyDeposit (const Nothing) isRegPoolId utxo txBody `shouldBe` evaluateTransactionBalance pp certState utxo txBody where @@ -143,14 +148,14 @@ propEvalBalanceTxBody pp certState utxo = isRegPoolId = (`Map.member` psStakePools (certState ^. certPStateL)) propEvalBalanceShelleyTxBody :: - (EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era), EraCertState era) => + (EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody TopTx era), EraCertState era) => PParams era -> CertState era -> UTxO era -> Property propEvalBalanceShelleyTxBody pp certState utxo = property $ - forAll (genTxBodyFrom certState utxo) $ \txBody -> + forAll (genTxBodyFrom @_ @TopTx certState utxo) $ \txBody -> evalBalanceTxBody pp lookupKeyDeposit (const Nothing) isRegPoolId utxo txBody `shouldBe` evaluateTransactionBalanceShelley pp certState utxo txBody where diff --git a/libs/cardano-ledger-api/testlib/Test/Cardano/Ledger/Api/Upgrade.hs b/libs/cardano-ledger-api/testlib/Test/Cardano/Ledger/Api/Upgrade.hs index 92023ecfb1d..d39d8c92bd0 100644 --- a/libs/cardano-ledger-api/testlib/Test/Cardano/Ledger/Api/Upgrade.hs +++ b/libs/cardano-ledger-api/testlib/Test/Cardano/Ledger/Api/Upgrade.hs @@ -16,6 +16,7 @@ import Cardano.Ledger.Binary (DecCBOR, decNoShareCBOR, encodeMemPack) import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes (EqRaw (eqRaw)) import Data.Default (Default (def)) +import Data.Typeable (Typeable) import qualified Prettyprinter as Pretty import Test.Cardano.Ledger.Api.Arbitrary () import Test.Cardano.Ledger.Binary.RoundTrip @@ -164,13 +165,14 @@ specTxWitsUpgrade = do expectRawEqual "TxWits" curTxWits upgradedTxWits specTxBodyUpgrade :: - forall era. - ( EraApi era + forall era l. + ( Typeable l + , EraApi era , EraTxBody (PreviousEra era) - , Arbitrary (TxBody (PreviousEra era)) + , Arbitrary (TxBody l (PreviousEra era)) , HasCallStack - , ToExpr (TxBody era) - , DecCBOR (TxBody era) + , ToExpr (TxBody l era) + , DecCBOR (TxBody l era) ) => Spec specTxBodyUpgrade = do @@ -183,7 +185,7 @@ specTxBodyUpgrade = do "Expected to deserialize: =======================================================\n" ++ show err | otherwise -> pure () -- Both upgrade and deserializer fail successfully - Right (curTxBody :: TxBody era) + Right (curTxBody :: TxBody l era) | Right upgradedTxBody <- upgradeTxBody prevTxBody -> expectRawEqual "TxBody" curTxBody upgradedTxBody | otherwise -> expectationFailure "Expected upgradeTxBody to succeed" @@ -196,20 +198,21 @@ specTxBodyUpgrade = do "Expected to deserialize: =======================================================\n" ++ show err | otherwise -> pure () -- Both upgrade and deserializer fail successfully - Right (curTxBody :: TxBody era) + Right (curTxBody :: TxBody l era) | Right upgradedTxBody <- upgradeTxBody prevTxBody -> expectRawEqual "TxBody" curTxBody upgradedTxBody | otherwise -> expectationFailure "Expected upgradeTxBody to succeed" specTxUpgrade :: - forall era. - ( EraApi era + forall era l. + ( Typeable l + , EraApi era , EraTx (PreviousEra era) - , Arbitrary (Tx (PreviousEra era)) + , Arbitrary (Tx l (PreviousEra era)) , HasCallStack - , ToExpr (Tx era) - , DecCBOR (Tx era) - , EqRaw (Tx era) + , ToExpr (Tx l era) + , DecCBOR (Tx l era) + , EqRaw (Tx l era) ) => Spec specTxUpgrade = do @@ -222,7 +225,7 @@ specTxUpgrade = do "Expected to deserialize: =======================================================\n" ++ show err | otherwise -> pure () -- Both upgrade and deserializer fail successfully - Right (curTx :: Tx era) + Right (curTx :: Tx l era) | Right upgradedTx <- upgradeTx prevTx -> expectRawEqual "Tx" curTx upgradedTx | otherwise -> expectationFailure "Expected upgradeTx to succeed" @@ -235,7 +238,7 @@ specTxUpgrade = do "Expected to deserialize: =======================================================\n" ++ show err | otherwise -> pure () -- Both upgrade and deserializer fail successfully - Right (curTx :: Tx era) + Right (curTx :: Tx l era) | Right upgradedTx <- upgradeTx prevTx -> expectRawEqual "Tx" curTx upgradedTx | otherwise -> expectationFailure "Expected upgradeTx to succeed" @@ -247,21 +250,21 @@ spec :: , Arbitrary (TxCert (PreviousEra era)) , Arbitrary (TxAuxData (PreviousEra era)) , Arbitrary (TxWits (PreviousEra era)) - , Arbitrary (TxBody (PreviousEra era)) + , Arbitrary (TxBody TopTx (PreviousEra era)) , EraTx (PreviousEra era) - , Arbitrary (Tx (PreviousEra era)) + , Arbitrary (Tx TopTx (PreviousEra era)) , Arbitrary (Script (PreviousEra era)) , HasCallStack - , ToExpr (Tx era) - , ToExpr (TxBody era) + , ToExpr (Tx TopTx era) + , ToExpr (TxBody TopTx era) , ToExpr (TxWits era) , ToExpr (TxAuxData era) , DecCBOR (TxAuxData era) , DecCBOR (Script era) , DecCBOR (TxWits era) - , DecCBOR (TxBody era) - , DecCBOR (Tx era) - , EqRaw (Tx era) + , DecCBOR (TxBody TopTx era) + , DecCBOR (Tx TopTx era) + , EqRaw (Tx TopTx era) ) => BinaryUpgradeOpts -> Spec @@ -271,9 +274,9 @@ spec BinaryUpgradeOpts {isScriptUpgradeable, isTxUpgradeable} = specTxCertUpgrade @era specTxAuxDataUpgrade @era specTxWitsUpgrade @era - specTxBodyUpgrade @era + specTxBodyUpgrade @era @TopTx when isTxUpgradeable $ - specTxUpgrade @era + specTxUpgrade @era @TopTx when isScriptUpgradeable $ specScriptUpgrade @era -- This is a test that ensures that binary version of a TxOut is backwards compatible as it is diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Ledger.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Ledger.hs index f5fca56f57a..b1e934c9397 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Ledger.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Ledger.hs @@ -25,6 +25,7 @@ import Cardano.Ledger.Conway.Core ( EraTxOut (..), EraTxWits (..), ScriptHash, + TxLevel (..), ) import Cardano.Ledger.Conway.Rules (EnactState) import Cardano.Ledger.Shelley.LedgerState (LedgerState (..)) @@ -72,9 +73,9 @@ instance instance ( EraTx era - , ToExpr (Tx era) + , ToExpr (Tx TopTx era) , ToExpr (TxOut era) - , ToExpr (TxBody era) + , ToExpr (TxBody TopTx era) , ToExpr (TxWits era) , ToExpr (TxAuxData era) , ToExpr (PParamsHKD Identity era) @@ -87,7 +88,7 @@ instance ( EraPParams era , EraCertState era , EncCBOR (TxOut era) - , EncCBOR (Tx era) + , EncCBOR (Tx TopTx era) ) => EncCBOR (ConwayLedgerExecContext era) where 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..916c31539d2 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 @@ -25,6 +25,7 @@ import Cardano.Ledger.Conway.Core ( EraTx (..), EraTxBody (..), ScriptHash, + TxLevel (..), txIdTx, ) import Cardano.Ledger.Conway.Rules (EnactState) @@ -64,9 +65,9 @@ instance instance Inject ctx TxId => - SpecTranslate ctx (TxBody ConwayEra) + SpecTranslate ctx (TxBody TopTx ConwayEra) where - type SpecRep (TxBody ConwayEra) = Agda.TxBody + type SpecRep (TxBody TopTx ConwayEra) = Agda.TxBody toSpecRep txb = do txId <- askCtx @TxId @@ -90,8 +91,8 @@ instance <*> toSpecRep (txb ^. reqSignerHashesTxBodyL) <*> toSpecRep (txb ^. scriptIntegrityHashTxBodyL) -instance SpecTranslate ctx (Tx ConwayEra) where - type SpecRep (Tx ConwayEra) = Agda.Tx +instance SpecTranslate ctx (Tx TopTx ConwayEra) where + type SpecRep (Tx TopTx ConwayEra) = Agda.Tx toSpecRep tx = Agda.MkTx diff --git a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs index b3fd1358f09..79143962a5e 100644 --- a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs +++ b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs @@ -115,10 +115,10 @@ submitTxConformanceHook :: , SpecTranslate (ExecContext "LEDGER" era) (TxWits era) , HasCallStack , SpecRep (TxWits era) ~ Agda.TxWitnesses - , SpecRep (TxBody era) ~ Agda.TxBody - , SpecTranslate TxId (TxBody era) - , SpecTranslate (ConwayLedgerExecContext era) (Tx era) - , ToExpr (SpecRep (Tx era)) + , SpecRep (TxBody TopTx era) ~ Agda.TxBody + , SpecTranslate TxId (TxBody TopTx era) + , SpecTranslate (ConwayLedgerExecContext era) (Tx TopTx era) + , ToExpr (SpecRep (Tx TopTx era)) , SpecNormalize (SpecState "LEDGER" era) , Eq (SpecState "LEDGER" era) ) => diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 8af511d9203..dfebe8a26e2 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,11 @@ ## 1.19.0.0 +* Add `fromStrictMaybeL`, `toStrictMaybeL` +* Add `memoRawTypeL` +* Remove `getterMemoRawType` +* Add `EncCBOR` instance for `MemoBytes` +* Add `TxLevel`, `EraTxLevel`, `HasEraTxLevel` * Rename `PoolParams` to `StakePoolParams` - Replace the prefix for all the fields of this type from `pp*` -> `spp*` - Rename the lenses for the fields from `ppCostL`, `ppMetadataL` and `ppVrfL` to `sppCostL`, `sppMetadataL` and `sppVrfL` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index ef047b796af..32805b46e83 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -93,6 +93,7 @@ library Cardano.Ledger.Core.PParams Cardano.Ledger.Core.Translation Cardano.Ledger.Core.TxCert + Cardano.Ledger.Core.TxLevel Cardano.Ledger.Keys.Internal Cardano.Ledger.State.Account Cardano.Ledger.State.CertState diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index c796470568b..c9a7065ef6b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -4,11 +4,14 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,6 +26,9 @@ -- It is intended for qualified import: -- > import qualified Cardano.Ledger.Core as Core module Cardano.Ledger.Core ( + -- * Transaction types + module Cardano.Ledger.Core.TxLevel, + -- * Era-changing types EraTx (..), txIdTx, @@ -49,6 +55,8 @@ module Cardano.Ledger.Core ( binaryUpgradeTxBody, binaryUpgradeTxWits, binaryUpgradeTxAuxData, + fromStrictMaybeL, + toStrictMaybeL, -- * Era module Cardano.Ledger.Core.Era, @@ -100,6 +108,7 @@ import Cardano.Ledger.Core.Era import Cardano.Ledger.Core.PParams import Cardano.Ledger.Core.Translation import Cardano.Ledger.Core.TxCert +import Cardano.Ledger.Core.TxLevel import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Hashes hiding (GenDelegPair (..), GenDelegs (..), unsafeMakeSafeHash) import Cardano.Ledger.Keys.Bootstrap (BootstrapWitness, bootstrapWitKeyHash) @@ -119,7 +128,7 @@ import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust) -import Data.Maybe.Strict (StrictMaybe, strictMaybe) +import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe, strictMaybe, strictMaybeToMaybe) import Data.MemPack import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) @@ -138,32 +147,33 @@ class , EraTxWits era , EraTxAuxData era , EraPParams era - , NFData (Tx era) - , NoThunks (Tx era) - , DecCBOR (Annotator (Tx era)) - , EncCBOR (Tx era) - , ToCBOR (Tx era) - , Show (Tx era) - , Eq (Tx era) + , HasEraTxLevel Tx era + , forall l. Typeable l => NoThunks (Tx l era) + , forall l. Typeable l => DecCBOR (Annotator (Tx l era)) + , forall l. Typeable l => ToCBOR (Tx l era) + , forall l. EncCBOR (Tx l era) + , forall l. NFData (Tx l era) + , forall l. Show (Tx l era) + , forall l. Eq (Tx l era) ) => EraTx era where - data Tx era + data Tx (l :: TxLevel) era - mkBasicTx :: TxBody era -> Tx era + mkBasicTx :: TxBody l era -> Tx l era - bodyTxL :: Lens' (Tx era) (TxBody era) + bodyTxL :: Lens' (Tx l era) (TxBody l era) - witsTxL :: Lens' (Tx era) (TxWits era) + witsTxL :: Lens' (Tx l era) (TxWits era) - auxDataTxL :: Lens' (Tx era) (StrictMaybe (TxAuxData era)) + auxDataTxL :: Lens' (Tx l era) (StrictMaybe (TxAuxData era)) -- | For fee calculation and estimations of impact on block space - sizeTxF :: HasCallStack => SimpleGetter (Tx era) Word32 + sizeTxF :: HasCallStack => SimpleGetter (Tx l era) Word32 -- | For fee calculation and estimations of impact on block space -- To replace `sizeTxF` after it has been proved equivalent to it . - sizeTxForFeeCalculation :: (HasCallStack, SafeToHash (TxWits era)) => Tx era -> Word32 + sizeTxForFeeCalculation :: (HasCallStack, SafeToHash (TxWits era), Typeable l) => Tx l era -> Word32 sizeTxForFeeCalculation tx = errorFail $ integralToBounded @Int @Word32 $ @@ -173,12 +183,12 @@ class + 1 -- account for the top-level CBOR encoding tag -- | Using information from the transaction validate the supplied native script. - validateNativeScript :: Tx era -> NativeScript era -> Bool + validateNativeScript :: Tx l era -> NativeScript era -> Bool -- | Minimum fee calculation excluding witnesses getMinFeeTx :: PParams era -> - Tx era -> + Tx l era -> -- | Size in bytes of reference scripts present in this transaction Int -> Coin @@ -187,44 +197,45 @@ 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) + , HasEraTxLevel TxBody era + , forall l. HashAnnotated (TxBody l era) EraIndependentTxBody + , forall l. EncCBOR (TxBody l era) + , forall l. Typeable l => DecCBOR (Annotator (TxBody l era)) + , forall l. Typeable l => ToCBOR (TxBody l era) + , forall l. Typeable l => NoThunks (TxBody l era) + , forall l. NFData (TxBody l era) + , forall l. Show (TxBody l era) + , forall l. Eq (TxBody l era) + , forall l. EqRaw (TxBody l era) ) => EraTxBody era where -- | The body of a transaction. - data TxBody era + data TxBody (l :: TxLevel) era - mkBasicTxBody :: TxBody era + mkBasicTxBody :: Typeable l => TxBody l era - inputsTxBodyL :: Lens' (TxBody era) (Set TxIn) + inputsTxBodyL :: Lens' (TxBody l era) (Set TxIn) - outputsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxOut era)) + outputsTxBodyL :: Lens' (TxBody l era) (StrictSeq (TxOut era)) - feeTxBodyL :: Lens' (TxBody era) Coin + feeTxBodyL :: Lens' (TxBody TopTx era) Coin - withdrawalsTxBodyL :: Lens' (TxBody era) Withdrawals + withdrawalsTxBodyL :: Lens' (TxBody l era) Withdrawals - auxDataHashTxBodyL :: Lens' (TxBody era) (StrictMaybe TxAuxDataHash) + auxDataHashTxBodyL :: Lens' (TxBody l 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 (TxBody l 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 (TxBody TopTx era) (Set TxIn) - certsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxCert era)) + certsTxBodyL :: Lens' (TxBody l era) (StrictSeq (TxCert era)) -- | Compute the total deposits from the certificates in a TxBody. -- @@ -233,7 +244,7 @@ class PParams era -> -- | Check whether stake pool is registered or not (KeyHash 'StakePool -> Bool) -> - TxBody era -> + TxBody l era -> Coin getTotalDepositsTxBody pp isPoolRegisted txBody = getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) @@ -247,14 +258,14 @@ class (Credential 'Staking -> Maybe Coin) -> -- | Lookup current deposit for DRep credential if one is registered (Credential 'DRepRole -> Maybe Coin) -> - TxBody era -> + TxBody l era -> Coin getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) -- | 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 + getGenesisKeyHashCountTxBody :: TxBody TopTx era -> Int getGenesisKeyHashCountTxBody _ = 0 -- | Abstract interface into specific fields of a `TxOut` @@ -579,7 +590,7 @@ hashScript = -- | Indicates that an era supports segregated witnessing. -- -- This class embodies an isomorphism between 'BlockBody era' and 'StrictSeq --- (Tx era)', witnessed by the `txSeqBlockBodyL` lens. +-- (Tx l era)', witnessed by the `txSeqBlockBodyL` lens. class ( EraTx era , Eq (BlockBody era) @@ -594,12 +605,12 @@ class mkBasicBlockBody :: BlockBody era - txSeqBlockBodyL :: Lens' (BlockBody era) (StrictSeq (Tx era)) + txSeqBlockBodyL :: Lens' (BlockBody era) (StrictSeq (Tx TopTx era)) - fromTxSeq :: BlockBody era -> StrictSeq (Tx era) + fromTxSeq :: BlockBody era -> StrictSeq (Tx TopTx era) fromTxSeq = (^. txSeqBlockBodyL) - toTxSeq :: StrictSeq (Tx era) -> BlockBody era + toTxSeq :: StrictSeq (Tx TopTx era) -> BlockBody era toTxSeq s = mkBasicBlockBody & txSeqBlockBodyL .~ s -- | Get the block body hash from the BlockBody. Note that this is not a regular @@ -622,14 +633,14 @@ class bBodySize :: forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int bBodySize (ProtVer v _) = BS.length . serialize' v . encCBORGroup -txIdTx :: EraTx era => Tx era -> TxId +txIdTx :: EraTx era => Tx l era -> TxId txIdTx tx = txIdTxBody (tx ^. bodyTxL) -txIdTxBody :: EraTxBody era => TxBody era -> TxId +txIdTxBody :: EraTxBody era => TxBody l era -> TxId txIdTxBody = TxId . hashAnnotated -- | txsize computes the length of the serialised bytes (actual size) -wireSizeTxF :: forall era. EraTx era => SimpleGetter (Tx era) Word32 +wireSizeTxF :: forall era l. EraTx era => SimpleGetter (Tx l era) Word32 wireSizeTxF = to $ checkedFromIntegral @@ -645,18 +656,18 @@ wireSizeTxF = -- | Translate a transaction through its binary representation from previous to current era. binaryUpgradeTx :: - forall era. - (Era era, ToCBOR (Tx (PreviousEra era)), DecCBOR (Annotator (Tx era))) => - Tx (PreviousEra era) -> - Except DecoderError (Tx era) + forall era l. + (Era era, ToCBOR (Tx l (PreviousEra era)), DecCBOR (Annotator (Tx l era))) => + Tx l (PreviousEra era) -> + Except DecoderError (Tx l era) binaryUpgradeTx = translateViaCBORAnnotator (eraProtVerLow @era) (withEraName @era "Tx") -- | Translate a tx body through its binary representation from previous to current era. binaryUpgradeTxBody :: - forall era. - (Era era, ToCBOR (TxBody (PreviousEra era)), DecCBOR (Annotator (TxBody era))) => - TxBody (PreviousEra era) -> - Except DecoderError (TxBody era) + forall era l. + (Era era, ToCBOR (TxBody l (PreviousEra era)), DecCBOR (Annotator (TxBody l era))) => + TxBody l (PreviousEra era) -> + Except DecoderError (TxBody l era) binaryUpgradeTxBody = translateViaCBORAnnotator (eraProtVerLow @era) (withEraName @era "TxBody") -- | Translate tx witnesses through its binary representation from previous to current era. @@ -677,3 +688,9 @@ binaryUpgradeTxAuxData = translateViaCBORAnnotator (eraProtVerLow @era) (withEra withEraName :: forall era. Era era => Text -> Text withEraName t = t <> " " <> T.pack (eraName @era) <> "Era" + +toStrictMaybeL :: Lens' (Maybe a) (StrictMaybe a) +toStrictMaybeL = lens maybeToStrictMaybe (const strictMaybeToMaybe) + +fromStrictMaybeL :: Lens' (StrictMaybe a) (Maybe a) +fromStrictMaybeL = lens strictMaybeToMaybe (const maybeToStrictMaybe) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxLevel.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxLevel.hs new file mode 100644 index 00000000000..7aa8f2e0fde --- /dev/null +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxLevel.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Cardano.Ledger.Core.TxLevel ( + TxLevel (..), + STxTopLevel (..), + withSTxTopLevelM, + STxBothLevels (..), + withSTxBothLevels, + EraTxLevel (..), + HasEraTxLevel (..), + asSTxTopLevel, + mkSTxTopLevelM, + withTopTxLevelOnly, + asSTxBothLevels, + mkSTxBothLevelsM, + withBothTxLevels, +) where + +import Cardano.Ledger.Core.Era (Era (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Fail.String +import Data.Functor.Identity (Identity (..), runIdentity) +import Data.Kind (Type) +import Data.Typeable +import GHC.Stack + +type data TxLevel = TopTx | SubTx + +data STxTopLevel (l :: TxLevel) era where + STopTxOnly :: STxTopLevel TopTx era + +withSTxTopLevelM :: + forall l era a m. (Typeable l, Era era, MonadFail m) => (STxTopLevel l era -> m a) -> m a +withSTxTopLevelM f = + case eqT @l @TopTx of + Just Refl -> f STopTxOnly + Nothing -> fail $ "SubTx level is not supported in the " <> eraName @era <> " era" + +data STxBothLevels (l :: TxLevel) era where + STopTx :: STxBothLevels TopTx era + SSubTx :: STxBothLevels SubTx era + +withSTxBothLevels :: forall l era a. (Typeable l, HasCallStack) => (STxBothLevels l era -> a) -> a +withSTxBothLevels f = + case eqT @l @TopTx of + Just Refl -> f STopTx + Nothing -> case eqT @l @SubTx of + Just Refl -> f SSubTx + Nothing -> error $ "Impossible: Unrecognized TxLevel: " <> show (typeRep (Proxy @l)) + +class Era era => EraTxLevel era where + -- | Supported transaction level as a singleton. One of these two should be used: + -- + -- * `STxTopLevel` - for eras up to and including Conway, that do not support nested transactions. + -- * `STxBothLevels` - for Dijkstra onwards that do support nested transactions. + type STxLevel (l :: TxLevel) era = (r :: Type) | r -> era + + type STxLevel l era = STxBothLevels l era + +-- | Type class for data families that have different definition depending on the level. Currently +-- it is only `Cardano.Ledger.Core.Tx` and `Cardano.Ledger.Core.TxBody` that have this distinction. +class EraTxLevel era => HasEraTxLevel (t :: TxLevel -> Type -> Type) era where + toSTxLevel :: t l era -> STxLevel l era + +mkSTxTopLevelM :: + forall (l :: TxLevel) t m era. + (Typeable l, Monad m, HasEraTxLevel t era, STxLevel l era ~ STxTopLevel l era) => + m (t TopTx era) -> m (t l era) +mkSTxTopLevelM mkTopTx = do + fmap (either error id) $ runFailT $ withSTxTopLevelM @l @era $ \level -> + case level of + STopTxOnly -> do + res <- lift mkTopTx + -- Here we tell the compiler that we only expect top level transactions in this function and + -- any attempt to construct a sub transaction level will result in a compiler error, + -- instead of a trigger of `fail` in `MonadFail`, as `withSTxTopLevelM` would normally do. + let _level = asTypeOf (toSTxLevel res) level + pure res + +asSTxTopLevel :: + forall (l :: TxLevel) t era. + (Typeable l, HasEraTxLevel t era, STxLevel l era ~ STxTopLevel l era) => + t TopTx era -> t l era +asSTxTopLevel = runIdentity . mkSTxTopLevelM . pure + +withTopTxLevelOnly :: + (HasEraTxLevel t era, STxLevel l era ~ STxTopLevel l era) => + t l era -> (t TopTx era -> a) -> a +withTopTxLevelOnly t f = + case toSTxLevel t of + STopTxOnly -> f t + +mkSTxBothLevelsM :: + forall (l :: TxLevel) t m era. + (Typeable l, Monad m, HasEraTxLevel t era, STxLevel l era ~ STxBothLevels l era) => + m (t TopTx era) -> m (t SubTx era) -> m (t l era) +mkSTxBothLevelsM mkTopTx mkSubTx = + withSTxBothLevels @l $ \level -> do + res <- case level of + STopTx -> mkTopTx + SSubTx -> mkSubTx + -- Tell the compiler that we expect only `STxBothLevels` in this action + let _level = asTypeOf (toSTxLevel res) level + pure res + +asSTxBothLevels :: + forall (l :: TxLevel) t era. + (Typeable l, HasEraTxLevel t era, STxLevel l era ~ STxBothLevels l era) => + t TopTx era -> t SubTx era -> t l era +asSTxBothLevels mkTopTx mkSubTx = runIdentity $ mkSTxBothLevelsM (pure mkTopTx) (pure mkSubTx) + +withBothTxLevels :: + (HasEraTxLevel t era, STxLevel l era ~ STxBothLevels l era) => + t l era -> (t TopTx era -> a) -> (t SubTx era -> a) -> a +withBothTxLevels t fTop fSub = + case toSTxLevel t of + STopTx -> fTop t + SSubTx -> fSub t diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs index d1f84207d45..8f510ed1195 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs @@ -28,7 +28,7 @@ module Cardano.Ledger.MemoBytes ( eqRawType, getMemoRawBytes, lensMemoRawType, - getterMemoRawType, + memoRawTypeL, -- * MemoBytes MemPack definitions byteCountMemoBytes, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs index aae3b5a6a14..314a99c15e8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -57,7 +57,7 @@ module Cardano.Ledger.MemoBytes.Internal ( eqRawType, getMemoRawBytes, lensMemoRawType, - getterMemoRawType, + memoRawTypeL, -- * MemoBytes MemPack instance definitions byteCountMemoBytes, @@ -74,10 +74,11 @@ import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (decCBOR), Decoder, - EncCBOR, + EncCBOR (..), Version, decodeAnnotated, decodeFullAnnotator, + encodePreEncoded, serialize, withSlice, ) @@ -164,6 +165,9 @@ deriving instance NFData t => NFData (MemoBytes t) instance Typeable t => Plain.ToCBOR (MemoBytes t) where toCBOR (MemoBytes _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes) +instance EncCBOR (MemoBytes t) where + encCBOR (MemoBytes _ bytes _hash) = encodePreEncoded (fromShort bytes) + instance DecCBOR t => DecCBOR (MemoBytes t) where decCBOR = decodeMemoized decCBOR @@ -333,14 +337,14 @@ lensMemoRawType getter setter = lens (getter . getMemoRawType) (\t b -> mkMemoizedEra @era $ setter (getMemoRawType t) b) {-# INLINEABLE lensMemoRawType #-} --- | This is a helper SimpleGetter creator for any Memoized type -getterMemoRawType :: - Memoized t => - (RawType t -> a) -> - SimpleGetter t a -getterMemoRawType getter = - to (getter . getMemoRawType) -{-# INLINEABLE getterMemoRawType #-} +memoRawTypeL :: + forall era t. + ( Era era + , EncCBOR (RawType t) + , Memoized t + ) => + Lens' t (RawType t) +memoRawTypeL = lensMemoRawType @era id (\_ x -> x) -- | Type class that implements equality on the Haskell type, ignoring any of the -- potentially memoized binary representation of the type. diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs index e6799fa0292..dbe41ff5358 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs @@ -361,13 +361,13 @@ class -- -- This is the contribution of a TxBody towards the deposit pot (utxosDeposit field of -- the UTxOState) of the system - certsTotalDepositsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody era -> Coin + certsTotalDepositsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody t era -> Coin -- | Compute the total refunds from the Certs of a TxBody. -- -- This is the contribution of a TxBody towards the total 'Obligations' of the system -- See `Obligations` and `obligationCertState` for more information. - certsTotalRefundsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody era -> Coin + certsTotalRefundsTxBody :: EraTxBody era => PParams era -> CertState era -> TxBody t era -> Coin instance EncCBOR InstantaneousRewards where encCBOR (InstantaneousRewards irR irT dR dT) = diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/UTxO.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/UTxO.hs index eced02526eb..8b7d6febe7b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/UTxO.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/UTxO.hs @@ -134,15 +134,15 @@ deriving newtype instance ToJSON (TxOut era) => ToJSON (UTxO era) -- txins has the same problems as txouts, see notes below. txins :: EraTxBody era => - TxBody era -> + TxBody t era -> Set TxIn txins = (^. inputsTxBodyL) -- | Compute the transaction outputs of a transaction. txouts :: - forall era. + forall era l. EraTxBody era => - TxBody era -> + TxBody l era -> UTxO era txouts txBody = UTxO $ @@ -248,7 +248,7 @@ class EraTx era => EraUTxO era where -- scripts needed for the transaction. type ScriptsNeeded era = (r :: Type) | r -> era - consumed :: PParams era -> CertState era -> UTxO era -> TxBody era -> Value era + consumed :: PParams era -> CertState era -> UTxO era -> TxBody t era -> Value era -- | Calculate all the value that is being consumed by the transaction. getConsumedValue :: @@ -258,14 +258,14 @@ class EraTx era => EraUTxO era where -- | Function that can lookup current drep deposits (Credential 'DRepRole -> Maybe Coin) -> UTxO era -> - TxBody era -> + TxBody t era -> Value era getProducedValue :: PParams era -> -- | Check whether a pool with a supplied PoolStakeId is already registered. (KeyHash 'StakePool -> Bool) -> - TxBody era -> + TxBody t era -> Value era -- | Initial eras will look into witness set to find all of the available scripts, but @@ -275,19 +275,19 @@ class EraTx era => EraUTxO era where -- | For some era it is necessary to look into the UTxO to find all of the available -- scripts for the transaction UTxO era -> - Tx era -> + Tx t era -> ScriptsProvided era -- | Produce all the information required for figuring out which scripts are required -- for the transaction to be valid, once those scripts are evaluated - getScriptsNeeded :: UTxO era -> TxBody era -> ScriptsNeeded era + getScriptsNeeded :: UTxO era -> TxBody t era -> ScriptsNeeded era -- | Extract the set of all script hashes that are needed for script validation. getScriptsHashesNeeded :: ScriptsNeeded era -> Set ScriptHash -- | Extract all of the KeyHash witnesses that are required for validating the transaction getWitsVKeyNeeded :: - CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness) + CertState era -> UTxO era -> TxBody t era -> Set (KeyHash 'Witness) -- | Minimum fee computation, excluding witnesses and including ref scripts size - getMinFeeTxUtxo :: PParams era -> Tx era -> UTxO era -> Coin + getMinFeeTxUtxo :: PParams era -> Tx t era -> UTxO era -> Coin diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs index 562e94ec070..06129ebc6b0 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs @@ -61,14 +61,14 @@ import Lens.Micro setMinFeeTx :: EraTx era => PParams era -> - Tx era -> + Tx TopTx era -> -- | Size in bytes of reference scripts present in this transaction Int -> - Tx era + Tx TopTx era setMinFeeTx pp tx refScriptsSize = setMinFeeTxInternal (\t -> getMinFeeTx pp t refScriptsSize) tx -setMinFeeTxUtxo :: EraUTxO era => PParams era -> Tx era -> UTxO era -> Tx era +setMinFeeTxUtxo :: EraUTxO era => PParams era -> Tx TopTx era -> UTxO era -> Tx TopTx era setMinFeeTxUtxo pp tx utxo = setMinFeeTxInternal (\t -> getMinFeeTxUtxo pp t utxo) tx @@ -85,9 +85,9 @@ ensureMinCoinTxOut = setMinCoinTxOutWith (>=) setMinFeeTxInternal :: EraTx era => - (Tx era -> Coin) -> - Tx era -> - Tx era + (Tx TopTx era -> Coin) -> + Tx TopTx era -> + Tx TopTx era setMinFeeTxInternal f tx = let curMinFee = f tx curFee = tx ^. bodyTxL . feeTxBodyL @@ -109,7 +109,7 @@ calcMinFeeTxNativeScriptWits :: -- | The current protocol parameters. PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | KeyHash witnesses that will be supplied for satisfying native scripts. It is -- impossible to know how many of these is required without knowing the actual witnesses -- supplied and the time when the transaction will be submitted. Therefore we put this @@ -140,7 +140,7 @@ calcMinFeeTx :: -- | The current protocol parameters. PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | Number of extra KeyHash witnesses that will be supplied for satisfying native -- scripts. It is impossible to know how many of these is required without knowing the -- actual witnesses supplied and the time when the transaction will be @@ -163,7 +163,7 @@ calcMinFeeTxInternal :: -- | The current protocol parameters. PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | Number of KeyHash witnesses that will be supplied for native scripts Int -> -- | KeyHash witnesses that will be supplied for native scripts @@ -199,7 +199,7 @@ estimateMinFeeTx :: -- | The current protocol parameters. PParams era -> -- | The transaction. - Tx era -> + Tx TopTx era -> -- | The number of key witnesses still to be added to the transaction. Int -> -- | The number of Byron key witnesses still to be added to the transaction. @@ -231,18 +231,18 @@ byteStringToNum = BS.foldr (\w i -> i `shiftL` 8 + fromIntegral w) 0 -- | Create dummy witnesses and add them to the transaction addDummyWitsTx :: - forall era. + forall era l. EraTx era => -- | The current protocol parameters. PParams era -> -- | The transaction. - Tx era -> + Tx l era -> -- | The number of key witnesses still to be added to the transaction. Int -> -- | List of attributes from TxOuts with Byron addresses that are being spent [Byron.Attributes Byron.AddrAttributes] -> -- | The required minimum fee. - Tx era + Tx l era addDummyWitsTx pp tx numKeyWits byronAttrs = tx & (witsTxL . addrTxWitsL <>~ dummyKeyWits) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs index 57af50cf54c..026821e7bd7 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs @@ -25,12 +25,12 @@ import Test.Cardano.Ledger.Core.Binary.Annotator txSizeSpec :: forall era. ( EraTx era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , SafeToHash (TxWits era) ) => Spec txSizeSpec = describe "Transaction size" $ do - prop "should match the size of the cbor encoding" $ \(tx :: Tx era) -> do + prop "should match the size of the cbor encoding" $ \(tx :: Tx TopTx era) -> do let txSize = sizeTxForFeeCalculation tx txSize `shouldBe` tx ^. sizeTxF diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Annotator.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Annotator.hs index 9e4a2f2a681..e8f039921d2 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Annotator.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Annotator.hs @@ -49,8 +49,8 @@ decoderEquivalenceEraSpec = decoderEquivalenceSpec @t (eraProtVerLow @era) (eraP decoderEquivalenceCoreEraTypesSpec :: forall era. ( EraTx era - , Arbitrary (Tx era) - , Arbitrary (TxBody era) + , Arbitrary (Tx TopTx era) + , Arbitrary (TxBody TopTx era) , Arbitrary (TxWits era) , Arbitrary (TxAuxData era) , Arbitrary (Script era) @@ -63,5 +63,5 @@ decoderEquivalenceCoreEraTypesSpec = decoderEquivalenceEraSpec @era @(Script era) decoderEquivalenceEraSpec @era @(TxAuxData era) decoderEquivalenceEraSpec @era @(TxWits era) - decoderEquivalenceEraSpec @era @(TxBody era) - decoderEquivalenceEraSpec @era @(Tx era) + decoderEquivalenceEraSpec @era @(TxBody TopTx era) + decoderEquivalenceEraSpec @era @(Tx TopTx era) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs index 11d1d5db110..9247ce78559 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -188,8 +189,8 @@ roundTripCoreEraTypesSpec :: forall era. ( EraTx era , EraCertState era - , Arbitrary (Tx era) - , Arbitrary (TxBody era) + , Arbitrary (Tx TopTx era) + , Arbitrary (TxBody TopTx era) , Arbitrary (TxOut era) , Arbitrary (TxCert era) , Arbitrary (TxWits era) @@ -204,8 +205,8 @@ roundTripCoreEraTypesSpec :: , DecCBOR (Script era) , DecCBOR (TxAuxData era) , DecCBOR (TxWits era) - , DecCBOR (TxBody era) - , DecCBOR (Tx era) + , DecCBOR (TxBody TopTx era) + , DecCBOR (Tx TopTx era) , Typeable (CertState era) , HasCallStack ) => @@ -224,10 +225,10 @@ roundTripCoreEraTypesSpec = do roundTripEraSpec @era @(TxAuxData era) roundTripAnnEraSpec @era @(TxWits era) roundTripEraSpec @era @(TxWits era) - roundTripAnnEraSpec @era @(TxBody era) - roundTripEraSpec @era @(TxBody era) - roundTripAnnEraSpec @era @(Tx era) - roundTripEraSpec @era @(Tx era) + roundTripAnnEraSpec @era @(TxBody TopTx era) + roundTripEraSpec @era @(TxBody TopTx era) + roundTripAnnEraSpec @era @(Tx TopTx era) + roundTripEraSpec @era @(Tx TopTx era) prop ("MemPack/CBOR Roundtrip " <> show (typeRep $ Proxy @(TxOut era))) $ roundTripRangeExpectation @(TxOut era) (mkTrip encodeMemPack decNoShareCBOR) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs index fb54775e974..0ba68776841 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs @@ -45,7 +45,7 @@ testGlobals = mkDummySafeHash :: forall a. Int -> SafeHash a mkDummySafeHash = unsafeMakeSafeHash . mkDummyHash @HASH -txInAt :: (HasCallStack, EraTx era) => Int -> Tx era -> TxIn +txInAt :: (HasCallStack, EraTx era) => Int -> Tx l era -> TxIn txInAt index tx = let txId = txIdTx tx in mkTxInPartial txId (toInteger index) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs index 5586171e833..376f92ef126 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableSuperClasses #-} module Test.Cardano.Ledger.Era ( @@ -35,11 +36,11 @@ class , EraAccounts era , EraGenesis era , -- Arbitrary Core - Arbitrary (Tx era) + Arbitrary (Tx TopTx era) + , Arbitrary (TxBody TopTx era) + , Arbitrary (TxWits era) , Arbitrary (TxOut era) - , Arbitrary (TxBody era) , Arbitrary (TxAuxData era) - , Arbitrary (TxWits era) , Arbitrary (Script era) , Arbitrary (PParamsHKD Identity era) , Arbitrary (PParamsHKD StrictMaybe era) @@ -53,11 +54,11 @@ class , Arbitrary (Accounts era) , Arbitrary (AccountState era) , -- ToExpr Core - ToExpr (Tx era) + ToExpr (Tx TopTx era) + , ToExpr (TxBody TopTx era) + , ToExpr (TxWits era) , ToExpr (TxOut era) - , ToExpr (TxBody era) , ToExpr (TxAuxData era) - , ToExpr (TxWits era) , ToExpr (Script era) , ToExpr (PParamsHKD Identity era) , ToExpr (PParamsHKD StrictMaybe era) @@ -75,8 +76,8 @@ class , DecCBOR (NativeScript era) , DecCBOR (TxAuxData era) , DecCBOR (TxWits era) - , DecCBOR (TxBody era) - , DecCBOR (Tx era) + , DecCBOR (TxBody TopTx era) + , DecCBOR (Tx TopTx era) , -- TranslationContext Eq (TranslationContext era) , Show (TranslationContext era) diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs index f58245b7e2f..f1466e6d321 100644 --- a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs +++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs @@ -64,7 +64,7 @@ benchWithGenState :: , EraGen era , HasTrace (EraRule "LEDGER" era) (GenEnv MockCrypto era) , BaseEnv (EraRule "LEDGER" era) ~ Globals - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era , EraStake era @@ -83,7 +83,7 @@ benchApplyTx :: , ApplyTx era , HasTrace (EraRule "LEDGER" era) (GenEnv MockCrypto era) , BaseEnv (EraRule "LEDGER" era) ~ Globals - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era , EraStake era @@ -116,16 +116,16 @@ deserialiseTxEra :: , HasTrace (EraRule "LEDGER" era) (GenEnv MockCrypto era) , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , EraStake era , EraGov era - , DecCBOR (Tx era) + , DecCBOR (Tx TopTx era) ) => Proxy era -> Benchmark deserialiseTxEra px = benchWithGenState px (pure . Plain.serialize . ateTx) $ - nf (either (error . show) (id @(Tx era)) . decodeFull v) + nf (either (error . show) (id @(Tx TopTx era)) . decodeFull v) where v = eraProtVerHigh @era @@ -136,7 +136,7 @@ deserialiseAnnTxEra :: , HasTrace (EraRule "LEDGER" era) (GenEnv MockCrypto era) , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , EraStake era , EraGov era ) => @@ -144,7 +144,7 @@ deserialiseAnnTxEra :: Benchmark deserialiseAnnTxEra px = benchWithGenState px (pure . Plain.serialize . ateTx) $ - nf (either (error . show) (id @(Tx era)) . decodeFullAnnotator v "tx" decCBOR) + nf (either (error . show) (id @(Tx TopTx era)) . decodeFullAnnotator v "tx" decCBOR) where v = eraProtVerHigh @era diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx/Gen.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx/Gen.hs index 651895045c1..0cb7d45b78b 100644 --- a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx/Gen.hs +++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx/Gen.hs @@ -60,7 +60,7 @@ data ApplyTxEnv era = ApplyTxEnv { ateGlobals :: Globals , ateMempoolEnv :: MempoolEnv era , ateState :: LedgerState era - , ateTx :: Tx era + , ateTx :: Tx TopTx era } deriving (Generic) @@ -73,7 +73,7 @@ generateApplyTxEnvForEra :: ( EraGen era , HasTrace (EraRule "LEDGER" era) (GenEnv MockCrypto era) , BaseEnv (EraRule "LEDGER" era) ~ Globals - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era , EraStake era diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Serialisation/Generators.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Serialisation/Generators.hs index 07a41bc7347..cbb06033fa9 100644 --- a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Serialisation/Generators.hs +++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/Serialisation/Generators.hs @@ -10,15 +10,15 @@ import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () import Test.QuickCheck -genTxShelley :: IO (Tx ShelleyEra) +genTxShelley :: IO (Tx TopTx ShelleyEra) genTxShelley = generate arbitrary -- | Generate an arbitrary Allegra transaction -genTxAllegra :: IO (Tx AllegraEra) +genTxAllegra :: IO (Tx TopTx AllegraEra) genTxAllegra = generate arbitrary -- | Generate an arbitrary Mary transaction -genTxMary :: IO (Tx MaryEra) +genTxMary :: IO (Tx TopTx MaryEra) genTxMary = generate arbitrary benchTxGeneration :: Benchmark diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Certs.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Certs.hs index 23c482c5b3a..099041defc2 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Certs.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Certs.hs @@ -28,11 +28,11 @@ import Test.Cardano.Ledger.Constrained.Conway.WitnessUniverse setMapMaybe :: Ord a => (t -> Maybe a) -> Set t -> Set a setMapMaybe f set = Set.foldr' (\x s -> maybe s (`Set.insert` s) $ f x) mempty set -txZero :: EraTx era => Tx era +txZero :: EraTx era => Tx TopTx era txZero = mkBasicTx mkBasicTxBody certsEnvSpec :: - (EraSpecPParams era, HasSpec (Tx era)) => + (EraSpecPParams era, HasSpec (Tx TopTx era)) => Specification (CertsEnv era) certsEnvSpec = constrained $ \ce -> match ce $ \tx pp _currepoch _currcommittee commproposals -> diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs index baec83bf460..72e4f7a910f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs @@ -184,10 +184,10 @@ type ConwayTxBodyTypes = , Coin ] -instance HasSpec (TxBody ConwayEra) +instance HasSpec (TxBody TopTx ConwayEra) -instance HasSimpleRep (TxBody ConwayEra) where - type TheSop (TxBody ConwayEra) = '["ConwayTxBody" ::: ConwayTxBodyTypes] +instance HasSimpleRep (TxBody TopTx ConwayEra) where + type TheSop (TxBody TopTx ConwayEra) = '["ConwayTxBody" ::: ConwayTxBodyTypes] toSimpleRep ConwayTxBody {..} = inject @"ConwayTxBody" @'["ConwayTxBody" ::: ConwayTxBodyTypes] ctbSpendInputs @@ -1496,29 +1496,52 @@ instance -- Unlike ShelleyTx, AlonzoTx is just a data type, and the generic instances work fine -- BUT, all the type families inside need constraints +type AlonzoTxTypes era = + '[ TxBody TopTx era + , TxWits era + , IsValid + , Maybe (TxAuxData era) + ] + instance ( Typeable (TxAuxData era) - , Typeable (TxBody era) + , Typeable (TxBody TopTx era) , Typeable (TxWits era) , Era era ) => - HasSimpleRep (AlonzoTx era) + HasSimpleRep (AlonzoTx TopTx era) + where + type + TheSop (AlonzoTx TopTx era) = + '["AlonzoTx" ::: AlonzoTxTypes era] + toSimpleRep AlonzoTx {..} = + inject @"AlonzoTx" @'["AlonzoTx" ::: AlonzoTxTypes era] + atBody + atWits + atIsValid + (strictMaybeToMaybe atAuxData) + fromSimpleRep rep = + algebra @'["AlonzoTx" ::: AlonzoTxTypes era] + rep + ( \body wits isValid auxData -> + AlonzoTx body wits isValid (maybeToStrictMaybe auxData) + ) instance ( EraSpecPParams era - , HasSpec (TxBody era) + , HasSpec (TxBody TopTx era) , HasSpec (TxWits era) , HasSpec (TxAuxData era) , IsNormalType (TxAuxData era) ) => - HasSpec (AlonzoTx era) + HasSpec (AlonzoTx TopTx era) -- NOTE: this is a representation of the `ShelleyTx` type. You can't -- simply use the generics to derive the `SimpleRep` for `ShelleyTx` -- because the type is memoized. So instead we say that the representation -- is the same as what you would get from using the `ShelleyTx` pattern. type ShelleyTxTypes era = - '[ TxBody era + '[ TxBody TopTx era , TxWits era , Maybe (TxAuxData era) ] @@ -1527,22 +1550,22 @@ instance ( EraTxOut era , EraTx era , EraSpecPParams era - , HasSpec (TxBody era) + , HasSpec (TxBody TopTx era) , HasSpec (TxWits era) , HasSpec (TxAuxData era) , IsNormalType (TxAuxData era) ) => - HasSpec (ShelleyTx era) + HasSpec (ShelleyTx TopTx era) -instance HasSimpleRep (Tx ConwayEra) where - type TheSop (Tx ConwayEra) = TheSop (AlonzoTx ConwayEra) +instance HasSimpleRep (Tx TopTx ConwayEra) where + type TheSop (Tx TopTx ConwayEra) = TheSop (AlonzoTx TopTx ConwayEra) toSimpleRep = toSimpleRep . unConwayTx fromSimpleRep = MkConwayTx . fromSimpleRep -instance HasSpec (Tx ConwayEra) +instance HasSpec (Tx TopTx ConwayEra) -instance (EraTx era, EraTxOut era, EraSpecPParams era) => HasSimpleRep (ShelleyTx era) where - type TheSop (ShelleyTx era) = '["ShelleyTx" ::: ShelleyTxTypes era] +instance (EraTx era, EraTxOut era, EraSpecPParams era) => HasSimpleRep (ShelleyTx TopTx era) where + type TheSop (ShelleyTx TopTx era) = '["ShelleyTx" ::: ShelleyTxTypes era] toSimpleRep (ShelleyTx body wits auxdata) = inject @"ShelleyTx" @'["ShelleyTx" ::: ShelleyTxTypes era] body @@ -1826,9 +1849,9 @@ instance HasSimpleRep Pulser where instance HasSpec Pulser -instance (Typeable (Tx era), Typeable era) => HasSimpleRep (CertsEnv era) +instance (Typeable (Tx TopTx era), Typeable era) => HasSimpleRep (CertsEnv era) -instance (EraGov era, EraTx era, EraSpecPParams era, HasSpec (Tx era)) => HasSpec (CertsEnv era) +instance (EraGov era, EraTx era, EraSpecPParams era, HasSpec (Tx TopTx era)) => HasSpec (CertsEnv era) -- CompactForm diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/TxBody.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/TxBody.hs index 11974bc2cf2..62e8381b954 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/TxBody.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/TxBody.hs @@ -61,8 +61,8 @@ type ShelleyTxBodyTypes = , Maybe TxAuxDataHash ] -instance HasSimpleRep (TxBody ShelleyEra) where - type SimpleRep (TxBody ShelleyEra) = SOP '["ShelleyTxBody" ::: ShelleyTxBodyTypes] +instance HasSimpleRep (TxBody TopTx ShelleyEra) where + type SimpleRep (TxBody TopTx ShelleyEra) = SOP '["ShelleyTxBody" ::: ShelleyTxBodyTypes] toSimpleRep (ShelleyTxBody is os certs w c s up aux) = inject @"ShelleyTxBody" @'["ShelleyTxBody" ::: ShelleyTxBodyTypes] is @@ -89,7 +89,7 @@ instance HasSimpleRep (TxBody ShelleyEra) where (maybeToStrictMaybe aux) ) -instance HasSpec (TxBody ShelleyEra) +instance HasSpec (TxBody TopTx ShelleyEra) -- ======================================================= -- AllegraTxBody @@ -109,8 +109,8 @@ type AllegraTxBodyTypes = , Maybe TxAuxDataHash ] -instance HasSimpleRep (TxBody AllegraEra) where - type SimpleRep (TxBody AllegraEra) = SOP '["AllegraTxBody" ::: AllegraTxBodyTypes] +instance HasSimpleRep (TxBody TopTx AllegraEra) where + type SimpleRep (TxBody TopTx AllegraEra) = SOP '["AllegraTxBody" ::: AllegraTxBodyTypes] toSimpleRep (AllegraTxBody is os certs w c vi up aux) = inject @"AllegraTxBody" @'["AllegraTxBody" ::: AllegraTxBodyTypes] is @@ -137,7 +137,7 @@ instance HasSimpleRep (TxBody AllegraEra) where (maybeToStrictMaybe aux) ) -instance HasSpec (TxBody AllegraEra) +instance HasSpec (TxBody TopTx AllegraEra) -- ========================================================================= -- MaryTxBody @@ -158,8 +158,8 @@ type MaryTxBodyTypes = , MultiAsset ] -instance HasSimpleRep (TxBody MaryEra) where - type SimpleRep (TxBody MaryEra) = SOP '["MaryTxBody" ::: MaryTxBodyTypes] +instance HasSimpleRep (TxBody TopTx MaryEra) where + type SimpleRep (TxBody TopTx MaryEra) = SOP '["MaryTxBody" ::: MaryTxBodyTypes] toSimpleRep (MaryTxBody is os certs w c vi up aux ma) = inject @"MaryTxBody" @'["MaryTxBody" ::: MaryTxBodyTypes] is @@ -188,7 +188,7 @@ instance HasSimpleRep (TxBody MaryEra) where ma ) -instance HasSpec (TxBody MaryEra) +instance HasSpec (TxBody TopTx MaryEra) -- ================================================================================= -- AlonzoTxBody @@ -213,8 +213,8 @@ type AlonzoTxBodyTypes = , Maybe Network ] -instance HasSimpleRep (TxBody AlonzoEra) where - type SimpleRep (TxBody AlonzoEra) = SOP '["AlonzoTxBody" ::: AlonzoTxBodyTypes] +instance HasSimpleRep (TxBody TopTx AlonzoEra) where + type SimpleRep (TxBody TopTx AlonzoEra) = SOP '["AlonzoTxBody" ::: AlonzoTxBodyTypes] toSimpleRep (AlonzoTxBody inputs colinputs os certs w c vi up kh ma ihash aux nw) = inject @"AlonzoTxBody" @'["AlonzoTxBody" ::: AlonzoTxBodyTypes] inputs @@ -251,7 +251,7 @@ instance HasSimpleRep (TxBody AlonzoEra) where (maybeToStrictMaybe nw) ) -instance HasSpec (TxBody AlonzoEra) +instance HasSpec (TxBody TopTx AlonzoEra) -- ================================================================================= -- BabbageTxBody @@ -279,8 +279,8 @@ type BabbageTxBodyTypes = , Maybe Network ] -instance HasSimpleRep (TxBody BabbageEra) where - type SimpleRep (TxBody BabbageEra) = SOP '["BabbageTxBody" ::: BabbageTxBodyTypes] +instance HasSimpleRep (TxBody TopTx BabbageEra) where + type SimpleRep (TxBody TopTx BabbageEra) = SOP '["BabbageTxBody" ::: BabbageTxBodyTypes] toSimpleRep (BabbageTxBody inputs colinputs refinputs os colOut coin certs w c vi up kh ma ihash aux nw) = inject @"BabbageTxBody" @'["BabbageTxBody" ::: BabbageTxBodyTypes] inputs @@ -323,4 +323,4 @@ instance HasSimpleRep (TxBody BabbageEra) where (maybeToStrictMaybe nw) ) -instance HasSpec (TxBody BabbageEra) +instance HasSpec (TxBody TopTx BabbageEra) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Ledger.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Ledger.hs index 08dbe6319d8..c08f13912c7 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Ledger.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Ledger.hs @@ -11,5 +11,5 @@ import Test.Cardano.Ledger.Constrained.Conway.Utxo ledgerTxSpec :: UtxoExecContext ConwayEra -> - Specification (Tx ConwayEra) + Specification (Tx TopTx ConwayEra) ledgerTxSpec = utxoTxSpec diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs index e97e88982a6..a9c06d337e3 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs @@ -30,6 +30,7 @@ import Cardano.Ledger.Conway.Core ( EraTx (..), EraTxAuxData (..), EraTxWits (..), + TxLevel (..), ppMaxTxSizeL, ) import Cardano.Ledger.Conway.Governance (GovActionId) @@ -146,7 +147,7 @@ utxoStateSpec UtxoExecContext {uecUTxO} UtxoEnv {ueSlot, ueCertState} = curEpoch = runReader (epochFromSlot ueSlot) testGlobals data UtxoExecContext era = UtxoExecContext - { uecTx :: !(Tx era) + { uecTx :: !(Tx TopTx era) , uecUTxO :: !(UTxO era) , uecUtxoEnv :: !(UtxoEnv era) } @@ -163,20 +164,20 @@ instance instance ( EraTx era , ToExpr (TxOut era) - , ToExpr (TxBody era) + , ToExpr (TxBody TopTx era) , ToExpr (TxWits era) , ToExpr (TxAuxData era) , ToExpr (PParamsHKD Identity era) , EraCertState era , ToExpr (CertState era) - , ToExpr (Tx era) + , ToExpr (Tx TopTx era) ) => ToExpr (UtxoExecContext era) instance ( EraPParams era , EncCBOR (TxOut era) - , EncCBOR (Tx era) + , EncCBOR (Tx TopTx era) , EraCertState era ) => EncCBOR (UtxoExecContext era) @@ -193,9 +194,9 @@ instance CertState era ~ ConwayCertState era => Inject (UtxoExecContext era) (Co inject ctx = (uecUtxoEnv ctx) ^. utxoEnvCertStateL utxoTxSpec :: - HasSpec (Tx era) => + HasSpec (Tx TopTx era) => UtxoExecContext era -> - Specification (Tx era) + Specification (Tx TopTx era) utxoTxSpec UtxoExecContext {uecTx} = constrained $ \tx -> tx ==. lit uecTx diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index c3891532cf9..f3b2ba5f33c 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -211,7 +211,7 @@ validatingTx :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era validatingTx = mkBasicTx validatingBody & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBody @era) someKeys] @@ -225,7 +225,7 @@ validatingBody :: , AlonzoEraScript era , EraModel era ) => - TxBody era + TxBody TopTx era validatingBody = mkBasicTxBody & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 1) @@ -247,7 +247,7 @@ notValidatingTx :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era notValidatingTx = mkBasicTx notValidatingBody & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBody) someKeys] @@ -272,7 +272,7 @@ notValidatingTx = validatingTxWithWithdrawal :: forall era. (AlonzoEraTxBody era, EraModel era, AlonzoEraTxWits era) => - Tx era + Tx TopTx era validatingTxWithWithdrawal = mkBasicTx validatingBodyWithWithdrawal & witsTxL . addrTxWitsL @@ -286,7 +286,7 @@ validatingBodyWithWithdrawal :: , AlonzoEraScript era , EraModel era ) => - TxBody era + TxBody TopTx era validatingBodyWithWithdrawal = mkBasicTxBody & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 5) @@ -314,7 +314,7 @@ notValidatingTxWithWithdrawal :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era notValidatingTxWithWithdrawal = mkBasicTx notValidatingBodyWithWithdrawal & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithWithdrawal) someKeys] @@ -340,7 +340,7 @@ validatingTxWithCert :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era validatingTxWithCert = mkBasicTx validatingBodyWithCert & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBodyWithCert @era) someKeys] @@ -354,7 +354,7 @@ validatingBodyWithCert :: , AlonzoEraScript era , EraModel era ) => - TxBody era + TxBody TopTx era validatingBodyWithCert = mkBasicTxBody & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 3) @@ -379,7 +379,7 @@ notValidatingTxWithCert :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era notValidatingTxWithCert = mkBasicTx notValidatingBodyWithCert & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithCert) someKeys] @@ -405,7 +405,7 @@ validatingTxWithMint :: , EraModel era , EraPlutusTxInfo PlutusV1 era ) => - Tx era + Tx TopTx era validatingTxWithMint = mkBasicTx validatingBodyWithMint & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBodyWithMint @era) someKeys] @@ -419,7 +419,7 @@ validatingBodyWithMint :: , EraModel era , EraPlutusTxInfo PlutusV1 era ) => - TxBody era + TxBody TopTx era validatingBodyWithMint = mkBasicTxBody & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 7) @@ -452,7 +452,7 @@ notValidatingTxWithMint :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era notValidatingTxWithMint = mkBasicTx notValidatingBodyWithMint & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithMint) someKeys] @@ -475,7 +475,7 @@ notValidatingTxWithMint = poolMDHTooBigTx :: forall era. (ShelleyEraScript era, EraModel era) => - Tx era + Tx TopTx era poolMDHTooBigTx = -- Note that the UTXOW rule will no trigger the expected predicate failure, -- since it is checked in the POOL rule. BBODY will trigger it, however. @@ -588,7 +588,7 @@ coldKeys = KeyPair vk sk (sk, vk) = mkKeyPair (RawSeed 1 2 3 2 1) makeNaiveBlock :: - forall era. EraBlockBody era => [Tx era] -> Block BHeaderView era + forall era. EraBlockBody era => [Tx TopTx era] -> Block BHeaderView era makeNaiveBlock txs = Block {blockHeader = bhView, blockBody} where bhView = diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoCollectInputs.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoCollectInputs.hs index f9ebdd755f4..daff5376e09 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoCollectInputs.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoCollectInputs.hs @@ -135,7 +135,7 @@ validatingTx :: , EraModel era , EraPlutusTxInfo PlutusV1 era ) => - Tx era + Tx TopTx era validatingTx = let script = alwaysSucceeds @PlutusV1 @era 3 in mkBasicTx validatingBody @@ -173,7 +173,7 @@ collectInputs :: EpochInfo (Either Text) -> SystemStart -> PParams era -> - Tx era -> + Tx TopTx era -> UTxO era -> Either [CollectError era] [PlutusWithContext] collectInputs = collectPlutusScriptsWithContext diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs index c032cbe2904..3062acc031c 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs @@ -155,10 +155,10 @@ commonReferenceScript = type InOut era = (TxIn, TxOut era) data TestCaseData era = TestCaseData - { txBody :: TxBody era + { txBody :: TxBody TopTx era , initOutputs :: InitOutputs era , keysForAddrWits :: [KeyPairRole era] - , otherWitsFields :: Tx era -> Tx era + , otherWitsFields :: Tx TopTx era -> Tx TopTx era } data InitOutputs era = InitOutputs @@ -199,7 +199,7 @@ txFromTestCaseData :: forall era. EraTx era => TestCaseData era -> - Tx era + Tx TopTx era txFromTestCaseData testCaseData = let addrWits = @@ -222,7 +222,7 @@ testExpectSuccessValid :: , State (EraRule "UTXOW" era) ~ UTxOState era , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) , Reflect era , BabbageEraTxBody era , AlonzoEraTx era @@ -269,7 +269,7 @@ testExpectUTXOFailure :: , Environment (EraRule "UTXO" era) ~ UtxoEnv era , State (EraRule "UTXO" era) ~ UTxOState era , BaseM (EraRule "UTXO" era) ~ ShelleyBase - , Tx era ~ Signal (EraRule "UTXO" era) + , Tx TopTx era ~ Signal (EraRule "UTXO" era) , STS (EraRule "UTXO" era) , ToExpr (PredicateFailure (EraRule "UTXO" era)) , BabbageEraPParams era diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs index 0f962ce873d..fcd6e4fea01 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs @@ -106,7 +106,7 @@ data PlutusPurposeTag instance ToExpr PlutusPurposeTag class EraTest era => EraModel era where - applyTx :: Int -> SlotNo -> Model era -> Tx era -> Model era + applyTx :: Int -> SlotNo -> Model era -> Tx TopTx era -> Model era applyCert :: Model era -> TxCert era -> Model era mkRedeemersFromTags :: [((PlutusPurposeTag, Word32), (Data era, ExUnits))] -> Redeemers era @@ -130,7 +130,7 @@ class EraTest era => EraModel era where never :: Natural -> Script era - collateralReturnTxBodyT :: Lens' (TxBody era) (StrictMaybe (TxOut era)) + collateralReturnTxBodyT :: Lens' (TxBody TopTx era) (StrictMaybe (TxOut era)) validTxOut :: Map ScriptHash (Script era) -> TxOut era -> Bool @@ -282,13 +282,13 @@ testUTXOW :: , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , STS (EraRule "UTXOW" era) - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) , State (EraRule "UTXOW" era) ~ UTxOState era , ToExpr (PredicateFailure (EraRule "UTXOW" era)) ) => UTxO era -> PParams era -> - Tx era -> + Tx TopTx era -> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) -> Expectation testUTXOW utxo p tx = testUTXOWwith (genericCont (show (utxo, tx))) utxo p tx @@ -300,14 +300,14 @@ testUTXOWsubset :: , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) , STS (EraRule "UTXOW" era) , ToExpr (PredicateFailure (EraRule "UTXOW" era)) , ShelleyEraTest era ) => UTxO era -> PParams era -> - Tx era -> + Tx TopTx era -> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) -> Expectation testUTXOWsubset = testUTXOWwith subsetCont @@ -320,12 +320,12 @@ testUTXOspecialCase :: , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) , STS (EraRule "UTXOW" era) ) => UTxO era -> PParams era -> - Tx era -> + Tx TopTx era -> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) -> Expectation testUTXOspecialCase utxo pparam tx expected = @@ -345,12 +345,12 @@ testUTXOWwith :: , BaseM (EraRule "UTXOW" era) ~ ShelleyBase , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) ) => (Result era -> Result era -> Expectation) -> UTxO era -> PParams era -> - Tx era -> + Tx TopTx era -> Result era -> Expectation testUTXOWwith cont utxo pparams tx expected = @@ -364,11 +364,11 @@ runLEDGER :: , STS (EraRule "LEDGER" era) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era - , Tx era ~ Signal (EraRule "LEDGER" era) + , Tx TopTx era ~ Signal (EraRule "LEDGER" era) ) => LedgerState era -> PParams era -> - Tx era -> + Tx TopTx era -> Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era)) runLEDGER state pparams tx = let env = LedgerEnv (SlotNo 0) Nothing minBound pparams def diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ApplyTx.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ApplyTx.hs index 7834a535c04..0f305cc929e 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ApplyTx.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ApplyTx.hs @@ -61,11 +61,12 @@ import Test.Cardano.Ledger.Generic.Proof hiding (lift) import Test.Cardano.Ledger.Plutus (zeroTestingCostModels) import Test.Cardano.Ledger.Shelley.Rewards (RewardUpdateOld (deltaFOld), rsOld) -applyTxSimple :: forall era. EraModel era => Int -> Model era -> Tx era -> Model era +applyTxSimple :: forall era. EraModel era => Int -> Model era -> Tx TopTx era -> Model era applyTxSimple count model tx = applyTxBody count model $ tx ^. bodyTxL applyTxFail :: - (Reflect era, AlonzoEraTxBody era, EraModel era) => Int -> TxIx -> Model era -> Tx era -> Model era + (Reflect era, AlonzoEraTxBody era, EraModel era) => + Int -> TxIx -> Model era -> Tx TopTx era -> Model era applyTxFail count nextTxIx model tx = updateInfo info model where info = collInfo count nextTxIx model emptyCollInfo $ tx ^. bodyTxL @@ -76,7 +77,7 @@ collInfo :: TxIx -> Model era -> CollInfo era -> - TxBody era -> + TxBody TopTx era -> CollInfo era collInfo count firstTxIx model info txbody = afterColReturn @@ -129,7 +130,7 @@ epochBoundary transactionEpoch modelEpoch model = where ru = createRUpdNonPulsing' @era model -applyTxBody :: EraModel era => Int -> Model era -> TxBody era -> Model era +applyTxBody :: EraModel era => Int -> Model era -> TxBody TopTx era -> Model era applyTxBody count model txbody = Map.foldlWithKey' applyWithdrawals (foldl' applyCert model' $ txbody ^. certsTxBodyL) . unWithdrawals @@ -246,7 +247,7 @@ notValidatingTx :: , AlonzoEraTxBody era , EraModel era ) => - Tx era + Tx TopTx era notValidatingTx = let s = alwaysFails @PlutusV1 1 dat = Data (PV1.I 0) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs index 083c45d0943..8fd768209fa 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs @@ -84,7 +84,7 @@ depositsAndRefunds pp certificates accounts = List.foldl' accum (Coin 0) certifi -- | Compute the set of ScriptHashes for which there should be ScriptWitnesses. In Babbage -- Era and later, where inline Scripts are allowed, they should not appear in this set. -scriptWitsNeeded' :: Proof era -> MUtxo era -> TxBody era -> Set ScriptHash +scriptWitsNeeded' :: Proof era -> MUtxo era -> TxBody TopTx era -> Set ScriptHash scriptWitsNeeded' Conway utxo txBody = regularScripts `Set.difference` inlineScripts where theUtxo = UTxO utxo @@ -107,7 +107,7 @@ scriptWitsNeeded' Shelley utxo txBody = getScriptsHashesNeeded (getScriptsNeeded (UTxO utxo) txBody) {-# NOINLINE scriptWitsNeeded' #-} -scriptsNeeded' :: EraUTxO era => MUtxo era -> TxBody era -> Set ScriptHash +scriptsNeeded' :: EraUTxO era => MUtxo era -> TxBody TopTx era -> Set ScriptHash scriptsNeeded' utxo txBody = getScriptsHashesNeeded (getScriptsNeeded (UTxO utxo) txBody) {-# NOINLINE scriptsNeeded' #-} @@ -142,7 +142,7 @@ maxRefInputs :: Proof era -> Int maxRefInputs Babbage = 3 maxRefInputs _ = 0 -isValid' :: Proof era -> Tx era -> IsValid +isValid' :: Proof era -> Tx TopTx era -> IsValid isValid' Conway x = x ^. isValidTxL isValid' Babbage x = x ^. isValidTxL isValid' Alonzo x = x ^. isValidTxL @@ -192,10 +192,10 @@ stakeCredAddr :: Addr -> Maybe (Credential 'Staking) stakeCredAddr (Addr _ _ (StakeRefBase cred)) = Just cred stakeCredAddr _ = Nothing -getBody :: EraTx era => Proof era -> Tx era -> TxBody era +getBody :: EraTx era => Proof era -> Tx TopTx era -> TxBody TopTx era getBody _ tx = tx ^. bodyTxL -getCollateralInputs :: Proof era -> TxBody era -> Set TxIn +getCollateralInputs :: Proof era -> TxBody TopTx era -> Set TxIn getCollateralInputs Conway txBody = txBody ^. collateralInputsTxBodyL getCollateralInputs Babbage txBody = txBody ^. collateralInputsTxBodyL getCollateralInputs Alonzo txBody = txBody ^. collateralInputsTxBodyL @@ -204,7 +204,7 @@ getCollateralInputs Allegra _ = Set.empty getCollateralInputs Shelley _ = Set.empty {-# NOINLINE getCollateralInputs #-} -getCollateralOutputs :: Proof era -> TxBody era -> [TxOut era] +getCollateralOutputs :: Proof era -> TxBody TopTx era -> [TxOut era] getCollateralOutputs Conway txBody = case txBody ^. collateralReturnTxBodyL of SNothing -> [] @@ -237,7 +237,7 @@ alwaysFalse (Just l) n = alwaysFailsLang' @era l n alwaysFalse Nothing _ = fromNativeScript $ RequireAnyOf mempty {-# NOINLINE alwaysFalse #-} -certs :: (ShelleyEraTxBody era, EraTx era) => Proof era -> Tx era -> [TxCert era] +certs :: (ShelleyEraTxBody era, EraTx era) => Proof era -> Tx TopTx era -> [TxCert era] certs _ tx = Fold.toList $ tx ^. bodyTxL . certsTxBodyL -- | Create an old style RewardUpdate to be used in tests, in any Era. @@ -269,7 +269,7 @@ createRUpdNonPulsing' model = languagesUsed :: forall era. Proof era -> - Tx era -> + Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language @@ -286,7 +286,7 @@ languagesUsed proof tx utxo sNeeded = case proof of languages :: forall era. (EraUTxO era, AlonzoEraScript era) => - Tx era -> + Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs index 5f7f6892b4d..b63885760af 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs @@ -160,21 +160,21 @@ import Test.QuickCheck ( ) class (EraTest era, Reflect era, EraModel era) => EraGenericGen era where - setValidity :: ValidityInterval -> TxBody era -> TxBody era + setValidity :: ValidityInterval -> TxBody TopTx era -> TxBody TopTx era - setReferenceInputs :: Set TxIn -> TxBody era -> TxBody era + setReferenceInputs :: Set TxIn -> TxBody TopTx era -> TxBody TopTx era - setCollateralInputs :: Set TxIn -> TxBody era -> TxBody era + setCollateralInputs :: Set TxIn -> TxBody TopTx era -> TxBody TopTx era - setTotalCollateral :: StrictMaybe Coin -> TxBody era -> TxBody era + setTotalCollateral :: StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era - setCollateralReturn :: StrictMaybe (TxOut era) -> TxBody era -> TxBody era + setCollateralReturn :: StrictMaybe (TxOut era) -> TxBody TopTx era -> TxBody TopTx era addRedeemers :: Redeemers era -> TxWits era -> TxWits era - setScriptIntegrityHash :: StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era + setScriptIntegrityHash :: StrictMaybe ScriptIntegrityHash -> TxBody TopTx era -> TxBody TopTx era - setNetworkIdTxBody :: StrictMaybe Network -> TxBody era -> TxBody era + setNetworkIdTxBody :: StrictMaybe Network -> TxBody TopTx era -> TxBody TopTx era genExUnits :: Int -> GenRS era [ExUnits] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs index f5bf5b9ad98..2aca2a3ba5a 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs @@ -142,10 +142,11 @@ timeToLive :: ValidityInterval -> SlotNo timeToLive (ValidityInterval _ (SJust n)) = n timeToLive (ValidityInterval _ SNothing) = SlotNo maxBound -shelleySetValidity :: ValidityInterval -> TxBody ShelleyEra -> TxBody ShelleyEra +shelleySetValidity :: ValidityInterval -> TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra shelleySetValidity vi = ttlTxBodyL .~ timeToLive vi -allegraSetValidity :: AllegraEraTxBody era => ValidityInterval -> TxBody era -> TxBody era +allegraSetValidity :: + AllegraEraTxBody era => ValidityInterval -> TxBody TopTx era -> TxBody TopTx era allegraSetValidity vi = vldtTxBodyL .~ vi allegraValidTxOut :: EraTxOut era => Map ScriptHash (Script era) -> TxOut era -> Bool @@ -349,7 +350,7 @@ instance EraGenericGen AlonzoEra where setCollateralReturn = const id genPParams = alonzoGenPParams -shelleyApplyTx :: EraModel era => Int -> SlotNo -> Model era -> Tx era -> Model era +shelleyApplyTx :: EraModel era => Int -> SlotNo -> Model era -> Tx TopTx era -> Model era shelleyApplyTx count slot model tx = applyTxBody count epochAccurateModel $ tx ^. bodyTxL where modelEpoch = mEL model @@ -359,7 +360,7 @@ shelleyApplyTx count slot model tx = applyTxBody count epochAccurateModel $ tx ^ alonzoApplyTx :: forall era. (EraModel era, AlonzoEraTx era, Reflect era) => - Int -> SlotNo -> Model era -> Tx era -> Model era + Int -> SlotNo -> Model era -> Tx TopTx era -> Model era alonzoApplyTx count slot model tx = case tx ^. isValidTxL of IsValid True -> applyTxSimple count epochAccurateModel tx IsValid False -> applyTxFail count nextTxIx epochAccurateModel tx diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs index 8343a2e03fa..920165069d2 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs @@ -84,7 +84,7 @@ data MockChainEvent era data MockBlock era = MockBlock { mbIssuer :: !(KeyHash 'StakePool) , mbSlot :: !SlotNo - , mbTrans :: !(StrictSeq (Tx era)) + , mbTrans :: !(StrictSeq (Tx TopTx era)) } deriving (Generic) @@ -127,11 +127,11 @@ instance , Signal (EraRule "TICK" era) ~ SlotNo , Environment (EraRule "TICK" era) ~ () , Embed (EraRule "TICK" era) (MOCKCHAIN era) - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era , Embed (EraRule "LEDGERS" era) (MOCKCHAIN era) - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , State (EraRule "LEDGER" era) ~ LedgerState era , Eq (PredicateFailure (EraRule "LEDGER" era)) @@ -191,7 +191,7 @@ instance ( STS (ShelleyLEDGERS era) , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era ) => Embed (ShelleyLEDGERS era) (MOCKCHAIN era) where @@ -218,10 +218,10 @@ ppMockChainState = toExpr instance (Reflect era, ShelleyEraTest era) => ToExpr (MockChainState era) -ppMockBlock :: ToExpr (StrictSeq (Tx era)) => MockBlock era -> Expr +ppMockBlock :: ToExpr (StrictSeq (Tx TopTx era)) => MockBlock era -> Expr ppMockBlock = toExpr -instance ToExpr (StrictSeq (Tx era)) => ToExpr (MockBlock era) +instance ToExpr (StrictSeq (Tx TopTx era)) => ToExpr (MockBlock era) ppMockChainFailure :: ToExpr (MockChainFailure era) => MockChainFailure era -> Expr ppMockChainFailure = toExpr diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs index a139ed6e014..faf48bc7748 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs @@ -82,12 +82,12 @@ import Test.Control.State.Transition.Trace.Generator.QuickCheck (HasTrace (..)) -- Top level generators of TRC genTxAndUTXOState :: - ( Signal (EraRule "LEDGER" era) ~ Tx era + ( Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , State (EraRule "UTXOW" era) ~ UTxOState era - , Tx era ~ Signal (EraRule "UTXOW" era) + , Tx TopTx era ~ Signal (EraRule "UTXOW" era) , EraGenericGen era ) => GenSize -> Gen (TRC (EraRule "UTXOW" era), GenState era) @@ -97,7 +97,7 @@ genTxAndUTXOState gsize = do genTxAndLEDGERState :: forall era. - ( Signal (EraRule "LEDGER" era) ~ Tx era + ( Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , EraGenericGen era @@ -125,7 +125,7 @@ genTxAndLEDGERState sizes = do testTxValidForLEDGER :: forall era. ( Reflect era - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , State (EraRule "LEDGER" era) ~ LedgerState era , ToExpr (PredicateFailure (EraRule "LEDGER" era)) , EraTest era @@ -264,9 +264,9 @@ adaIsPreservedInEachEpoch :: , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , Signal (EraRule "NEWEPOCH" era) ~ EpochNo , Signal (EraRule "RUPD" era) ~ SlotNo - , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era) , Signal (EraRule "TICK" era) ~ SlotNo - , Signal (EraRule "LEDGER" era) ~ Tx era + , Signal (EraRule "LEDGER" era) ~ Tx TopTx era , BaseM (EraRule "NEWEPOCH" era) ~ ShelleyBase , Embed (EraRule "TICK" era) (MOCKCHAIN era) , Embed (EraRule "NEWEPOCH" era) (ShelleyTICK era) @@ -305,5 +305,5 @@ twiddleInvariantHolds name = twiddleInvariantHoldsEras :: Spec twiddleInvariantHoldsEras = describe "Twiddle invariant holds for TxBody" $ do - twiddleInvariantHolds @(TxBody AlonzoEra) "Alonzo" - twiddleInvariantHolds @(TxBody BabbageEra) "Babbage" + twiddleInvariantHolds @(TxBody TopTx AlonzoEra) "Alonzo" + twiddleInvariantHolds @(TxBody TopTx BabbageEra) "Babbage" diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs index a4f6e3cdee5..6eee9ac39be 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs @@ -104,7 +104,7 @@ import Test.Control.State.Transition.Trace.Generator.QuickCheck (HasTrace (..), genRsTxAndModel :: forall era. EraGenericGen era => - Int -> SlotNo -> GenRS era (Tx era) + Int -> SlotNo -> GenRS era (Tx TopTx era) genRsTxAndModel n slot = do (_, tx) <- genAlonzoTx slot modifyModel (\model -> applyTx n slot model tx) @@ -116,9 +116,9 @@ genRsTxSeq :: EraGenericGen era => Int -> Int -> - [(StrictSeq (Tx era), SlotNo)] -> + [(StrictSeq (Tx TopTx era), SlotNo)] -> SlotNo -> - GenRS era (Vector (StrictSeq (Tx era), SlotNo)) + GenRS era (Vector (StrictSeq (Tx TopTx era), SlotNo)) genRsTxSeq this lastN ans _slot | this >= lastN = do pure (Vector.fromList (reverse ans)) genRsTxSeq this lastN ans slot = do @@ -137,7 +137,7 @@ genTxSeq :: Int -> -- The number of Tx in the sequence GenRS era () -> -- An arbitrary 'initialization action', to run before we generate the sequence -- use (pure ()) if you don't want or need initialization - Gen (Vector (StrictSeq (Tx era), SlotNo), GenState era) + Gen (Vector (StrictSeq (Tx TopTx era), SlotNo), GenState era) genTxSeq gensize numTx initialize = do runGenRS gensize (initialize >> genRsTxSeq 0 numTx [] (SlotNo 1)) @@ -202,7 +202,7 @@ raiseMockError :: SlotNo -> EpochState era -> NonEmpty (MockChainFailure era) -> - [Tx era] -> + [Tx TopTx era] -> GenState era -> String raiseMockError slot (SlotNo next) epochstate _pdfs _txs _ = @@ -269,7 +269,7 @@ shortTxOut out = case out ^. addrTxOutL of Addr _ pay _ -> toExpr (pay, out ^. coinTxOutL) _ -> error "Bootstrap Address in shortTxOut" -smartTxBody :: EraTest era => MUtxo era -> TxBody era -> Expr +smartTxBody :: EraTest era => MUtxo era -> TxBody TopTx era -> Expr smartTxBody u txbody = toExpr (u, txbody) -- ===================================================================== @@ -284,7 +284,7 @@ instance STS (MOCKCHAIN era) -} -- ============================================================== -data Gen1 era = Gen1 (Vector (StrictSeq (Tx era), SlotNo)) (GenState era) +data Gen1 era = Gen1 (Vector (StrictSeq (Tx TopTx era), SlotNo)) (GenState era) instance ( STS (MOCKCHAIN era) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs index 4db833eb3f1..6ccbdb14814 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs @@ -814,12 +814,12 @@ minus m (Just (txin, _)) = Map.delete txin m genAlonzoTx :: forall era. EraGenericGen era => - SlotNo -> GenRS era (UTxO era, Tx era) + SlotNo -> GenRS era (UTxO era, Tx TopTx era) genAlonzoTx slot = do (utxo, tx, _fee, _old) <- genAlonzoTxAndInfo slot pure (utxo, tx) -applyIsValid :: forall era. Reflect era => IsValid -> Tx era -> Tx era +applyIsValid :: forall era. Reflect era => IsValid -> Tx TopTx era -> Tx TopTx era applyIsValid isValid = case reify @era of Shelley -> id Mary -> id @@ -835,7 +835,7 @@ genAlonzoTxAndInfo :: GenRS era ( UTxO era - , Tx era + , Tx TopTx era , UtxoEntry era -- The fee key , Maybe (UtxoEntry era) -- from oldUtxO ) diff --git a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs index 4a485f8cffd..a5a846db4f8 100644 --- a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs +++ b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs @@ -36,7 +36,7 @@ spec = do blockEraSpec :: forall era. ( EraBlockBody era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , Arbitrary (BlockBody era) ) => Spec diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs index 300243f380b..8eb58e3c713 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs @@ -155,7 +155,7 @@ instance , EraBlockBody era , KES.Signable (KES c) ~ SignableRepresentation , VRF.Signable (VRF c) ~ SignableRepresentation - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , Arbitrary (BlockBody era) ) => Arbitrary (Block (BHeader c) era) @@ -190,7 +190,7 @@ genBlock aiks = genCoherentBlock :: forall era r c. ( EraBlockBody era - , Arbitrary (Tx era) + , Arbitrary (Tx TopTx era) , KES.Signable (KES c) ~ SignableRepresentation , PraosCrypto c ) => diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs index b4ff3cb6b51..6846b40ec86 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs @@ -259,7 +259,7 @@ mkBlock :: -- | All keys in the stake pool AllIssuerKeys c r -> -- | Transactions to record - [Tx era] -> + [Tx TopTx era] -> -- | Current slot SlotNo -> -- | Block number/chain length/chain "difficulty" @@ -295,7 +295,7 @@ mkBlockFakeVRF :: -- | All keys in the stake pool AllIssuerKeys c r -> -- | Transactions to record - [Tx era] -> + [Tx TopTx era] -> -- | Current slot SlotNo -> -- | Block number\/chain length\/chain "difficulty" diff --git a/libs/ledger-state/bench/Performance.hs b/libs/ledger-state/bench/Performance.hs index 3e280cefcba..4cb2d6ab1c4 100644 --- a/libs/ledger-state/bench/Performance.hs +++ b/libs/ledger-state/bench/Performance.hs @@ -43,6 +43,7 @@ import qualified Data.Map.Strict as Map import Data.MapExtras (extractKeys, extractKeysSmallSet) import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import GHC.Stack (HasCallStack) import Lens.Micro ((&), (.~), (^.)) import System.Environment (getEnv) @@ -186,7 +187,7 @@ selectRandomMapKeys n gen m = runStateGenT_ gen $ \g -> extractKeysNaive :: Ord k => Map k a -> Set.Set k -> (Map k a, Map k a) extractKeysNaive sm s = (Map.withoutKeys sm s, Map.restrictKeys sm s) -decodeTx :: HasCallStack => ByteString -> Tx CurrentEra +decodeTx :: (HasCallStack, Typeable l) => ByteString -> Tx l CurrentEra decodeTx hex = either error id $ do bsl <- BSL16.decode hex tx <- first show $ decodeFullAnnotator (eraProtVerHigh @CurrentEra) "Tx" decCBOR bsl @@ -197,7 +198,7 @@ decodeTx hex = either error id $ do -- -- * One input with Shelley address without staking -- * One destination and change back to the address from original input. -validatedTx1 :: Validated (Tx CurrentEra) +validatedTx1 :: Validated (Tx TopTx CurrentEra) validatedTx1 = unsafeMakeValidated $ decodeTx @@ -215,7 +216,7 @@ validatedTx1 = -- -- * One input with Shelley address /with/ staking address -- * One destination and change back to the address from original input. -validatedTx2 :: Validated (Tx CurrentEra) +validatedTx2 :: Validated (Tx TopTx CurrentEra) validatedTx2 = unsafeMakeValidated $ decodeTx @@ -234,7 +235,7 @@ validatedTx2 = -- -- * One input with Shelley address /with/ staking address and some tokens -- * One destination and change back to the address from original input. -validatedTx3 :: Validated (Tx CurrentEra) +validatedTx3 :: Validated (Tx TopTx CurrentEra) validatedTx3 = unsafeMakeValidated $ decodeTx