{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (LedgerTxInfo (..), toPlutusTxInfo)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  CollectError (NoCostModel),
  TransactionScriptFailure (RedeemerPointsToUnknownScriptHash),
  evalTxExUnits,
 )
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure (..),
  TagMismatchDescription (..),
 )
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
import Cardano.Ledger.BaseTypes (
  Globals (..),
  ProtVer (..),
  SlotNo (..),
  StrictMaybe (..),
  natVersion,
 )
import Cardano.Ledger.Plutus.Data (Data (..))
import Cardano.Ledger.Plutus.Language (hashPlutusScript, withSLanguage)
import qualified Cardano.Ledger.Plutus.Language as L
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Control.Monad.Reader (asks)
import Data.Either (isLeft)
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Lens.Micro (set, to, (%~), (&), (.~), (<>~), (^.), _2)
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsWithDatum,
  alwaysSucceedsWithDatum,
  datumIsWellformed,
  inputsOutputsAreNotEmptyWithDatum,
  purposeIsWellformedWithDatum,
  redeemerSameAsDatum,
 )

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOS" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
    String
"transaction validity interval has closed upper bound when protocol version < 9 and open otherwise"
    (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      EpochInfo (Either Text)
ei <- Getting
  (EpochInfo (Either Text))
  (ImpTestState era)
  (EpochInfo (Either Text))
-> ImpM (LedgerSpec era) (EpochInfo (Either Text))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting
   (EpochInfo (Either Text))
   (ImpTestState era)
   (EpochInfo (Either Text))
 -> ImpM (LedgerSpec era) (EpochInfo (Either Text)))
-> Getting
     (EpochInfo (Either Text))
     (ImpTestState era)
     (EpochInfo (Either Text))
-> ImpM (LedgerSpec era) (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> Const (EpochInfo (Either Text)) Globals)
-> ImpTestState era
-> Const (EpochInfo (Either Text)) (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const (EpochInfo (Either Text)) Globals)
 -> ImpTestState era
 -> Const (EpochInfo (Either Text)) (ImpTestState era))
-> ((EpochInfo (Either Text)
     -> Const (EpochInfo (Either Text)) (EpochInfo (Either Text)))
    -> Globals -> Const (EpochInfo (Either Text)) Globals)
-> Getting
     (EpochInfo (Either Text))
     (ImpTestState era)
     (EpochInfo (Either Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> EpochInfo (Either Text))
-> SimpleGetter Globals (EpochInfo (Either Text))
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> EpochInfo (Either Text)
epochInfo
      ss :: SystemStart
ss@(SystemStart UTCTime
sysStart) <- Getting SystemStart (ImpTestState era) SystemStart
-> ImpM (LedgerSpec era) SystemStart
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting SystemStart (ImpTestState era) SystemStart
 -> ImpM (LedgerSpec era) SystemStart)
-> Getting SystemStart (ImpTestState era) SystemStart
-> ImpM (LedgerSpec era) SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> Const SystemStart Globals)
-> ImpTestState era -> Const SystemStart (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const SystemStart Globals)
 -> ImpTestState era -> Const SystemStart (ImpTestState era))
-> ((SystemStart -> Const SystemStart SystemStart)
    -> Globals -> Const SystemStart Globals)
-> Getting SystemStart (ImpTestState era) SystemStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> SystemStart) -> SimpleGetter Globals SystemStart
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> SystemStart
systemStart
      SlotNo Word64
currentSlot <- Getting SlotNo (ImpTestState era) SlotNo
-> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impLastTickG
      ProtVer
protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
      UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
      let txValidity :: Word64
txValidity = Word64
7200
          -- We must provide a non-Nothing upper bound so that the "closed" vs "open" case can be tested.
          interval :: ValidityInterval
interval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (StrictMaybe SlotNo -> ValidityInterval)
-> StrictMaybe SlotNo -> ValidityInterval
forall a b. (a -> b) -> a -> b
$ SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo -> StrictMaybe SlotNo) -> SlotNo -> StrictMaybe SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
txValidity
          startPOSIX :: Integer
