{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Alonzo.ImpTest (
  module Test.Cardano.Ledger.Mary.ImpTest,
  AlonzoEraImp (..),
  impLookupPlutusScript,
  malformedPlutus,
  addCollateralInput,
  impGetPlutusContexts,
  alonzoFixupTx,
  plutusTestScripts,
  impGetScriptContext,
  impLookupScriptContext,
  impPlutusWithContexts,
  impScriptPredicateFailure,
  submitPhase2Invalid_,
  submitPhase2Invalid,
  impAlonzoExpectTxSuccess,
  impComputeScriptIntegrity,
  computeScriptIntegrityHash,
  computeScriptIntegrity,
  -- Fixup
  fixupDatums,
  fixupOutputDatums,
  fixupPPHash,
  fixupRedeemers,
  fixupRedeemerIndices,
  fixupScriptWits,
  alonzoFixupFees,
) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  collectPlutusScriptsWithContext,
  evalPlutusScriptsWithLogs,
  evalTxExUnits,
 )
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxoPredFailure,
  AlonzoUtxosPredFailure (..),
  AlonzoUtxowPredFailure,
  TagMismatchDescription (..),
  scriptFailureToFailureDescription,
 )
import Cardano.Ledger.Alonzo.Scripts (toAsItem, toAsIx)
import Cardano.Ledger.Alonzo.Tx (ScriptIntegrity, hashScriptIntegrity, mkScriptIntegrity)
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL, unTxDatsL)
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
import Cardano.Ledger.BaseTypes (Globals (..), StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Plutus (
  Data (..),
  Datum (..),
  ExUnits (..),
  Language (..),
  Plutus (..),
  PlutusBinary (..),
  PlutusLanguage,
  PlutusWithContext (..),
  Prices (..),
  SLanguage (..),
  ScriptResult (..),
  hashData,
  hashPlutusScript,
  plutusLanguage,
 )
import Cardano.Ledger.Shelley.LedgerState (
  curPParamsEpochStateL,
  nesEsL,
  utxoL,
 )
import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..), txouts)
import Cardano.Ledger.TxIn (TxIn)
import Control.Monad (forM)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.MapExtras (fromElems)
import Data.Maybe (catMaybes, isJust, isNothing)
import Data.Set ((\\))
import qualified Data.Set as Set
import qualified Data.Text as T
import Lens.Micro
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.Era
import Test.Cardano.Ledger.Alonzo.TreeDiff ()
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Mary.ImpTest
import Test.Cardano.Ledger.Plutus (
  PlutusArgs (..),
  ScriptTestContext (..),
  testingCostModels,
 )
import Test.Cardano.Ledger.Plutus.Examples
import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript)

class
  ( MaryEraImp era
  , AlonzoEraTest era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , TxAuxData era ~ AlonzoTxAuxData era
  , ToExpr (ContextError era)
  , ToExpr (PlutusPurpose AsItem era)
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
  ) =>
  AlonzoEraImp era
  where
  scriptTestContexts :: Map ScriptHash ScriptTestContext

makeCollateralInput :: ShelleyEraImp era => ImpTestM era TxIn
makeCollateralInput :: forall era. ShelleyEraImp era => ImpTestM era TxIn
makeCollateralInput = do
  -- TODO: make more accurate
  let collateral :: Coin
collateral = Integer -> Coin
Coin Integer
30_000_000
  addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  withFixup fixupTx $ sendCoinTo addr collateral

addCollateralInput ::
  AlonzoEraImp era =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
addCollateralInput :: forall era.
AlonzoEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInput Tx TopTx era
tx
  | Bool -> Bool
not (Set TxIn -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Tx TopTx era
tx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL)) = Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx TopTx era
tx
  | Bool
otherwise = do
      ctx <- Tx TopTx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx TopTx era
tx
      if null ctx
        then pure tx
        else do
          impAnn "addCollateralInput" $ do
            collateralInput <- makeCollateralInput
            pure $ tx & bodyTxL . collateralInputsTxBodyL <>~ Set.singleton collateralInput

impLookupPlutusScript ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  Maybe (PlutusScript era)
impLookupPlutusScript :: forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
sh = do
  ScriptTestContext plutus _ <- forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext @era ScriptHash
sh
  mkPlutusScript plutus

impGetPlutusContexts ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx l era
tx = do
  let txBody :: TxBody l era
txBody = Tx l era
tx Tx l era
-> Getting (TxBody l era) (Tx l era) (TxBody l era) -> TxBody l era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody l era) (Tx l era) (TxBody l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
  utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  let AlonzoScriptsNeeded asn = getScriptsNeeded utxo txBody
  mbyContexts <- forM asn $ \(PlutusPurpose AsIxItem era
prp, ScriptHash
sh) -> do
    Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
 -> ImpM
      (LedgerSpec era)
      (Maybe
         (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)))
