diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 1eea7858db6..e934252caca 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.13.0.0 +* Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext` +* Add `lookupTxInfoResultImpossible` helper * Add `MemPack` instance for `Addr28Extra`, `DataHash32`, `AlonzoTxOut` and `PlutusScript AlonzoEra` * Deprecate `hashAlonzoTxAuxData` * Stop re-exporting deprecated `AuxiliaryDataHash` from `Cardano.Ledger.Alonzo.TxAuxData` 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 cd8d98822ca..ec023b71062 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs @@ -7,12 +7,16 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableSuperClasses #-} +-- Recursive definition constraints of `EraPlutusContext` and `EraPlutusTxInfo` lead to a wrongful +-- redundant constraint warning in the definition of `lookupTxInfoResult` +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Cardano.Ledger.Alonzo.Plutus.Context ( LedgerTxInfo (..), EraPlutusTxInfo (..), EraPlutusContext (..), toPlutusWithContext, + lookupTxInfoResultImpossible, -- * Language dependent translation PlutusTxInfo, @@ -45,6 +49,8 @@ import Cardano.Ledger.Plutus ( PlutusRunnable, PlutusScriptContext, PlutusWithContext (..), + SLanguage (..), + isLanguage, ) import Cardano.Ledger.UTxO (UTxO (..)) import Cardano.Slotting.EpochInfo (EpochInfo) @@ -52,8 +58,8 @@ import Cardano.Slotting.Time (SystemStart) import Control.DeepSeq (NFData) import Data.Aeson (ToJSON) import Data.Kind (Type) -import Data.Proxy (Proxy (..)) import Data.Text (Text) +import GHC.Stack import NoThunks.Class (NoThunks) import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 @@ -109,11 +115,28 @@ class where type ContextError era = (r :: Type) | r -> era + -- | This data type family is used to memoize the results of `toPlutusTxInfo`, so the outcome can + -- be shared between execution of different scripts with the same language version. + data TxInfoResult era :: Type + + -- | Construct `PlutusTxInfo` for all supported languages in this era. + mkTxInfoResult :: LedgerTxInfo era -> TxInfoResult era + + -- | `TxInfo` for the same language can be shared between executions of every script of the same + -- version in a single transaction. + -- + -- /Note/ - The `EraPlutusTxInfo` is here only to enforce this function is not called with an + -- unsupported plutus language version. + lookupTxInfoResult :: + EraPlutusTxInfo l era => + SLanguage l -> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l) + mkPlutusWithContext :: PlutusScript era -> ScriptHash -> PlutusPurpose AsIxItem era -> LedgerTxInfo era -> + TxInfoResult era -> (Data era, ExUnits) -> CostModel -> Either (ContextError era) PlutusWithContext @@ -125,16 +148,17 @@ toPlutusWithContext :: ScriptHash -> PlutusPurpose AsIxItem era -> LedgerTxInfo era -> + TxInfoResult era -> (Data era, ExUnits) -> CostModel -> Either (ContextError era) PlutusWithContext -toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits) costModel = do - let proxy = Proxy @l +toPlutusWithContext script scriptHash plutusPurpose lti txInfoResult (redeemerData, exUnits) costModel = do + let slang = isLanguage @l maybeSpendingDatum = getSpendingDatum (ltiUTxO lti) (ltiTx lti) (hoistPlutusPurpose toAsItem plutusPurpose) - txInfo <- toPlutusTxInfo proxy lti + txInfo <- lookupTxInfoResult slang txInfoResult plutusArgs <- - toPlutusArgs proxy (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData + toPlutusArgs slang (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData pure $ PlutusWithContext { pwcProtocolVersion = pvMajor (ltiProtVer lti) @@ -145,6 +169,13 @@ toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits) , pwcCostModel = costModel } +-- | Helper function to use when implementing `lookupTxInfoResult` for plutus languages that are not +-- supported by the era. +lookupTxInfoResultImpossible :: + (HasCallStack, EraPlutusTxInfo l era) => SLanguage l -> Either (ContextError era) (PlutusTxInfo l) +lookupTxInfoResultImpossible slang = + error $ "Impossible: Attempt to lookup TxInfoResult for an unsupported language: " <> show slang + -- ============================================= -- Type families that specify Plutus types that are different from one version to another 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 dc136426263..69233bf3f46 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs @@ -169,6 +169,7 @@ collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo = , ltiUTxO = utxo , ltiTx = tx } + txInfoResult = mkTxInfoResult ledgerTxInfo ScriptsProvided scriptsProvided = getScriptsProvided utxo tx AlonzoScriptsNeeded scriptsNeeded = getScriptsNeeded utxo (tx ^. bodyTxL) @@ -189,6 +190,7 @@ collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo = plutusScriptHash plutusPurpose ledgerTxInfo + txInfoResult (redeemerData, exUnits) costModel @@ -366,6 +368,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC , ltiUTxO = utxo , ltiTx = tx } + txInfoResult = mkTxInfoResult ledgerTxInfo maxBudget = pp ^. ppMaxTxExUnitsL txBody = tx ^. bodyTxL wits = tx ^. witsTxL @@ -400,6 +403,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC plutusScriptHash plutusPurpose ledgerTxInfo + txInfoResult (redeemerData, maxBudget) costModel case evaluatePlutusWithContext P.Verbose pwc of 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 7028ab24c57..5bde31f9580 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs @@ -69,7 +69,12 @@ import Cardano.Ledger.Mary.Value ( PolicyID (..), ) import Cardano.Ledger.Plutus.Data (Data, getPlutusData) -import Cardano.Ledger.Plutus.Language (Language (..), LegacyPlutusArgs (..), PlutusArgs (..)) +import Cardano.Ledger.Plutus.Language ( + Language (..), + LegacyPlutusArgs (..), + PlutusArgs (..), + SLanguage (..), + ) import Cardano.Ledger.Plutus.TxInfo import Cardano.Ledger.PoolParams (PoolParams (..)) import Cardano.Ledger.Rules.ValidationMode (Inject (..)) @@ -157,6 +162,13 @@ toLegacyPlutusArgs proxy pv mkScriptContext scriptPurpose maybeSpendingData rede instance EraPlutusContext AlonzoEra where type ContextError AlonzoEra = AlonzoContextError AlonzoEra + newtype TxInfoResult AlonzoEra + = AlonzoTxInfoResult (Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1)) + + mkTxInfoResult = AlonzoTxInfoResult . toPlutusTxInfo SPlutusV1 + + lookupTxInfoResult SPlutusV1 (AlonzoTxInfoResult tirPlutusV1) = tirPlutusV1 + lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang mkPlutusWithContext (AlonzoPlutusV1 p) = toPlutusWithContext (Left p) diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs index 2899e5a5e1c..df88c8ab11d 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs @@ -32,6 +32,8 @@ import Cardano.Ledger.Alonzo.Plutus.Context ( EraPlutusTxInfo (..), LedgerTxInfo (..), PlutusScriptPurpose, + PlutusTxInfo, + lookupTxInfoResultImpossible, toPlutusWithContext, ) import Cardano.Ledger.Alonzo.Plutus.TxInfo ( @@ -65,7 +67,7 @@ import Cardano.Ledger.Binary.Coders ( import Cardano.Ledger.Mary.Value (MaryValue) import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, getPlutusData) import Cardano.Ledger.Plutus.ExUnits (ExUnits (..)) -import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..)) +import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..)) import Cardano.Ledger.Plutus.TxInfo ( TxOutSource (..), transAddr, @@ -221,6 +223,16 @@ transTxRedeemers proxy pv tx = instance EraPlutusContext BabbageEra where type ContextError BabbageEra = BabbageContextError BabbageEra + data TxInfoResult BabbageEra + = BabbageTxInfoResult -- Fields must be kept lazy + (Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV1)) + (Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV2)) + + mkTxInfoResult lti = BabbageTxInfoResult (toPlutusTxInfo SPlutusV1 lti) (toPlutusTxInfo SPlutusV2 lti) + + lookupTxInfoResult SPlutusV1 (BabbageTxInfoResult tirPlutusV1 _) = tirPlutusV1 + lookupTxInfoResult SPlutusV2 (BabbageTxInfoResult _ tirPlutusV2) = tirPlutusV2 + lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang mkPlutusWithContext = \case BabbagePlutusV1 p -> toPlutusWithContext $ Left p diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs index a9287e3a4d6..e7f25ff3c71 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs @@ -36,6 +36,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context ( EraPlutusTxInfo (..), LedgerTxInfo (..), PlutusTxCert, + PlutusTxInfo, toPlutusWithContext, ) import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..)) @@ -92,7 +93,7 @@ import Cardano.Ledger.DRep (DRep (..)) import Cardano.Ledger.Mary (MaryValue) import Cardano.Ledger.Mary.Value (MultiAsset) import Cardano.Ledger.Plutus.Data (Data) -import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..)) +import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..)) import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..)) import Cardano.Ledger.Plutus.TxInfo ( transBoundedRational, @@ -130,6 +131,22 @@ import qualified PlutusLedgerApi.V3.MintValue as PV3 instance EraPlutusContext ConwayEra where type ContextError ConwayEra = ConwayContextError ConwayEra + data TxInfoResult ConwayEra + = ConwayTxInfoResult -- Fields must be kept lazy + (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV1)) + (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV2)) + (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV3)) + + mkTxInfoResult lti = + ConwayTxInfoResult + (toPlutusTxInfo SPlutusV1 lti) + (toPlutusTxInfo SPlutusV2 lti) + (toPlutusTxInfo SPlutusV3 lti) + + lookupTxInfoResult SPlutusV1 (ConwayTxInfoResult tirPlutusV1 _ _) = tirPlutusV1 + lookupTxInfoResult SPlutusV2 (ConwayTxInfoResult _ tirPlutusV2 _) = tirPlutusV2 + lookupTxInfoResult SPlutusV3 (ConwayTxInfoResult _ _ tirPlutusV3) = tirPlutusV3 + mkPlutusWithContext = \case ConwayPlutusV1 p -> toPlutusWithContext $ Left p ConwayPlutusV2 p -> toPlutusWithContext $ Left p