startPOSIX = POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
sysStart
          expectedUpperBound :: Integer
expectedUpperBound = (Integer
startPOSIX Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
txValidity)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000
          tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody era -> Identity (TxBody era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx era -> Identity (Tx era))
-> ValidityInterval -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval
interval
          lti :: LedgerTxInfo era
lti =
            LedgerTxInfo
              { ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
              , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
ei
              , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
ss
              , ltiUTxO :: UTxO era
ltiUTxO = UTxO era
utxo
              , ltiTx :: Tx era
ltiTx = Tx era
tx
              }
      case Proxy 'PlutusV1
-> LedgerTxInfo era
-> Either (ContextError era) (PlutusTxInfo 'PlutusV1)
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
forall (proxy :: Language -> *).
proxy 'PlutusV1
-> LedgerTxInfo era
-> Either (ContextError era) (PlutusTxInfo 'PlutusV1)
toPlutusTxInfo (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @L.PlutusV1) LedgerTxInfo era
lti of
        Left ContextError era
e -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"No translation error was expected, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContextError era -> String
forall a. Show a => a -> String
show ContextError era
e
        Right PlutusTxInfo 'PlutusV1
txInfo ->
          TxInfo -> POSIXTimeRange
PV1.txInfoValidRange PlutusTxInfo 'PlutusV1
TxInfo
txInfo
            POSIXTimeRange -> POSIXTimeRange -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` LowerBound POSIXTime -> UpperBound POSIXTime -> POSIXTimeRange
forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
              (Extended POSIXTime -> Bool -> LowerBound POSIXTime
forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound Extended POSIXTime
forall a. Extended a
PV1.NegInf Bool
True)
              ( Extended POSIXTime -> Bool -> UpperBound POSIXTime
forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound
                  ( POSIXTime -> Extended POSIXTime
forall a. a -> Extended a
PV1.Finite
                      (Integer -> POSIXTime
PV1.POSIXTime Integer
expectedUpperBound)
                  )
                  (ProtVer -> Version
pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) -- The upper bound.
              )

  [Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Language -> String
forall a. Show a => a -> String
show Language
lang) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      Language
-> (forall {l :: Language}.
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall {l :: Language}.
  PlutusLanguage l =>
  SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall {l :: Language}.
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang -> do
        let redeemerSameAsDatumHash :: ScriptHash
redeemerSameAsDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
            alwaysSucceedsWithDatumHash :: ScriptHash
alwaysSucceedsWithDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang

        let scripts :: [(String, SLanguage l -> Plutus l)]
scripts =
              [ (String
"redeemerSameAsDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
              , (String
"purposeIsWellformedWithDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum)
              , (String
"datumIsWellformed", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed)
              , (String
"inputsOutputsAreNotEmptyWithDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum)
              ]

        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ExUnits" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Calculate ExUnits" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
            let
              overrideExUnits :: Tx era -> ImpM (LedgerSpec era) (Tx era)
overrideExUnits Tx era
tx = 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
                Globals {EpochInfo (Either Text)
epochInfo :: Globals -> EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo, SystemStart
systemStart :: Globals -> SystemStart
systemStart :: SystemStart
systemStart} <- 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
                Map (PlutusPurpose AsIx era) ExUnits
purposeUnits <-
                  (TransactionScriptFailure era
 -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> (Map (PlutusPurpose AsIx era) ExUnits
    -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> Either
     (TransactionScriptFailure era)
     (Map (PlutusPurpose AsIx era) ExUnits)
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a. String -> ImpM (LedgerSpec era) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> (TransactionScriptFailure era -> String)
-> TransactionScriptFailure era
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionScriptFailure era -> String
forall a. Show a => a -> String
show) Map (PlutusPurpose AsIx era) ExUnits
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (TransactionScriptFailure era)
   (Map (PlutusPurpose AsIx era) ExUnits)
 -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> (Map
      (PlutusPurpose AsIx era)
      (Either (TransactionScriptFailure era) ExUnits)
    -> Either
         (TransactionScriptFailure era)
         (Map (PlutusPurpose AsIx era) ExUnits))
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
-> Either
     (TransactionScriptFailure era)
     (Map (PlutusPurpose AsIx era) ExUnits)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
Map (PlutusPurpose AsIx era) (m a)
-> m (Map (PlutusPurpose AsIx era) a)
sequence (Map
   (PlutusPurpose AsIx era)
   (Either (TransactionScriptFailure era) ExUnits)
 -> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits))
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
-> ImpM (LedgerSpec era) (Map (PlutusPurpose AsIx era) ExUnits)
forall a b. (a -> b) -> a -> b
$
                    PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
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
tx UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
                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
%~ Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
spliceUnits Map (PlutusPurpose AsIx era) ExUnits
purposeUnits
              spliceUnits :: Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
spliceUnits =
                SimpleWhenMissing
  (PlutusPurpose AsIx era) ExUnits (Data era, ExUnits)
-> SimpleWhenMissing
     (PlutusPurpose AsIx era) (Data era, ExUnits) (Data era, ExUnits)
-> SimpleWhenMatched
     (PlutusPurpose AsIx era)
     ExUnits
     (Data era, ExUnits)
     (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
                  SimpleWhenMissing
  (PlutusPurpose AsIx era) ExUnits (Data era, ExUnits)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing -- Ignore purposes not already in the redeemers
                  SimpleWhenMissing
  (PlutusPurpose AsIx era) (Data era, ExUnits) (Data era, ExUnits)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing -- Don't touch purposes not being updated
                  ((PlutusPurpose AsIx era
 -> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
-> SimpleWhenMatched
     (PlutusPurpose AsIx era)
     ExUnits
     (Data era, ExUnits)
     (Data era, ExUnits)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched ((PlutusPurpose AsIx era
  -> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
 -> SimpleWhenMatched
      (PlutusPurpose AsIx era)
      ExUnits
      (Data era, ExUnits)
      (Data era, ExUnits))
-> (PlutusPurpose AsIx era
    -> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
-> SimpleWhenMatched
     (PlutusPurpose AsIx era)
     ExUnits
     (Data era, ExUnits)
     (Data era, ExUnits)
forall a b. (a -> b) -> a -> b
$ \PlutusPurpose AsIx era
_ -> ASetter (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
-> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
forall s t a b. Field2 s t a b => Lens s t a b
Lens (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
_2) -- Replace the units, keep the datum
              redoAddrWits :: Tx era -> ImpM (LedgerSpec era) (Tx era)
redoAddrWits = Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> Tx era) -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((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))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
forall a. Monoid a => a
mempty)

            TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
            (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
overrideExUnits (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)
redoAddrWits) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
              Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Attempt to calculate ExUnits with an invalid tx" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
            TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
            let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

            Tx era
txFixed <- (Tx era
tx Tx era
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era)
forall a b. a -> (a -> b) -> b
&) ((Tx era -> ImpM (LedgerSpec era) (Tx era))
 -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup
            Tx era -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txFixed

            let
              twiddleIx :: StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
twiddleIx (SJust (SpendingPurpose (AsIx Word32
0))) = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
1)
              twiddleIx StrictMaybe (PlutusPurpose AsIx era)
_ = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
              badPurpose :: PlutusPurpose AsIx era
badPurpose =
                StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AlonzoEraScript era, AlonzoEraScript era) =>
StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
twiddleIx (StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era)
-> StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$
                  TxBody era
-> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era)
forall era.
AlonzoEraTxBody era =>
TxBody era
-> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era)
redeemerPointer (Tx era
txFixed 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) (AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (AsItem Word32 TxIn -> PlutusPurpose AsItem era)
-> AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall a b. (a -> b) -> a -> b
$ TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
AsItem TxIn
txIn)
              du :: (Data era, ExUnits)
du = (Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
forall a b. (a -> b) -> a -> b
$ Integer -> Data
PV1.I Integer
42, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000)
              txBorked :: Tx era
txBorked =
                Tx era
txFixed
                  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
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
badPurpose (Data era, ExUnits)
du
            Tx era -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txBorked

            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
            Globals {EpochInfo (Either Text)
epochInfo :: Globals -> EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo, SystemStart
systemStart :: Globals -> SystemStart
systemStart :: SystemStart
systemStart} <- 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 report :: Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
report = PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
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
txBorked UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
            Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
-> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
report

            (Either (TransactionScriptFailure era) ExUnits -> Bool)
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Either (TransactionScriptFailure era) ExUnits -> Bool
forall a b. Either a b -> Bool
isLeft Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
report
              Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` PlutusPurpose AsIx era
-> Either (TransactionScriptFailure era) ExUnits
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
forall k a. k -> a -> Map k a
Map.singleton PlutusPurpose AsIx era
badPurpose (TransactionScriptFailure era
-> Either (TransactionScriptFailure era) ExUnits
forall a b. a -> Either a b
Left (PlutusPurpose AsIx era -> TransactionScriptFailure era
forall era. PlutusPurpose AsIx era -> TransactionScriptFailure era
RedeemerPointsToUnknownScriptHash PlutusPurpose AsIx era
badPurpose))

        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending scripts with a Datum" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          [(String, SLanguage l -> Plutus l)]
-> ((String, SLanguage l -> Plutus l)
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts (((String, SLanguage l -> Plutus l)
  -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, SLanguage l -> Plutus l)
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              let sHash :: ScriptHash
sHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
              TxIn
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
sHash
              String -> Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submit a transaction that consumes the script output" (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
                    ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn0
              ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Valid transaction marked as invalid" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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
          Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Bool -> IsValid
IsValid Bool
False) TagMismatchDescription
PassedUnexpectedly)]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid transaction marked as valid" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus l -> ScriptHash) -> Plutus l -> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ImpTestM era TxIn) -> Plutus l -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid plutus script fails in phase 2" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          ExUnits
exUnits <- SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits)
-> SimpleGetter (NewEpochState era) ExUnits -> ImpTestM era ExUnits
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))
-> ((ExUnits -> Const r ExUnits)
    -> EpochState era -> Const r (EpochState era))