-> Maybe
     (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext))
forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIxItem era
prp,ScriptHash
sh,) (ScriptTestContext
 -> (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext))
-> Maybe ScriptTestContext
-> Maybe
     (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext @era ScriptHash
sh
  pure $ catMaybes mbyContexts

fixupRedeemerIndices ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
fixupRedeemerIndices :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupRedeemerIndices Tx l era
tx = String
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemerIndices" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  (rootTxIn, _) <- ImpTestM era (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
  let
    txInputs = Tx l era
tx Tx l era -> Getting (Set TxIn) (Tx l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody l era -> Const (Set TxIn) (TxBody l era))
-> Tx l era -> Const (Set TxIn) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Const (Set TxIn) (TxBody l era))
 -> Tx l era -> Const (Set TxIn) (Tx l era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody l era -> Const (Set TxIn) (TxBody l era))
-> Getting (Set TxIn) (Tx l era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody l era -> Const (Set TxIn) (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL
    rootTxIndex = Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ TxIn -> Set TxIn -> Int
forall a. Ord a => a -> Set a -> Int
Set.findIndex TxIn
rootTxIn Set TxIn
txInputs
    updateIndex (SpendingPurpose (AsIx Word32
i))
      | Word32
i Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
rootTxIndex = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (AsIx Word32 TxIn -> PlutusPurpose AsIx era)
-> (Word32 -> AsIx Word32 TxIn) -> Word32 -> PlutusPurpose AsIx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx (Word32 -> PlutusPurpose AsIx era)
-> Word32 -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
i
    updateIndex PlutusPurpose AsIx era
x = PlutusPurpose AsIx era
x
  pure $ tx & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.mapKeys updateIndex

fixupRedeemers ::
  forall era.
  (AlonzoEraImp era, HasCallStack) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
fixupRedeemers :: forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers Tx TopTx era
tx = String
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemers" (ImpM (LedgerSpec era) (Tx TopTx era)
 -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ do
  contexts <- Tx TopTx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx TopTx era
tx
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  let oldRedeemers = Tx TopTx era
tx Tx TopTx era
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx TopTx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall s a. s -> Getting a s a -> a
^. (TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Tx TopTx era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
 -> Tx TopTx era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx TopTx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx TopTx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
 -> TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
  txWithMaxExUnits <- txWithMaxRedeemers tx
  let newMaxRedeemers = Tx TopTx era
txWithMaxExUnits Tx TopTx era
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx TopTx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall s a. s -> Getting a s a -> a
^. (TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Tx TopTx era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
 -> Tx TopTx era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx TopTx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx TopTx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
 -> TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
  utxo <- getUTxO
  Globals {systemStart, epochInfo} <- use impGlobalsL
  let reports = PParams era
-> Tx TopTx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx TopTx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits PParams era
pp Tx TopTx era
txWithMaxExUnits UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
  exUnitsPerPurpose <-
    fmap (Map.mapMaybe id) $ forM reports $ \case
      Left TransactionScriptFailure era
err -> do
        String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Execution Units estimation error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TransactionScriptFailure era -> String
forall a. Show a => a -> String
show TransactionScriptFailure era
err
        Maybe ExUnits -> ImpM (LedgerSpec era) (Maybe ExUnits)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ExUnits
forall a. Maybe a
Nothing
      Right ExUnits
exUnits ->
        Maybe ExUnits -> ImpM (LedgerSpec era) (Maybe ExUnits)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ExUnits -> ImpM (LedgerSpec era) (Maybe ExUnits))
-> Maybe ExUnits -> ImpM (LedgerSpec era) (Maybe ExUnits)
forall a b. (a -> b) -> a -> b
$ ExUnits -> Maybe ExUnits
forall a. a -> Maybe a
Just ExUnits
exUnits
  let
    mkNewRedeemers (PlutusPurpose AsIxItem era
prpIdx, ScriptHash
_, ScriptTestContext Plutus l
_ (PlutusArgs Data
dat Maybe Data
_)) =
      let ptr :: PlutusPurpose AsIx era
ptr = forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose @era AsIxItem ix it -> AsIx ix it
forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx
       in case PlutusPurpose AsIx era
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Maybe (Data era, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
ptr Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers of
            Just (Data era, ExUnits)
redeemer -> Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
 -> ImpM
      (LedgerSpec era)
      (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))))
-> Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIx era, (Data era, ExUnits))
-> Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (Data era, ExUnits)
redeemer)
            Maybe (Data era, ExUnits)
Nothing ->
              case PlutusPurpose AsIx era
