{-# 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 (..),
  impLookupPlutusScriptMaybe,
  malformedPlutus,
  addCollateralInput,
  impGetPlutusContexts,
  alonzoFixupTx,
  plutusTestScripts,
  impGetScriptContext,
  impGetScriptContextMaybe,
  impPlutusWithContexts,
  impScriptPredicateFailure,
  submitPhase2Invalid_,
  submitPhase2Invalid,
  expectTxSuccess,
  -- Fixup
  fixupDatums,
  fixupOutputDatums,
  fixupPPHash,
  fixupRedeemers,
  fixupRedeemerIndices,
  fixupScriptWits,
) 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.Context (EraPlutusContext)
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 (Redeemers (..), TxDats (..))
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), 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,
  esLStateL,
  lsUTxOStateL,
  nesEsL,
  utxosUtxoL,
 )
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.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
  , AlonzoEraScript era
  , AlonzoEraTxWits era
  , AlonzoEraTx era
  , AlonzoEraUTxO era
  , EraPlutusContext 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 <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshKeyAddr_
  forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx forall a b. (a -> b) -> a -> b
$ 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx
  | Bool
otherwise = do
      [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
ctx <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
ctx
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx
        else do
          forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"addCollateralInput" forall a b. (a -> b) -> a -> b
$ do
            TxIn
collateralInput <- forall era. ShelleyEraImp era => ImpTestM era TxIn
makeCollateralInput
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall a. a -> Set a
Set.singleton TxIn
collateralInput

impLookupPlutusScriptMaybe ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  Maybe (PlutusScript era)
impLookupPlutusScriptMaybe :: forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash
sh =
  (\(ScriptTestContext Plutus l
plutus PlutusArgs
_) -> forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript Plutus l
plutus) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impGetScriptContextMaybe @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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
  UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
  let AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash)]
asn = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo TxBody era
txBody
  [Maybe (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
mbyContexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash)]
asn forall a b. (a -> b) -> a -> b
$ \(PlutusPurpose AsIxItem era
prp, ScriptHash
sh) -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIxItem era
prp,ScriptHash
sh,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impGetScriptContextMaybe @era ScriptHash
sh
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemerIndices" forall a b. (a -> b) -> a -> b
$ do
  (TxIn
rootTxIn, TxOut era
_) <- forall era. ImpTestM era (TxIn, TxOut era)
lookupImpRootTxOut
  let
    txInputs :: Set TxIn
txInputs = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    rootTxIndex :: Word32
rootTxIndex = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> Bool
>= Word32
rootTxIndex = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ix it. ix -> AsIx ix it
AsIx forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Word32
i
    updateIndex PlutusPurpose AsIx era
x = PlutusPurpose AsIx era
x
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
        forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\(Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m) -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PlutusPurpose AsIx era -> PlutusPurpose AsIx era
updateIndex Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m)

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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemers" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
  Tx era
txWithMaxExUnits <- forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
txWithMaxRedeemers Tx era
tx
  let Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers = Tx era
txWithMaxExUnits forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  Globals {SystemStart
systemStart :: Globals -> SystemStart
systemStart :: SystemStart
systemStart, EpochInfo (Either Text)
epochInfo :: Globals -> EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo} <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  let reports :: RedeemerReport era
reports = 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 <-
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM RedeemerReport era
reports forall a b. (a -> b) -> a -> b
$ \case
      Left TransactionScriptFailure era
err -> do
        forall t. HasCallStack => String -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ String
"Execution Units estimation error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TransactionScriptFailure era
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Right ExUnits
exUnits ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx
       in case 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (Data era, ExUnits)
redeemer)
            Maybe (Data era, ExUnits)
Nothing ->
              case 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
                  forall t. HasCallStack => String -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ String
"Missing Redeemer Ptr from execution estimation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PlutusPurpose AsIx era
ptr
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                Just ExUnits
exUnits ->
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
exUnits))
  Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newRedeemers <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