-> (ExUnits -> Const r ExUnits)
-> 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 ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((ExUnits -> Const r ExUnits)
    -> PParams era -> Const r (PParams era))
-> (ExUnits -> Const r ExUnits)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExUnits -> Const r ExUnits)
-> PParams era -> Const r (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
          String -> Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submitting consuming transaction" (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn0
              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
              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
.~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsIx Word32 TxIn -> PlutusPurpose AsIx era)
-> AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
32, ExUnits
exUnits)

        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Scripts pass in phase 2" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          let scripts' :: [(String, SLanguage l -> Plutus l)]
scripts' = Int
-> [(String, SLanguage l -> Plutus l)]
-> [(String, SLanguage l -> Plutus l)]
forall a. Int -> [a] -> [a]
drop Int
1 [(String, SLanguage l -> Plutus l)]
scripts
          [(String, SLanguage l -> Plutus l)]
-> ((String, SLanguage l -> Plutus l)
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts' (((String, SLanguage l -> Plutus l)
  -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, SLanguage l -> Plutus l)
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              let sHash :: ScriptHash
sHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
              TxIn
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
sHash
              String -> Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submitting consuming transaction" (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn0

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No cost model" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody 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. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((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
<>~ [Item (Set TxIn)
TxIn
txIn]
          (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels
forall a. Monoid a => a
mempty
          Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
            Tx era
tx
            [AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure ([CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [Language -> CollectError era
forall era. Language -> CollectError era
NoCostModel Language
lang])]