-> Map (PlutusPurpose AsIx era) ExUnits -> Maybe ExUnits
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
ptr Map (PlutusPurpose AsIx era) ExUnits
exUnitsPerPurpose of
                Maybe ExUnits
Nothing -> do
                  String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Missing Redeemer Ptr from execution estimation: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PlutusPurpose AsIx era -> String
forall a. Show a => a -> String
show PlutusPurpose AsIx era
ptr
                  Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
forall a. Maybe a
Nothing
                Just ExUnits
exUnits ->
                  Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
 -> ImpM
      (LedgerSpec era)
      (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))))
-> Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIx era, (Data era, ExUnits))
-> Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))
forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (Data -> Data era
forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
exUnits))
  newRedeemers <- Map.fromList . catMaybes <$> mapM mkNewRedeemers contexts
  pure $
    tx
      & witsTxL . rdmrsTxWitsL . unRedeemersL .~ Map.unions [oldRedeemers, newRedeemers, newMaxRedeemers]

txWithMaxRedeemers ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
txWithMaxRedeemers :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
txWithMaxRedeemers Tx l era
tx = do
  contexts <- Tx l era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx l era
tx
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  let
    maxExUnit = PParams era
pp PParams era -> Getting ExUnits (PParams era) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams era) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
    mkNewMaxRedeemers (PlutusPurpose AsIxItem era
prpIdx, ScriptHash
_, ScriptTestContext Plutus l
_ (PlutusArgs Data
dat Maybe Data
_)) =
      (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose @era AsIxItem ix it -> AsIx ix it
forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx, (Data -> Data era
forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
maxExUnit))
    newMaxRedeemers = [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
mkNewMaxRedeemers ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
 -> (PlutusPurpose AsIx era, (Data era, ExUnits)))
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts)
  pure $ tx & witsTxL . rdmrsTxWitsL . unRedeemersL .~ newMaxRedeemers

