{-# 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,
  -- 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.PParams (getLanguageView)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  collectPlutusScriptsWithContext,
  evalPlutusScriptsWithLogs,
  evalTxExUnits,
 )
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure (..),
  TagMismatchDescription (..),
  scriptFailureToFailureDescription,
 )
import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage, toAsItem, toAsIx)
import Cardano.Ledger.Alonzo.Tx (IsValid (..), hashScriptIntegrity)
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,
 )
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 (Set, (\\))
import qualified Data.Set as Set
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
  ) =>
  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
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  (Tx era -> ImpTestM era (Tx era))
-> ImpTestM era TxIn -> ImpTestM era TxIn
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx era -> ImpTestM era (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx (ImpTestM era TxIn -> ImpTestM era TxIn)
-> ImpTestM era TxIn -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr Coin
collateral

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

impLookupPlutusScript ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  Maybe (PlutusScript era)
impLookupPlutusScript :: forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
sh =
  (\(ScriptTestContext Plutus l
plutus PlutusArgs
_) -> Plutus l -> Maybe (PlutusScript era)
forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript Plutus l
plutus) (ScriptTestContext -> Maybe (PlutusScript era))
-> Maybe ScriptTestContext -> Maybe (PlutusScript era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impLookupScriptContext @era ScriptHash
sh

impGetPlutusContexts ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts :: forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx = do
  let txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
  UTxO era
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 [(PlutusPurpose AsIxItem era, ScriptHash)]
asn = UTxO era -> TxBody era -> ScriptsNeeded era
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo TxBody era
txBody
  [Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
mbyContexts <- [(PlutusPurpose AsIxItem era, ScriptHash)]
-> ((PlutusPurpose AsIxItem era, ScriptHash)
    -> ImpM
         (LedgerSpec era)
         (Maybe
            (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)))
-> ImpM
     (LedgerSpec era)
     [Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash)]
asn (((PlutusPurpose AsIxItem era, ScriptHash)
  -> ImpM
       (LedgerSpec era)
       (Maybe
          (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)))
 -> ImpM
      (LedgerSpec era)
      [Maybe
         (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)])
-> ((PlutusPurpose AsIxItem era, ScriptHash)
    -> ImpM
         (LedgerSpec era)
         (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) -> 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
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
 -> ImpTestM
      era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)])
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall a b. (a -> b) -> a -> b
$ [Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
mbyContexts

fixupRedeemerIndices ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupRedeemerIndices :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemerIndices" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ do
  (TxIn
rootTxIn, TxOut era
_) <- ImpTestM era (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
  let
    txInputs :: Set TxIn
txInputs = Tx era
tx Tx era -> Getting (Set TxIn) (Tx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (Set TxIn) (TxBody era))
-> Tx era -> Const (Set TxIn) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (Set TxIn) (TxBody era))
 -> Tx era -> Const (Set TxIn) (Tx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody era -> Const (Set TxIn) (TxBody era))
-> Getting (Set TxIn) (Tx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody era -> Const (Set TxIn) (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    rootTxIndex :: Word32
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 :: PlutusPurpose AsIx era -> PlutusPurpose AsIx era
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
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (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 ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (PlutusPurpose AsIx era -> PlutusPurpose AsIx era)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PlutusPurpose AsIx era -> PlutusPurpose AsIx era
updateIndex

fixupRedeemers ::
  forall era.
  (AlonzoEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupRedeemers :: forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemers" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- Tx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let oldRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers = Tx era
tx Tx era
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx 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 era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
 -> Tx era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx 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 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
  Tx era
txWithMaxExUnits <- Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
txWithMaxRedeemers Tx era
tx
  let newMaxRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers = Tx era
txWithMaxExUnits Tx era
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx 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 era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
 -> Tx era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx 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 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 era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  Globals {SystemStart
systemStart :: SystemStart
systemStart :: Globals -> SystemStart
systemStart, EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo :: Globals -> EpochInfo (Either Text)
epochInfo} <- 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
  let reports :: RedeemerReport era
reports = PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits PParams era
pp Tx era
txWithMaxExUnits UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
  Map (PlutusPurpose AsIx era) ExUnits
exUnitsPerPurpose <-
    (Map (PlutusPurpose AsIx era) (Maybe ExUnits)
 -> Map (PlutusPurpose AsIx era) ExUnits)
-> ImpM
     (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits))
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a b.
(a -> b) -> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ExUnits -> Maybe ExUnits)
-> Map (PlutusPurpose AsIx era) (Maybe ExUnits)
-> Map (PlutusPurpose AsIx era) ExUnits
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Maybe ExUnits -> Maybe ExUnits
forall a. a -> a
id) (ImpM
   (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits))
 -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> ImpM
     (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits))
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a b. (a -> b) -> a -> b
$ RedeemerReport era
-> (Either (TransactionScriptFailure era) ExUnits
    -> ImpM (LedgerSpec era) (Maybe ExUnits))
-> ImpM
     (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM RedeemerReport era
reports ((Either (TransactionScriptFailure era) ExUnits
  -> ImpM (LedgerSpec era) (Maybe ExUnits))
 -> ImpM
      (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits)))
-> (Either (TransactionScriptFailure era) ExUnits
    -> ImpM (LedgerSpec era) (Maybe ExUnits))
-> ImpM
     (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Maybe ExUnits))
