{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec (spec) where

import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusTxInfo, mkSupportedPlutusScript)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure (..))
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Rules (BabbageUtxowPredFailure (..))
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.Scripts (pattern RequireAnyOf)
import Cardano.Ledger.TxIn (mkTxInPartial)
import Data.Either (isRight)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (redeemerSameAsDatum)

spec ::
  forall era.
  ( AlonzoEraImp era
  , BabbageEraTxBody era
  , EraPlutusTxInfo 'PlutusV2 era
  , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  , Inject (BabbageContextError era) (ContextError era)
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxBody era,
 EraPlutusTxInfo 'PlutusV2 era,
 InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era,
 Inject (BabbageContextError era) (ContextError 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
"UTXOW" (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
"MalformedScriptWitnesses" (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 scriptHash :: ScriptHash
scriptHash = Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). Plutus l
malformedPlutus @'PlutusV2)
    TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
    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
-> 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
      [ BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Set ScriptHash -> BabbageUtxowPredFailure era
forall era. Set ScriptHash -> BabbageUtxowPredFailure era
MalformedScriptWitnesses [Item (Set ScriptHash)
ScriptHash
scriptHash]
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MalformedReferenceScripts" (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 script :: Script era
script = PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (Plutus 'PlutusV2 -> PlutusScript era
forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Plutus l -> PlutusScript era
mkSupportedPlutusScript (forall (l :: Language). Plutus l
malformedPlutus @'PlutusV2))
    let scriptHash :: ScriptHash
scriptHash = Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
script
    Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    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))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
              ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
SJust Script era
script
                 ]
    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
      [ BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> BabbageUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Set ScriptHash -> BabbageUtxowPredFailure era
forall era. Set ScriptHash -> BabbageUtxowPredFailure era
MalformedReferenceScripts [Item (Set ScriptHash)
ScriptHash
scriptHash]
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ExtraRedeemers/RedeemerPointerPointsToNothing" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$
    -- There is ExtraRedeemers test for PlutusV1 in Alonzo, thus we start with PlutusV2
    [Language]
-> (Language -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Item [Language]
Language
PlutusV2 .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era] :: [Language]) ((Language -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (Language -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Language
lang -> do
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Testing for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Language -> String
forall a. Show a => a -> String
show Language
lang
      let scriptHash :: ScriptHash
scriptHash = Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> ScriptHash)
-> ScriptHash
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash)
-> (SLanguage l -> Plutus l) -> SLanguage l -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
      TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
      let prp :: PlutusPurpose AsIx era
prp = AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
MintingPurpose (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
2)
      Data era
dt <- ImpM (LedgerSpec era) (Data era)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      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 -> (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
prp (Data era
dt, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)
      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
        [ AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [Item [PlutusPurpose AsIx era]
PlutusPurpose AsIx era
prp]
        , AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
            [CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (BabbageContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (BabbageContextError era -> ContextError era)
-> BabbageContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ PlutusPurpose AsIx era -> BabbageContextError era
forall era. PlutusPurpose AsIx era -> BabbageContextError era
RedeemerPointerPointsToNothing PlutusPurpose AsIx era
prp)]
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"P1 reference scripts must be witnessed" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (KeyHash 'Payment
_, Addr
addr) <- ImpM (LedgerSpec era) (KeyHash 'Payment, Addr)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash 'Payment, Addr)
freshKeyAddr
    let
      timelock :: Script era
timelock = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript @era (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf []
      txOut :: TxOut era
txOut =
        Addr -> Coin -> TxOut era
forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
addr (Coin -> Coin
forall t s. Inject t s => t -> s
inject (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
15_000_000)
          TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
SJust Script era
timelock
    Tx era
tx0 <-
      Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx 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))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton TxOut era
txOut
    let
      txIn :: TxIn
txIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx0) Integer
0
      tx1 :: Tx era
tx1 =
        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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((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
txIn
    Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res <- Tx era
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx1
    Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
      (Tx era)
    -> Bool)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfyExpr` Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
-> Bool
forall a b. Either a b -> Bool
isRight