fixupScriptWits ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
fixupScriptWits :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits Tx l era
tx = String
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupScriptWits" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  contexts <- Tx l era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx l era
tx
  utxo <- getUTxO
  let ScriptsProvided provided = getScriptsProvided utxo tx
  let contextsToAdd = ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
 -> Bool)
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PlutusPurpose AsIxItem era
_, ScriptHash
sh, ScriptTestContext
_) -> Bool -> Bool
not (ScriptHash -> Map ScriptHash (AlonzoScript era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member ScriptHash
sh Map ScriptHash (Script era)
Map ScriptHash (AlonzoScript era)
provided)) [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts
  scriptWits <- forM contextsToAdd $ \(PlutusPurpose AsIxItem era
_, ScriptHash
sh, ScriptTestContext Plutus l
plutus PlutusArgs
_) ->
    (ScriptHash
sh,) (AlonzoScript era -> (ScriptHash, Script era))
-> (PlutusScript era -> AlonzoScript era)
-> PlutusScript era
-> (ScriptHash, Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusScript era -> Script era
PlutusScript era -> AlonzoScript era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> (ScriptHash, Script era))
-> ImpM (LedgerSpec era) (PlutusScript era)
-> ImpM (LedgerSpec era) (ScriptHash, Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plutus l -> ImpM (LedgerSpec era) (PlutusScript era)
forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
forall (l :: Language) (m :: * -> *).
(PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript Plutus l
plutus
  pure $
    tx
      & witsTxL . scriptTxWitsL <>~ Map.fromList scriptWits

fixupDatums ::
  forall era l.
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx l era ->
  ImpTestM era (Tx l era)
fixupDatums :: forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums Tx l era
tx = String
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupDatums" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  contexts <- Tx l era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx l era
tx
  let purposes = ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> Getting
     (PlutusPurpose AsIxItem era)
     (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
     (PlutusPurpose AsIxItem era)
-> PlutusPurpose AsIxItem era
forall s a. s -> Getting a s a -> a
^. Getting
  (PlutusPurpose AsIxItem era)
  (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
  (PlutusPurpose AsIxItem era)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
  (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
  (PlutusPurpose AsIxItem era)
  (PlutusPurpose AsIxItem era)
_1) ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
 -> PlutusPurpose AsIxItem era)
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> [PlutusPurpose AsIxItem era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts
  datums <- traverse collectDatums purposes
  pure $
    tx
      & witsTxL . datsTxWitsL . unTxDatsL
        <>~ fromElems hashData (catMaybes datums)
  where
    collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
    collectDatums :: PlutusPurpose AsIxItem era
-> ImpM (LedgerSpec era) (Maybe (Data era))
collectDatums PlutusPurpose AsIxItem era
purpose = do
      let txIn :: Maybe TxIn
txIn = AsItem Word32 TxIn -> TxIn
forall ix it. AsItem ix it -> it
unAsItem (AsItem Word32 TxIn -> TxIn)
-> Maybe (AsItem Word32 TxIn) -> Maybe TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlutusPurpose AsItem era -> Maybe (AsItem Word32 TxIn)
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
forall (f :: * -> * -> *).
PlutusPurpose f era -> Maybe (f Word32 TxIn)
toSpendingPurpose ((forall ix it. AsIxItem ix it -> AsItem ix it)
-> PlutusPurpose AsIxItem era -> PlutusPurpose AsItem era
forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose AsIxItem ix it -> AsItem ix it
forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
purpose)
      mbyTxOut <- (TxIn -> ImpM (LedgerSpec era) (TxOut era))
-> Maybe TxIn -> ImpM (LedgerSpec era) (Maybe (TxOut era))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (forall era. ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impGetUTxO @era) Maybe TxIn
txIn
      case mbyTxOut of
        Just TxOut era
txOut -> TxOut era -> ImpM (LedgerSpec era) (Maybe (Data era))
getData TxOut era
txOut
        Maybe (TxOut era)
Nothing -> Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Data era)
forall a. Maybe a
Nothing

    getData :: TxOut era -> ImpTestM era (Maybe (Data era))
    getData :: TxOut era -> ImpM (LedgerSpec era) (Maybe (Data era))
getData TxOut era
txOut =
      let sh :: ScriptHash
sh = TxOut era -> ScriptHash
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> ScriptHash
txOutScriptHash TxOut era
txOut
       in case TxOut era
txOut TxOut era
-> Getting (Datum era) (TxOut era) (Datum era) -> Datum era
forall s a. s -> Getting a s a -> a
^. Getting (Datum era) (TxOut era) (Datum era)
forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
SimpleGetter (TxOut era) (Datum era)
datumTxOutF of
            DatumHash DataHash
dh -> case ScriptHash
-> Map ScriptHash ScriptTestContext -> Maybe ScriptTestContext
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
sh (forall era. AlonzoEraImp era => Map ScriptHash ScriptTestContext
scriptTestContexts @era) of
              Just ScriptTestContext
x | forall era. Data era -> DataHash
hashData @era (ScriptTestContext -> Data era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era) =>
ScriptTestContext -> Data era
spendDatum ScriptTestContext
x) DataHash -> DataHash -> Bool
forall a. Eq a => a -> a -> Bool
== DataHash
dh -> Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era)))
-> (Data era -> Maybe (Data era))
-> Data era
-> ImpM (LedgerSpec era) (Maybe (Data era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data era -> Maybe (Data era)
forall a. a -> Maybe a
Just (Data era -> ImpM (LedgerSpec era) (Maybe (Data era)))
-> Data era -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a b. (a -> b) -> a -> b
$ ScriptTestContext -> Data era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era) =>
ScriptTestContext -> Data era
spendDatum ScriptTestContext
x
              Maybe ScriptTestContext
_ -> do
                Text -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => Text -> ImpM t ()
logText (Text -> ImpM (LedgerSpec era) ())
-> Text -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                  Text
"Script not found in `scriptTestContexts`:\n"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
sh)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nThe transaction will likely fail. To fix this, add the script to `scriptTestContexts`."
                Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Data era)
forall a. Maybe a
Nothing
            Datum era
_ -> Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Data era)
forall a. Maybe a
Nothing

    txOutScriptHash :: TxOut era -> ScriptHash
txOutScriptHash TxOut era
txOut
      | Addr Network
_ (ScriptHashObj ScriptHash
sh) StakeReference
_ <- TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL = ScriptHash
sh
      | Bool
otherwise = String -> ScriptHash
forall a. HasCallStack => String -> a
error String
"TxOut does not have a payment script"

    spendDatum :: ScriptTestContext -> Data era
spendDatum (ScriptTestContext Plutus l
_ (PlutusArgs Data
_ (Just Data
d))) = Data -> Data era
forall era. Era era => Data -> Data era
Data Data
d
    spendDatum ScriptTestContext
_ = String -> Data era
forall a. HasCallStack => String -> a
error String
"Context does not have a spending datum"

fixupPPHash ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
fixupPPHash :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash Tx l era
tx = String
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupPPHash" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  integrityHash <- Tx l era -> ImpTestM era (StrictMaybe ScriptIntegrityHash)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (StrictMaybe ScriptIntegrityHash)
computeScriptIntegrityHash Tx l era
tx
  pure $
    tx
      & bodyTxL . scriptIntegrityHashTxBodyL .~ integrityHash