forall a b. (a -> b) -> a -> b
$ \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, ScriptHash, ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
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))
  Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newRedeemers <- [(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 AsIx era, (Data era, ExUnits))]
 -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> ([Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
    -> [(PlutusPurpose AsIx era, (Data era, ExUnits))])
-> [Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> ImpM
     (LedgerSpec era)
     [Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
-> ImpM
     (LedgerSpec era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
 -> ImpM
      (LedgerSpec era)
      (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))))
-> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> ImpM
     (LedgerSpec era)
     [Maybe (PlutusPurpose AsIx era, (Data era, ExUnits))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
mkNewRedeemers [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (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 ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Map (PlutusPurpose AsIx era) (Data era, ExUnits)]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers, Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newRedeemers, Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers]

txWithMaxRedeemers ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
txWithMaxRedeemers :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
txWithMaxRedeemers Tx era
tx = do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- Tx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let
    maxExUnit :: ExUnits
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, ScriptHash, ScriptTestContext)
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
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 :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
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)
  Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (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 ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers

fixupScriptWits ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupScriptWits :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupScriptWits" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- Tx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  let ScriptsProvided Map ScriptHash (Script era)
provided = UTxO era -> Tx era -> ScriptsProvided era
forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
  let contextsToAdd :: [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
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
  let
    plutusToScript ::
      forall l.
      PlutusLanguage l =>
      Plutus l ->
      ImpTestM era (Script era)
    plutusToScript :: forall (l :: Language).
PlutusLanguage l =>
Plutus l -> ImpTestM era (Script era)
plutusToScript Plutus l
p =
      case forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript @era Plutus l
p of
        Just PlutusScript era
x -> Script era -> ImpTestM era (Script era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script era -> ImpTestM era (Script era))
-> Script era -> ImpTestM era (Script era)
forall a b. (a -> b) -> a -> b
$ PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
x
        Maybe (PlutusScript era)
Nothing -> String -> ImpM (LedgerSpec era) (AlonzoScript era)
forall a. HasCallStack => String -> a
error String
"Plutus version not supported by era"
  [(ScriptHash, Script era)]
scriptWits <- [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
-> ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
    -> ImpM (LedgerSpec era) (ScriptHash, Script era))
-> ImpM (LedgerSpec era) [(ScriptHash, Script era)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contextsToAdd (((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
  -> ImpM (LedgerSpec era) (ScriptHash, Script era))
 -> ImpM (LedgerSpec era) [(ScriptHash, Script era)])
-> ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
    -> ImpM (LedgerSpec era) (ScriptHash, Script era))
-> ImpM (LedgerSpec era) [(ScriptHash, Script era)]
forall a b. (a -> b) -> a -> b
$ \(PlutusPurpose AsIxItem era
_, ScriptHash
sh, ScriptTestContext Plutus l
plutus PlutusArgs
_) ->
    (ScriptHash
sh,) (AlonzoScript era -> (ScriptHash, Script era))
-> ImpM (LedgerSpec era) (AlonzoScript era)
-> ImpM (LedgerSpec era) (ScriptHash, Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plutus l -> ImpTestM era (Script era)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> ImpTestM era (Script era)
plutusToScript Plutus l
plutus
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map ScriptHash (Script era)
     -> Identity (Map ScriptHash (Script era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era)
    -> Identity (Map ScriptHash (Script era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> Tx era -> Identity (Tx era))
-> Map ScriptHash (Script era) -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScriptHash, Script era)]
scriptWits

fixupDatums ::
  forall era.
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupDatums :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupDatums" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- Tx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  let purposes :: [PlutusPurpose AsIxItem era]
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
  [Maybe (Data era)]
datums <- (PlutusPurpose AsIxItem era
 -> ImpM (LedgerSpec era) (Maybe (Data era)))
-> [PlutusPurpose AsIxItem era]
-> ImpM (LedgerSpec era) [Maybe (Data 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) -> [a] -> f [b]
traverse PlutusPurpose AsIxItem era
-> ImpM (LedgerSpec era) (Maybe (Data era))
collectDatums [PlutusPurpose AsIxItem era]
purposes
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Identity (TxDats era))
-> TxWits era -> Identity (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL ((TxDats era -> Identity (TxDats era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxDats era -> Identity (TxDats era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxDats era -> Identity (TxDats era)
forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
Lens' (TxDats era) (Map DataHash (Data era))
unTxDatsL
        ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
 -> Tx era -> Identity (Tx era))
-> Map DataHash (Data era) -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ (Data era -> DataHash) -> [Data era] -> Map DataHash (Data era)
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems Data era -> DataHash
forall era. Data era -> DataHash
hashData ([Maybe (Data era)] -> [Data era]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Data era)]
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)
      Maybe (TxOut era)
txOut <- (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
      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)))
-> Maybe (Data era) -> ImpM (LedgerSpec era) (Maybe (Data era))
forall a b. (a -> b) -> a -> b
$ TxOut era -> Maybe (Data era)
getData (TxOut era -> Maybe (Data era))
-> Maybe (TxOut era) -> Maybe (Data era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (TxOut era)
txOut

    getData :: TxOut era -> Maybe (Data era)
    getData :: TxOut era -> Maybe (Data era)
getData TxOut era
txOut = 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 -> 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 -> Data era)
-> Maybe ScriptTestContext -> Maybe (Data era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptHash
-> Map ScriptHash ScriptTestContext -> Maybe ScriptTestContext
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (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) (forall era. AlonzoEraImp era => Map ScriptHash ScriptTestContext
scriptTestContexts @era)
      Datum era
_ -> 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.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupPPHash :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupPPHash" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ do
  PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  let
    scriptHashes :: Set ScriptHash
    scriptHashes :: Set ScriptHash
scriptHashes = ScriptsNeeded era -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (ScriptsNeeded era -> Set ScriptHash)
-> (TxBody era -> ScriptsNeeded era)
-> TxBody era
-> Set ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> TxBody era -> ScriptsNeeded era
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (TxBody era -> Set ScriptHash) -> TxBody era -> Set ScriptHash
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
    plutusLanguage :: ScriptHash -> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage ScriptHash
sh = do
      let mbyPlutus :: Maybe (PlutusScript era)
mbyPlutus = ScriptHash -> Maybe (PlutusScript era)
forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
sh
      Maybe LangDepView -> ImpM (LedgerSpec era) (Maybe LangDepView)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LangDepView -> ImpM (LedgerSpec era) (Maybe LangDepView))
-> Maybe LangDepView -> ImpM (LedgerSpec era) (Maybe LangDepView)
forall a b. (a -> b) -> a -> b
$ PParams era -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pp (Language -> LangDepView)
-> (PlutusScript era -> Language)
-> PlutusScript era
-> LangDepView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage @era (PlutusScript era -> LangDepView)
-> Maybe (PlutusScript era) -> Maybe LangDepView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PlutusScript era)
mbyPlutus
  [Maybe LangDepView]
langs <- (ScriptHash -> ImpM (LedgerSpec era) (Maybe LangDepView))
-> [ScriptHash] -> ImpM (LedgerSpec era) [Maybe LangDepView]
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) -> [a] -> f [b]
traverse ScriptHash -> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage ([ScriptHash] -> ImpM (LedgerSpec era) [Maybe LangDepView])
-> [ScriptHash] -> ImpM (LedgerSpec era) [Maybe LangDepView]
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> [ScriptHash]
forall a. Set a -> [a]
Set.toList Set ScriptHash
scriptHashes
  let
    integrityHash :: StrictMaybe ScriptIntegrityHash
integrityHash =
      Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
hashScriptIntegrity
        ([LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList ([LangDepView] -> Set LangDepView)
-> [LangDepView] -> Set LangDepView
forall a b. (a -> b) -> a -> b
$ [Maybe LangDepView] -> [LangDepView]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LangDepView]
langs)
        (Tx era
tx Tx era
-> Getting (Redeemers era) (Tx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx era -> Const (Redeemers era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx era -> Const (Redeemers era) (Tx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx 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)
        (Tx era
tx Tx era -> Getting (TxDats era) (Tx era) (TxDats era) -> TxDats era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (TxDats era) (TxWits era))
-> Tx era -> Const (TxDats era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (TxDats era) (TxWits era))
 -> Tx era -> Const (TxDats era) (Tx era))
-> ((TxDats era -> Const (TxDats era) (TxDats era))
    -> TxWits era -> Const (TxDats era) (TxWits era))
-> Getting (TxDats era) (Tx era) (TxDats era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Const (TxDats era) (TxDats era))
-> TxWits era -> Const (TxDats era) (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL)
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe ScriptIntegrityHash -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
integrityHash

fixupOutputDatums ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupOutputDatums :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums Tx era
tx = String
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupOutputDatums" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx 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 era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx era
-> Tx 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 era ->
  ImpTestM era (Tx era)
alonzoFixupTx :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx =
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
addCollateralInput
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx 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 era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupFees
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash
    (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits

alonzoFixupFees :: forall era. (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (Tx era)
alonzoFixupFees :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupFees Tx era
tx = do
  let originalRedeemers :: Redeemers era
originalRedeemers = Tx era
tx Tx era
-> Getting (Redeemers era) (Tx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx era -> Const (Redeemers era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx era -> Const (Redeemers era) (Tx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx 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
  Tx era
txWithMax <- Tx era -> ImpTestM era (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
txWithMaxRedeemers Tx 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
  Tx era
txWithFees <- Tx era -> ImpTestM era (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees Tx era
txWithMax
  Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
txWithFees Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Redeemers era -> Identity (Redeemers era))
    -> TxWits era -> Identity (TxWits era))
-> (Redeemers era -> Identity (Redeemers era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> Tx era -> Identity (Tx era))
-> Redeemers era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers era
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
    [ 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
    ]

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
34482)
        , 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 :: Set (KeyHash 'Witness)
-> TxBody AlonzoEra
-> NativeScript AlonzoEra
-> ImpTestM
     AlonzoEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = Set (KeyHash 'Witness)
-> TxBody AlonzoEra
-> NativeScript AlonzoEra
-> ImpTestM
     AlonzoEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack => Tx AlonzoEra -> ImpTestM AlonzoEra (Tx AlonzoEra)
fixupTx = Tx AlonzoEra -> ImpTestM AlonzoEra (Tx AlonzoEra)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx
  expectTxSuccess :: HasCallStack => Tx AlonzoEra -> ImpTestM AlonzoEra ()
expectTxSuccess = Tx AlonzoEra -> ImpTestM AlonzoEra ()
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
impAlonzoExpectTxSuccess

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 era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts Tx era
tx = do
  Globals
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
  PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  case EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext]
forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext]
collectPlutusScriptsWithContext (Globals -> EpochInfo (Either Text)
epochInfo Globals
globals) (Globals -> SystemStart
systemStart Globals
globals) PParams era
pp Tx era
tx UTxO era
utxo of
    Left [CollectError era]
errs ->
      String -> ImpTestM era [PlutusWithContext]
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpTestM era [PlutusWithContext])
-> String -> ImpTestM 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] -> ImpTestM 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 era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure Tx era
tx = do
  [PlutusWithContext]
plutusWithContexts <- Tx era -> ImpTestM era [PlutusWithContext]
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts Tx era
tx
  Bool -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PlutusWithContext] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PlutusWithContext]
plutusWithContexts) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
    String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"Could not find any plutus scripts in the transaction"
  case [PlutusWithContext] -> ([Text], ScriptResult)
evalPlutusScriptsWithLogs [PlutusWithContext]
plutusWithContexts of
    ([Text]
logs, Passes [PlutusWithContext]
_) ->
      String -> ImpTestM era (AlonzoUtxosPredFailure era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpTestM era (AlonzoUtxosPredFailure era))
-> String -> ImpTestM 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
-> ImpTestM era (AlonzoUtxosPredFailure era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoUtxosPredFailure era
 -> ImpTestM era (AlonzoUtxosPredFailure era))
-> AlonzoUtxosPredFailure era
-> ImpTestM 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
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  Tx era ->
  ImpTestM era ()
submitPhase2Invalid_ :: forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ = ImpM (LedgerSpec era) (Tx era) -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (Tx era) -> ImpTestM era ())
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpTestM era ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid

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

impAlonzoExpectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era -> ImpTestM era ()
impAlonzoExpectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
impAlonzoExpectTxSuccess Tx era
tx = do
  UTxO era
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 :: Set TxIn
inputs = Tx era
tx Tx era -> Getting (Set TxIn) (Tx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (Set TxIn) (TxBody era))
-> Tx era -> Const (Set TxIn) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (Set TxIn) (TxBody era))
 -> Tx era -> Const (Set TxIn) (Tx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody era -> Const (Set TxIn) (TxBody era))
-> Getting (Set TxIn) (Tx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody era -> Const (Set TxIn) (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
      collaterals :: Set TxIn
collaterals = Tx era
tx Tx era -> Getting (Set TxIn) (Tx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (Set TxIn) (TxBody era))
-> Tx era -> Const (Set TxIn) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (Set TxIn) (TxBody era))
 -> Tx era -> Const (Set TxIn) (Tx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody era -> Const (Set TxIn) (TxBody era))
-> Getting (Set TxIn) (Tx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody era -> Const (Set TxIn) (TxBody era)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
      outputs :: [(TxIn, TxOut era)]
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 era -> Map TxIn (TxOut era))
-> TxBody 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 era -> UTxO era) -> TxBody era -> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> UTxO era
forall era. EraTxBody era => TxBody era -> UTxO era
txouts (TxBody era -> [(TxIn, TxOut era)])
-> TxBody era -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
  if Tx era
tx Tx era -> Getting IsValid (Tx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True
    then do
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Inputs should be gone from UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isNothing) | TxIn
txIn <- Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList Set TxIn
inputs]
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral inputs should still be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isJust) | TxIn
txIn <- Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Set TxIn
collaterals Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
\\ Set TxIn
inputs]
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, (Maybe (TxOut era) -> Maybe (TxOut era) -> Bool
forall a. Eq a => a -> a -> Bool
== TxOut era -> Maybe (TxOut era)
forall a. a -> Maybe a
Just TxOut era
txOut)) | (TxIn
txIn, TxOut era
txOut) <- [(TxIn, TxOut era)]
outputs]
    else do
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Non-collateral inputs should still be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isJust) | TxIn
txIn <- Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Set TxIn
inputs Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
\\ Set TxIn
collaterals]
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral inputs should not be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isNothing) | TxIn
txIn <- Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList Set TxIn
collaterals]
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should not be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isNothing) | (TxIn
txIn, TxOut era
_txOut) <- [(TxIn, TxOut era)]
outputs]