{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.ImpTest (
  BabbageEraImp,
  babbageFixupTx,
  impBabbageExpectTxSuccess,
  module Test.Cardano.Ledger.Alonzo.ImpTest,
  produceRefScript,
  produceRefScripts,
  produceRefScriptsTx,
  mkTxWithRefInputs,
  submitTxWithRefInputs,
) where

import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Collateral (collOuts)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
import Cardano.Ledger.BaseTypes (Inject, StrictMaybe (..))
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState (
  UTxO (..),
  curPParamsEpochStateL,
  nesEsL,
  utxoL,
 )
import Cardano.Ledger.Tools (ensureMinCoinTxOut, setMinCoinTxOut)
import Cardano.Ledger.TxIn (TxIn, mkTxInPartial)
import Control.Monad (forM, (>=>))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (isNothing)
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import GHC.Stack (HasCallStack)
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Babbage.Era (BabbageEraTest)
import Test.Cardano.Ledger.Babbage.TreeDiff ()
import Test.Cardano.Ledger.Plutus (testingCostModels)

instance ShelleyEraImp BabbageEra where
  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState BabbageEra)
initNewEpochState =
    (NewEpochState (PreviousEra BabbageEra)
 -> NewEpochState (PreviousEra BabbageEra))
-> m (NewEpochState BabbageEra)
forall era g s (m :: * -> *).
(MonadState s m, HasKeyPairs s, HasStatefulGen g m, MonadFail m,
 ShelleyEraImp era, ShelleyEraImp (PreviousEra era),
 TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState
      ((EpochState AlonzoEra -> Identity (EpochState AlonzoEra))
-> NewEpochState AlonzoEra -> Identity (NewEpochState AlonzoEra)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState AlonzoEra -> Identity (EpochState AlonzoEra))
 -> NewEpochState AlonzoEra -> Identity (NewEpochState AlonzoEra))
-> ((CostModels -> Identity CostModels)
    -> EpochState AlonzoEra -> Identity (EpochState AlonzoEra))
-> (CostModels -> Identity CostModels)
-> NewEpochState AlonzoEra
-> Identity (NewEpochState AlonzoEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams AlonzoEra -> Identity (PParams AlonzoEra))
-> EpochState AlonzoEra -> Identity (EpochState AlonzoEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState AlonzoEra) (PParams AlonzoEra)
curPParamsEpochStateL ((PParams AlonzoEra -> Identity (PParams AlonzoEra))
 -> EpochState AlonzoEra -> Identity (EpochState AlonzoEra))
-> ((CostModels -> Identity CostModels)
    -> PParams AlonzoEra -> Identity (PParams AlonzoEra))
-> (CostModels -> Identity CostModels)
-> EpochState AlonzoEra
-> Identity (EpochState AlonzoEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CostModels -> Identity CostModels)
-> PParams AlonzoEra -> Identity (PParams AlonzoEra)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams AlonzoEra) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> NewEpochState AlonzoEra -> Identity (NewEpochState AlonzoEra))
-> CostModels -> NewEpochState AlonzoEra -> NewEpochState AlonzoEra
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV2])
  impSatisfyNativeScript :: forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l BabbageEra
-> NativeScript BabbageEra
-> ImpTestM
     BabbageEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript = Set (KeyHash Witness)
-> TxBody l BabbageEra
-> NativeScript BabbageEra
-> ImpTestM
     BabbageEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