fixupOutputDatums ::
  forall era l.
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
fixupOutputDatums :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums Tx l era
tx = String
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupOutputDatums" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  let
    addDatum :: TxOut era -> TxOut era
addDatum TxOut era
txOut =
      case TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
        Addr Network
_ (ScriptHashObj ScriptHash
sh) StakeReference
_
          | Just (ScriptTestContext Plutus l
_ (PlutusArgs Data
_ (Just Data
spendDatum))) <- forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext @era ScriptHash
sh
          , Datum era
NoDatum <- TxOut era
txOut TxOut era
-> Getting (Datum era) (TxOut era) (Datum era) -> Datum era
forall s a. s -> Getting a s a -> a
^. Getting (Datum era) (TxOut era) (Datum era)
forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
SimpleGetter (TxOut era) (Datum era)
datumTxOutF ->
              TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (forall era. Data era -> DataHash
hashData @era (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ Data -> Data era
forall era. Era era => Data -> Data era
Data Data
spendDatum)
        Addr
_ -> TxOut era
txOut
  Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ Tx l era
tx Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx l era -> Identity (Tx l era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TxOut era -> TxOut era)
-> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a b. (a -> b) -> StrictSeq a -> StrictSeq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut era -> TxOut era
addDatum

alonzoFixupTx ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
alonzoFixupTx :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupTx =
  Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (m :: * -> *) (l :: TxLevel).
(EraTx era, Applicative m) =>
Tx l era -> m (Tx l era)
fixupAuxDataHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
AlonzoEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInput
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addRootTxIn
    -- We need to update the indices after adding the rootTxIn because the
    -- indices of inputs might get bumped if the rootTxIn appears before them
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupRedeemerIndices
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTxOuts
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupFees
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits

alonzoFixupFees ::
  forall era. (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupFees :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupFees Tx TopTx era
tx = do
  let originalRedeemers :: Redeemers era
originalRedeemers = Tx TopTx era
tx Tx TopTx era
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
  txWithMax <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
txWithMaxRedeemers Tx TopTx era
tx
  -- we are maximizing the fees relative to the the redeemers, in order to break the circular dependency
  -- of the fee being impacted by the redeemers and viceversa
  txWithFees <- fixupFees txWithMax
  pure $ txWithFees & witsTxL . rdmrsTxWitsL .~ originalRedeemers

mkScriptTestEntry ::
  PlutusLanguage l =>
  Plutus l ->
  PlutusArgs ->
  (ScriptHash, ScriptTestContext)
mkScriptTestEntry :: forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry Plutus l
script PlutusArgs
args =
  ( Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus l
script
  , ScriptTestContext
      { stcScript :: Plutus l
stcScript = Plutus l
script
      , stcArgs :: PlutusArgs
stcArgs = PlutusArgs
args
      }
  )

plutusTestScripts ::
  forall l.
  PlutusLanguage l =>
  SLanguage l ->
  Map.Map ScriptHash ScriptTestContext
plutusTestScripts :: forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage l
lang =
  [(ScriptHash, ScriptTestContext)]
-> Map ScriptHash ScriptTestContext
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, ScriptTestContext)]
 -> Map ScriptHash ScriptTestContext)
-> [(ScriptHash, ScriptTestContext)]
-> Map ScriptHash ScriptTestContext
forall a b. (a -> b) -> a -> b
$
    [ Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). Plutus l
malformedPlutus @l) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
7)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) Maybe Data
forall a. Maybe a
Nothing
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) Maybe Data
forall a. Maybe a
Nothing
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
3)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
26)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) Maybe Data
forall a. Maybe a
Nothing
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerWithDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) Maybe Data
forall a. Maybe a
Nothing
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
221) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyNoDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
122) Maybe Data
forall a. Maybe a
Nothing
    , Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
222) (Data -> Maybe Data
forall a. a -> Maybe a
Just (Data -> Maybe Data) -> Data -> Maybe Data
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , Plutus 'PlutusV3 -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry Plutus 'PlutusV3
guardrailScript (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) Maybe Data
forall a. Maybe a
Nothing
    ]
      [(ScriptHash, ScriptTestContext)]
-> [(ScriptHash, ScriptTestContext)]
-> [(ScriptHash, ScriptTestContext)]
forall a. [a] -> [a] -> [a]
++ [ Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOverlapsWithRefInputs SLanguage l
lang) (PlutusArgs -> (ScriptHash, ScriptTestContext))
-> PlutusArgs -> (ScriptHash, ScriptTestContext)
forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) Maybe Data
forall a. Maybe a
Nothing
         | SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
lang Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV2
         ]

malformedPlutus :: Plutus l
malformedPlutus :: forall (l :: Language). Plutus l
malformedPlutus = PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus (ShortByteString -> PlutusBinary
PlutusBinary ShortByteString
"invalid")

