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

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

import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Collateral (collOuts)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.BaseTypes (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 GHC.Stack (HasCallStack)
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Babbage.Era ()
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 [Language
PlutusV2])
  impSatisfyNativeScript :: Set (KeyHash 'Witness)
-> TxBody BabbageEra
-> NativeScript BabbageEra
-> ImpTestM
     BabbageEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = Set (KeyHash 'Witness)
-> TxBody BabbageEra
-> NativeScript BabbageEra
-> ImpTestM
     BabbageEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
(AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack =>
Tx BabbageEra -> ImpTestM BabbageEra (Tx BabbageEra)
fixupTx = Tx BabbageEra -> ImpTestM BabbageEra (Tx BabbageEra)
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
babbageFixupTx
  expectTxSuccess :: HasCallStack => Tx BabbageEra -> ImpTestM BabbageEra ()
expectTxSuccess = Tx BabbageEra -> ImpTestM BabbageEra ()
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess

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

fixupCollateralReturn ::
  ( ShelleyEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupCollateralReturn :: forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
fixupCollateralReturn 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
  Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictMaybe (TxOut era) -> StrictMaybe (TxOut era))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TxOut era -> TxOut era)
-> StrictMaybe (TxOut era) -> StrictMaybe (TxOut era)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp)

impBabbageExpectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess Tx era
tx = do
  Tx era -> ImpTestM era ()
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
impAlonzoExpectTxSuccess Tx 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 era -> Map TxIn (TxOut era))
-> TxBody era
-> [(TxIn, TxOut era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO era -> Map TxIn (TxOut era))
-> (TxBody era -> UTxO era) -> TxBody era -> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> UTxO era
forall era. BabbageEraTxBody era => TxBody era -> UTxO era
collOuts (TxBody era -> [(TxIn, TxOut era)])
-> TxBody era -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
  UTxO era
utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  if Tx era
tx Tx era -> Getting IsValid (Tx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True
    then do
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral return should not be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, Maybe (TxOut era) -> Bool
forall a. Maybe a -> Bool
isNothing) | (TxIn
txIn, TxOut era
_txOut) <- [(TxIn, TxOut era)]
returns]
    else do
      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral return should be in UTxO" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, (Maybe (TxOut era) -> Maybe (TxOut era) -> Bool
forall a. Eq a => a -> a -> Bool
== TxOut era -> Maybe (TxOut era)
forall a. a -> Maybe a
Just TxOut era
txOut)) | (TxIn
txIn, TxOut era
txOut) <- [(TxIn, TxOut era)]
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
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
:| []
  TxIn -> ImpTestM era TxIn
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIn
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
  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
  NonEmpty (TxOut era)
txOuts <- NonEmpty (Script era)
-> (Script era -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Script era)
scripts ((Script era -> ImpM (LedgerSpec era) (TxOut era))
 -> ImpM (LedgerSpec era) (NonEmpty (TxOut era)))
-> (Script era -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (NonEmpty (TxOut era))
forall a b. (a -> b) -> a -> b
$ \Script era
script -> do
    Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    let txOutZero :: TxOut era
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
    TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
txOutZero
  let txBody :: TxBody era
txBody = TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (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)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody 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)
  TxId
txId <- Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx (Tx era -> TxId)
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody)
  NonEmpty TxIn -> ImpTestM era (NonEmpty TxIn)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty TxIn -> ImpTestM era (NonEmpty TxIn))
-> NonEmpty TxIn -> ImpTestM era (NonEmpty TxIn)
forall a b. (a -> b) -> a -> b
$ (Script era -> Integer -> TxIn)
-> NonEmpty (Script era) -> NonEmpty Integer -> NonEmpty TxIn
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Script era
_ -> HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
txId) NonEmpty (Script era)
scripts (Integer
0 Integer -> [Integer] -> NonEmpty Integer
forall a. a -> [a] -> NonEmpty a
:| [Integer
1 ..])