mkNewRedeemers [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (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 <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let
    maxExUnit :: ExUnits
maxExUnit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => 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 forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx, (forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
maxExUnit))
    newMaxRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
mkNewMaxRedeemers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers 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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupScriptWits" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let ScriptsProvided Map ScriptHash (Script era)
provided = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (\(PlutusPurpose AsIxItem era
_, ScriptHash
sh, ScriptTestContext
_) -> Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member ScriptHash
sh Map ScriptHash (Script 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
x
        Maybe (PlutusScript era)
Nothing -> forall a. HasCallStack => String -> a
error String
"Plutus version not supported by era"
  [(ScriptHash, Script era)]
scriptWits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contextsToAdd forall a b. (a -> b) -> a -> b
$ \(PlutusPurpose AsIxItem era
_, ScriptHash
sh, ScriptTestContext Plutus l
plutus PlutusArgs
_) ->
    (ScriptHash
sh,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (l :: Language).
PlutusLanguage l =>
Plutus l -> ImpTestM era (Script era)
plutusToScript Plutus l
plutus
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ 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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupDatums" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  let purposes :: [PlutusPurpose AsIxItem era]
purposes = (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
_1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
contexts
  [Maybe (Data era)]
datums <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
collectDatums [PlutusPurpose AsIxItem era]
purposes
  let TxDats Map DataHash (Data era)
prevDats = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats
          (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map DataHash (Data era)
prevDats forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. Data era -> DataHash
hashData (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Data era)]
datums))
  where
    collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
    collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
collectDatums PlutusPurpose AsIxItem era
purpose = do
      let txIn :: Maybe TxIn
txIn = forall ix it. AsItem ix it -> it
unAsItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
toSpendingPurpose (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
purpose)
      Maybe (TxOut era)
txOut <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall era. ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impLookupUTxO @era) Maybe TxIn
txIn
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOut era -> Maybe (Data era)
getData 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 forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
datumTxOutF of
      DatumHash DataHash
_dh -> forall {era}. Era era => ScriptTestContext -> Data era
spendDatum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall {era}. EraTxOut era => TxOut era -> ScriptHash
txOutScriptHash TxOut era
txOut) (forall era. AlonzoEraImp era => Map ScriptHash ScriptTestContext
scriptTestContexts @era)
      Datum era
_ -> forall a. Maybe a
Nothing

    txOutScriptHash :: TxOut era -> ScriptHash
txOutScriptHash TxOut era
txOut
      | Addr Network
_ (ScriptHashObj ScriptHash
sh) StakeReference
_ <- TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL = ScriptHash
sh
      | Bool
otherwise = 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))) = forall era. Era era => Data -> Data era
Data Data
d
    spendDatum ScriptTestContext
_ = 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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupPPHash" forall a b. (a -> b) -> a -> b
$ do
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let
    scriptHashes :: Set ScriptHash
    scriptHashes :: Set ScriptHash
scriptHashes = forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    plutusLanguage :: ScriptHash -> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage ScriptHash
sh = do
      let mbyPlutus :: Maybe (PlutusScript era)
mbyPlutus = forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash
sh
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PlutusScript era)
mbyPlutus
  [Maybe LangDepView]
langs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptHash -> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set ScriptHash
scriptHashes
  let
    integrityHash :: StrictMaybe ScriptIntegrityHash
integrityHash =
      forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
hashScriptIntegrity
        (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe LangDepView]
langs)
        (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)
        (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL 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 = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupOutputDatums" forall a b. (a -> b) -> a -> b
$ do
  let
    addDatum :: TxOut era -> TxOut era
addDatum TxOut era
txOut =
      case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => 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
impGetScriptContextMaybe @era ScriptHash
sh
          , Datum era
NoDatum <- TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
datumTxOutF ->
              TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era. Data era -> DataHash
hashData @era forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data -> Data era
Data Data
spendDatum)
        Addr
_ -> TxOut era
txOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ 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 =
  forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
addCollateralInput
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupFees
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
  Tx era
txWithMax <- 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 <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees Tx era
txWithMax
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
txWithFees forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL 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 =
  ( 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 =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). Plutus l
malformedPlutus @l) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
7)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
3)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
26)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) forall a. Maybe a
Nothing
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) forall a. Maybe a
Nothing
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
221) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
122) forall a. Maybe a
Nothing
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
222) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language).
PlutusLanguage l =>
Plutus l -> PlutusArgs -> (ScriptHash, ScriptTestContext)
mkScriptTestEntry Plutus 'PlutusV3
guardrailScript forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    ]