instance ShelleyEraImp AlonzoEra where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (Genesis AlonzoEra)
initGenesis =
    AlonzoGenesis -> m AlonzoGenesis
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      AlonzoGenesis
        { agCoinsPerUTxOWord :: CoinPerWord
agCoinsPerUTxOWord = Coin -> CoinPerWord
CoinPerWord (Integer -> Coin
Coin Integer
34_482)
        , agCostModels :: CostModels
agCostModels = HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Language
PlutusV1]
        , agPrices :: Prices
agPrices =
            Prices
              { prMem :: NonNegativeInterval
prMem = Integer
577 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000
              , prSteps :: NonNegativeInterval
prSteps = Integer
721 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000_000
              }
        , agMaxTxExUnits :: ExUnits
agMaxTxExUnits =
            ExUnits
              { exUnitsMem :: Nat
exUnitsMem = Nat
10_000_000
              , exUnitsSteps :: Nat
exUnitsSteps = Nat
10_000_000_000
              }
        , agMaxBlockExUnits :: ExUnits
agMaxBlockExUnits =
            ExUnits
              { exUnitsMem :: Nat
exUnitsMem = Nat
50_000_000
              , exUnitsSteps :: Nat
exUnitsSteps = Nat
40_000_000_000
              }
        , agMaxValSize :: Nat
agMaxValSize = Nat
5000
        , agCollateralPercentage :: Nat
agCollateralPercentage = Nat
150
        , agMaxCollateralInputs :: Nat
agMaxCollateralInputs = Nat
3
        }

  impSatisfyNativeScript :: forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l AlonzoEra
-> NativeScript AlonzoEra
-> ImpTestM
     AlonzoEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript = Set (KeyHash Witness)
-> TxBody l AlonzoEra
-> NativeScript AlonzoEra
-> ImpTestM
     AlonzoEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
(ShelleyEraImp era, AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack =>
Tx TopTx AlonzoEra -> ImpTestM AlonzoEra (Tx TopTx AlonzoEra)
fixupTx = Tx TopTx AlonzoEra -> ImpTestM AlonzoEra (Tx TopTx AlonzoEra)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx AlonzoEra -> ImpTestM AlonzoEra ()
expectTxSuccess = Tx TopTx AlonzoEra -> ImpTestM AlonzoEra ()
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era ()
impAlonzoExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp AlonzoEra =>
Version
-> SpecWith (ImpInit (LedgerSpec AlonzoEra))
-> SpecWith (ImpInit (LedgerSpec AlonzoEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec AlonzoEra))
-> SpecWith (ImpInit (LedgerSpec AlonzoEra))
forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM AlonzoEra (TxCert AlonzoEra)
genRegTxCert = Credential Staking -> ImpTestM AlonzoEra (TxCert AlonzoEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM AlonzoEra (TxCert AlonzoEra)
genUnRegTxCert = Credential Staking -> ImpTestM AlonzoEra (TxCert AlonzoEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert AlonzoEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert AlonzoEra
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
shelleyDelegStakeTxCert

instance MaryEraImp AlonzoEra

instance AlonzoEraImp AlonzoEra where
  scriptTestContexts :: Map ScriptHash ScriptTestContext
scriptTestContexts = SLanguage 'PlutusV1 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1

impLookupScriptContext ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  Maybe ScriptTestContext
impLookupScriptContext :: forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext ScriptHash
sh = ScriptHash
-> Map ScriptHash ScriptTestContext -> Maybe ScriptTestContext
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
sh (Map ScriptHash ScriptTestContext -> Maybe ScriptTestContext)
-> Map ScriptHash ScriptTestContext -> Maybe ScriptTestContext
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraImp era => Map ScriptHash ScriptTestContext
scriptTestContexts @era

impGetScriptContext ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  ImpTestM era ScriptTestContext
impGetScriptContext :: forall era.
AlonzoEraImp era =>
ScriptHash -> ImpTestM era ScriptTestContext
impGetScriptContext ScriptHash
sh =
  String
-> ImpM (LedgerSpec era) ScriptTestContext
-> ImpM (LedgerSpec era) ScriptTestContext
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (String
"Getting script context for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
sh)
    (ImpM (LedgerSpec era) ScriptTestContext
 -> ImpM (LedgerSpec era) ScriptTestContext)
-> (Maybe ScriptTestContext
    -> ImpM (LedgerSpec era) ScriptTestContext)
-> Maybe ScriptTestContext
-> ImpM (LedgerSpec era) ScriptTestContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ScriptTestContext -> ImpM (LedgerSpec era) ScriptTestContext
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust
    (Maybe ScriptTestContext
 -> ImpM (LedgerSpec era) ScriptTestContext)
-> Maybe ScriptTestContext
-> ImpM (LedgerSpec era) ScriptTestContext
forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext @era ScriptHash
sh

impPlutusWithContexts ::
  (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts Tx TopTx era
tx = do
  globals <- Getting Globals (ImpTestState era) Globals
-> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  utxo <- getUTxO
  case collectPlutusScriptsWithContext (epochInfo globals) (systemStart globals) pp tx utxo of
    Left [CollectError era]
errs ->
      String -> ImpM (LedgerSpec era) [PlutusWithContext]
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) [PlutusWithContext])
-> String -> ImpM (LedgerSpec era) [PlutusWithContext]
forall a b. (a -> b) -> a -> b
$ String
"Did not expect to get context translation failures: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((CollectError era -> String) -> [CollectError era] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CollectError era -> String
forall a. Show a => a -> String
show [CollectError era]
errs)
    Right [PlutusWithContext]
pwcs -> [PlutusWithContext] -> ImpM (LedgerSpec era) [PlutusWithContext]
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PlutusWithContext]
pwcs