(ShelleyEraImp era, AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack =>
Tx TopTx BabbageEra -> ImpTestM BabbageEra (Tx TopTx BabbageEra)
fixupTx = Tx TopTx BabbageEra -> ImpTestM BabbageEra (Tx TopTx BabbageEra)
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
babbageFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx BabbageEra -> ImpTestM BabbageEra ()
expectTxSuccess = Tx TopTx BabbageEra -> ImpTestM BabbageEra ()
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era ()
impBabbageExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp BabbageEra =>
Version
-> SpecWith (ImpInit (LedgerSpec BabbageEra))
-> SpecWith (ImpInit (LedgerSpec BabbageEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec BabbageEra))
-> SpecWith (ImpInit (LedgerSpec BabbageEra))
forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM BabbageEra (TxCert BabbageEra)
genRegTxCert = Credential Staking -> ImpTestM BabbageEra (TxCert BabbageEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM BabbageEra (TxCert BabbageEra)
genUnRegTxCert = Credential Staking -> ImpTestM BabbageEra (TxCert BabbageEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert BabbageEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert BabbageEra
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
shelleyDelegStakeTxCert

babbageFixupTx ::
  ( HasCallStack
  , AlonzoEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
babbageFixupTx :: forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
babbageFixupTx =
  Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (m :: * -> *) (l :: TxLevel).
(EraTx era, Applicative m) =>
Tx l era -> m (Tx l era)
fixupAuxDataHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
AlonzoEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInput
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addRootTxIn
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupRedeemerIndices
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTxOuts
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupCollateralReturn
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
alonzoFixupFees
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits

fixupCollateralReturn ::
  ( ShelleyEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
fixupCollateralReturn :: forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupCollateralReturn Tx TopTx era
tx = do
  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
  pure $ tx & bodyTxL . collateralReturnTxBodyL %~ fmap (ensureMinCoinTxOut pp)

impBabbageExpectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx TopTx era -> ImpTestM era ()
impBabbageExpectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era ()
impBabbageExpectTxSuccess Tx TopTx era
tx = do
  Tx TopTx era -> ImpTestM era ()
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era ()
impAlonzoExpectTxSuccess Tx TopTx era
tx
  -- Check that the balance of the collateral was returned
  let returns :: [(TxIn, TxOut era)]
returns = Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxIn (TxOut era) -> [(TxIn, TxOut era)])
-> (TxBody TopTx era -> Map TxIn (TxOut era))
-> TxBody TopTx era
-> [(TxIn, TxOut era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO era -> Map TxIn (TxOut era))
-> (TxBody TopTx era -> UTxO era)
-> TxBody TopTx era
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody TopTx era -> UTxO era
forall era. BabbageEraTxBody era => TxBody TopTx era -> UTxO era
collOuts (TxBody TopTx era -> [(TxIn, TxOut era)])
-> TxBody TopTx era -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
  utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  if tx ^. isValidTxL == IsValid True
    then do
      impAnn "Collateral return should not be in UTxO" $
        expectUTxOContent utxo [(txIn, isNothing) | (txIn, _txOut) <- returns]
    else do
      impAnn "Collateral return should be in UTxO" $
        expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- returns]

instance MaryEraImp BabbageEra

instance AlonzoEraImp BabbageEra where
  scriptTestContexts :: Map ScriptHash ScriptTestContext
scriptTestContexts = SLanguage 'PlutusV1 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1 Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV2 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV2
SPlutusV2

produceRefScript ::
  (ShelleyEraImp era, BabbageEraTxOut era) =>
  Script era ->
  ImpTestM era TxIn
produceRefScript :: forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript Script era
script = do
  txIn :| [] <- NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
produceRefScripts (NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn))
-> NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
forall a b. (a -> b) -> a -> b
$ Script era
script Script era -> [Script era] -> NonEmpty (Script era)
forall a. a -> [a] -> NonEmpty a
:| []
  pure txIn

produceRefScripts ::
  (ShelleyEraImp era, BabbageEraTxOut era) =>
  NonEmpty (Script era) ->
  ImpTestM era (NonEmpty TxIn)
produceRefScripts :: forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
produceRefScripts NonEmpty (Script era)
scripts = do
  txId <- Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx (Tx TopTx era -> TxId)
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Script era) -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx TopTx era)
produceRefScriptsTx NonEmpty (Script era)
scripts
  pure $ NE.zipWith (\Script era
_ -> HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
txId) scripts (0 :| [1 ..])

produceRefScriptsTx ::
  (ShelleyEraImp era, BabbageEraTxOut era) =>
  NonEmpty (Script era) ->
  ImpTestM era (Tx TopTx era)
produceRefScriptsTx :: forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (Tx TopTx era)
produceRefScriptsTx NonEmpty (Script era)
scripts = do
  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
  txOuts <- forM scripts $ \Script era
script -> do
    addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    let txOutZero =
          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
    pure $ setMinCoinTxOut pp txOutZero
  let txBody = TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx 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.fromList (NonEmpty (TxOut era) -> [TxOut era]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (TxOut era)
txOuts)
  submitTx (mkBasicTx txBody)

mkTxWithRefInputs ::
  (ShelleyEraImp era, BabbageEraTxBody era) =>
  TxIn ->
  NonEmpty TxIn ->
  Tx TopTx era
mkTxWithRefInputs :: forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> Tx TopTx era
mkTxWithRefInputs TxIn
txIn NonEmpty TxIn
refIns =
  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList (NonEmpty TxIn -> [TxIn]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TxIn
refIns)
      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

submitTxWithRefInputs ::
  (ShelleyEraImp era, BabbageEraTxBody era) =>
  TxIn ->
  NonEmpty TxIn ->
  ImpTestM era (Tx TopTx era)
submitTxWithRefInputs :: forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> ImpTestM era (Tx TopTx era)
submitTxWithRefInputs TxIn
txIn NonEmpty TxIn
refIns = Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTx (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ TxIn -> NonEmpty TxIn -> Tx TopTx era
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
TxIn -> NonEmpty TxIn -> Tx TopTx era
mkTxWithRefInputs TxIn
txIn NonEmpty TxIn
refIns

class
  ( AlonzoEraImp era
  , BabbageEraTest era
  , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
  , Inject (BabbageContextError era) (ContextError era)
  ) =>
  BabbageEraImp era

instance BabbageEraImp BabbageEra