malformedPlutus :: Plutus l
malformedPlutus :: forall (l :: Language). Plutus l
malformedPlutus = 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 =
    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
testingCostModels [Language
PlutusV1]
        , agPrices :: Prices
agPrices =
            Prices
              { prMem :: NonNegativeInterval
prMem = Integer
577 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000
              , prSteps :: NonNegativeInterval
prSteps = Integer
721 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000_000
              }
        , agMaxTxExUnits :: ExUnits
agMaxTxExUnits =
            ExUnits
              { exUnitsMem :: Natural
exUnitsMem = Natural
10_000_000
              , exUnitsSteps :: Natural
exUnitsSteps = Natural
10_000_000_000
              }
        , agMaxBlockExUnits :: ExUnits
agMaxBlockExUnits =
            ExUnits
              { exUnitsMem :: Natural
exUnitsMem = Natural
50_000_000
              , exUnitsSteps :: Natural
exUnitsSteps = Natural
40_000_000_000
              }
        , agMaxValSize :: Natural
agMaxValSize = Natural
5000
        , agCollateralPercentage :: Natural
agCollateralPercentage = Natural
150
        , agMaxCollateralInputs :: Natural
agMaxCollateralInputs = Natural
3
        }

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

instance MaryEraImp AlonzoEra

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

impGetScriptContextMaybe ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash ->
  Maybe ScriptTestContext
impGetScriptContextMaybe :: forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impGetScriptContextMaybe ScriptHash
sh = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
sh 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 =
  forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (String
"Getting script context for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptHash
sh)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust
    forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe ScriptTestContext
impGetScriptContextMaybe @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 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case 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 ->
      forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Did not expect to get context translation failures: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [CollectError era]
errs)
    Right [PlutusWithContext]
pwcs -> 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 <- forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era [PlutusWithContext]
impPlutusWithContexts Tx era
tx
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PlutusWithContext]
plutusWithContexts) forall a b. (a -> b) -> a -> b
$
    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]
_) ->
      forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
        String
"Plutus script: \n"
          forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [PlutusWithContext]
plutusWithContexts)
          forall a. [a] -> [a] -> [a]
++ String
"passed unexpectedly: \n"
          forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Text]
logs)
    ([Text]
_, Fails [PlutusWithContext]
_ NonEmpty ScriptFailure
failures) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Bool -> IsValid
IsValid Bool
True)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (ScriptFailure -> FailureDescription
scriptFailureToFailureDescription 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_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <-
    forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Check that tx fails with IsValid True" forall a b. (a -> b) -> a -> b
$ do
      Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL 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) <- forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure Tx era
fixedUpTx
      NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailure forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure AlonzoUtxosPredFailure era
scriptPredicateFailure)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
fixedUpTx
  forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Submit tx with IsValid False" forall a b. (a -> b) -> a -> b
$ do
    forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$ Tx era
fixedUpTx forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False

expectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era -> ImpTestM era ()
expectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess Tx era
tx
  | Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True = do
      UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
      let inputs :: [TxIn]
inputs = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
          outputs :: [(TxIn, TxOut era)]
outputs = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => TxBody era -> UTxO era
txouts forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Inputs should be gone from UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, forall a. Maybe a -> Bool
isNothing) | TxIn
txIn <- [TxIn]
inputs]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TxOut era
txOut)) | (TxIn
txIn, TxOut era
txOut) <- [(TxIn, TxOut era)]
outputs]
  | Bool
otherwise = do
      UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
      let inputs :: Set TxIn
inputs = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
          collaterals :: Set TxIn
collaterals = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
          outputs :: [(TxIn, TxOut era)]
outputs = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => TxBody era -> UTxO era
txouts forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Non-collateral inputs should still be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, forall a. Maybe a -> Bool
isJust) | TxIn
txIn <- forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set TxIn
inputs forall a. Ord a => Set a -> Set a -> Set a
\\ Set TxIn
collaterals]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral inputs should not be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, forall a. Maybe a -> Bool
isNothing) | TxIn
txIn <- forall a. Set a -> [a]
Set.toList Set TxIn
collaterals]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should not be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, forall a. Maybe a -> Bool
isNothing) | (TxIn
txIn, TxOut era
_txOut) <- [(TxIn, TxOut era)]
outputs]