impScriptPredicateFailure ::
  (HasCallStack, AlonzoEraImp era) => Tx TopTx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure Tx TopTx era
tx = do
  plutusWithContexts <- Tx TopTx era -> ImpTestM era [PlutusWithContext]
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts Tx TopTx era
tx
  when (null plutusWithContexts) $
    assertFailure "Could not find any plutus scripts in the transaction"
  case evalPlutusScriptsWithLogs plutusWithContexts of
    ([Text]
logs, Passes [PlutusWithContext]
_) ->
      String -> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era))
-> String -> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era)
forall a b. (a -> b) -> a -> b
$
        String
"Plutus script: \n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PlutusWithContext -> String) -> [PlutusWithContext] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PlutusWithContext -> String
forall a. Show a => a -> String
show [PlutusWithContext]
plutusWithContexts)
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"passed unexpectedly: \n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
forall a. Show a => a -> String
show [Text]
logs)
    ([Text]
_, Fails [PlutusWithContext]
_ NonEmpty ScriptFailure
failures) ->
      AlonzoUtxosPredFailure era
-> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoUtxosPredFailure era
 -> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era))
-> AlonzoUtxosPredFailure era
-> ImpM (LedgerSpec era) (AlonzoUtxosPredFailure era)
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Bool -> IsValid
IsValid Bool
True)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure -> FailureDescription)
-> NonEmpty ScriptFailure -> NonEmpty FailureDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
failures))

submitPhase2Invalid_ ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era ()
submitPhase2Invalid_ :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitPhase2Invalid_ = ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ())
-> (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> Tx TopTx era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitPhase2Invalid

submitPhase2Invalid ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
submitPhase2Invalid :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitPhase2Invalid Tx TopTx era
tx = do
  fixedUpTx <-
    String
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Check that tx fails with IsValid True" (ImpM (LedgerSpec era) (Tx TopTx era)
 -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ do
      Tx TopTx era
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL IsValid -> IsValid -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool -> IsValid
IsValid Bool
True
      (predFailure, fixedUpTx) <- Either
  (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
  (Tx TopTx era)
-> ImpM
     (LedgerSpec era)
     (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft (Either
   (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
   (Tx TopTx era)
 -> ImpM
      (LedgerSpec era)
      (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
        (Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitTx Tx TopTx era
tx
      scriptPredicateFailure <- impScriptPredicateFailure fixedUpTx
      predFailure `shouldBeExpr` pure (injectFailure scriptPredicateFailure)
      pure fixedUpTx
  impAnn "Submit tx with IsValid False" $ do
    withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False

impAlonzoExpectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx TopTx era -> ImpTestM era ()
impAlonzoExpectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era ()
impAlonzoExpectTxSuccess Tx TopTx era
tx = do
  utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  let inputs = Tx TopTx era
tx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL
      collaterals = Tx TopTx era
tx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL
      outputs = Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxIn (TxOut era) -> [(TxIn, TxOut era)])
-> (TxBody TopTx era -> Map TxIn (TxOut era))
-> TxBody TopTx era
-> [(TxIn, TxOut era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO era -> Map TxIn (TxOut era))
-> (TxBody TopTx era -> UTxO era)
-> TxBody TopTx era
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody TopTx era -> UTxO era
forall era (l :: TxLevel).
EraTxBody era =>
TxBody l era -> UTxO era
txouts (TxBody TopTx era -> [(TxIn, TxOut era)])
-> TxBody TopTx era -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
  if tx ^. isValidTxL == IsValid True
    then do
      impAnn "Inputs should be gone from UTxO" $
        expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs]
      impAnn "Collateral inputs should still be in UTxO" $
        expectUTxOContent utxo [(txIn, isJust) | txIn <- Set.toList $ collaterals \\ inputs]
      impAnn "Outputs should be in UTxO" $
        expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs]
    else do
      impAnn "Non-collateral inputs should still be in UTxO" $
        expectUTxOContent utxo [(txIn, isJust) | txIn <- Set.toList $ inputs \\ collaterals]
      impAnn "Collateral inputs should not be in UTxO" $
        expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList collaterals]
      impAnn "Outputs should not be in UTxO" $
        expectUTxOContent utxo [(txIn, isNothing) | (txIn, _txOut) <- outputs]

computeScriptIntegrity ::
  AlonzoEraImp era =>
  PParams era ->
  UTxO era ->
  Tx l era ->
  StrictMaybe (ScriptIntegrity era)
computeScriptIntegrity :: forall era (l :: TxLevel).
AlonzoEraImp era =>
PParams era
-> UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era)
computeScriptIntegrity PParams era
pp UTxO era
utxo Tx l era
tx = PParams era
-> Tx l era
-> ScriptsProvided era
-> Set ScriptHash
-> StrictMaybe (ScriptIntegrity era)
forall era (l :: TxLevel).
(AlonzoEraPParams era, AlonzoEraTxWits era, EraUTxO era) =>
PParams era
-> Tx l era
-> ScriptsProvided era
-> Set ScriptHash
-> StrictMaybe (ScriptIntegrity era)
mkScriptIntegrity PParams era
pp Tx l era
tx ScriptsProvided era
scriptsProvided Set ScriptHash
scriptsNeeded
  where
    scriptsProvided :: ScriptsProvided era
scriptsProvided = UTxO era -> Tx l era -> ScriptsProvided era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> Tx t era -> ScriptsProvided era
forall (t :: TxLevel). UTxO era -> Tx t era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx l era
tx
    scriptsNeeded :: Set ScriptHash
scriptsNeeded = ScriptsNeeded era -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (ScriptsNeeded era -> Set ScriptHash)
-> (TxBody l era -> ScriptsNeeded era)
-> TxBody l era
-> Set ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> TxBody l era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (TxBody l era -> Set ScriptHash) -> TxBody l era -> Set ScriptHash
forall a b. (a -> b) -> a -> b
$ Tx l era
tx Tx l era
-> Getting (TxBody l era) (Tx l era) (TxBody l era) -> TxBody l era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody l era) (Tx l era) (TxBody l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL

impComputeScriptIntegrity ::
  AlonzoEraImp era =>
  Tx l era ->
  ImpTestM era (StrictMaybe (ScriptIntegrity era))
impComputeScriptIntegrity :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (StrictMaybe (ScriptIntegrity era))
impComputeScriptIntegrity Tx l era
tx =
  PParams era
-> UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
PParams era
-> UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era)
computeScriptIntegrity (PParams era
 -> UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era))
-> ImpM (LedgerSpec era) (PParams era)
-> ImpM
     (LedgerSpec era)
     (UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' (PParams era) (PParams era)
-> ImpM (LedgerSpec era) (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id ImpM
  (LedgerSpec era)
  (UTxO era -> Tx l era -> StrictMaybe (ScriptIntegrity era))
-> ImpM (LedgerSpec era) (UTxO era)
-> ImpM
     (LedgerSpec era) (Tx l era -> StrictMaybe (ScriptIntegrity era))
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO ImpM
  (LedgerSpec era) (Tx l era -> StrictMaybe (ScriptIntegrity era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (StrictMaybe (ScriptIntegrity era))
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx l era
tx

computeScriptIntegrityHash ::
  AlonzoEraImp era => Tx l era -> ImpTestM era (StrictMaybe ScriptIntegrityHash)
computeScriptIntegrityHash :: forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (StrictMaybe ScriptIntegrityHash)
computeScriptIntegrityHash Tx l era
tx = (ScriptIntegrity era -> ScriptIntegrityHash)
-> StrictMaybe (ScriptIntegrity era)
-> StrictMaybe ScriptIntegrityHash
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptIntegrity era -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity (StrictMaybe (ScriptIntegrity era)
 -> StrictMaybe ScriptIntegrityHash)
-> ImpM (LedgerSpec era) (StrictMaybe (ScriptIntegrity era))
-> ImpM (LedgerSpec era) (StrictMaybe ScriptIntegrityHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx l era
-> ImpM (LedgerSpec era) (StrictMaybe (ScriptIntegrity era))
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (StrictMaybe (ScriptIntegrity era))
impComputeScriptIntegrity Tx l era
tx