{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Shelley.ImpTest (
  ImpTestM,
  BaseImpM,
  LedgerSpec,
  SomeSTSEvent (..),
  ImpTestState,
  ImpTestEnv (..),
  ImpException (..),
  ShelleyEraImp (..),
  PlutusArgs,
  ScriptTestContext,
  impWitsVKeyNeeded,
  modifyPrevPParams,
  passEpoch,
  passNEpochs,
  passNEpochsChecking,
  passTick,
  freshKeyAddr,
  freshKeyAddr_,
  freshKeyHash,
  freshKeyPair,
  lookupKeyPair,
  freshByronKeyHash,
  freshBootstapAddress,
  lookupByronKeyPair,
  freshSafeHash,
  freshKeyHashVRF,
  submitTx,
  submitTx_,
  submitTxAnn,
  submitTxAnn_,
  submitFailingTx,
  submitFailingTxM,
  trySubmitTx,
  modifyNES,
  getProtVer,
  getsNES,
  getUTxO,
  impAddNativeScript,
  impAnn,
  impAnnDoc,
  impLogToExpr,
  runImpRule,
  tryRunImpRule,
  tryRunImpRuleNoAssertions,
  delegateStake,
  registerRewardAccount,
  registerStakeCredential,
  getRewardAccountFor,
  tryLookupReward,
  lookupReward,
  poolParams,
  registerPool,
  registerPoolWithRewardAccount,
  registerAndRetirePoolToMakeReward,
  getRewardAccountAmount,
  shelleyFixupTx,
  lookupImpRootTxOut,
  sendValueTo,
  sendCoinTo,
  expectUTxOContent,
  expectRegisteredRewardAddress,
  expectNotRegisteredRewardAddress,
  expectTreasury,
  disableTreasuryExpansion,
  updateAddrTxWits,
  addNativeScriptTxWits,
  addRootTxIn,
  fixupTxOuts,
  fixupFees,
  fixupAuxDataHash,
  impGetNativeScript,
  impLookupUTxO,
  defaultInitNewEpochState,
  defaultInitImpTestState,
  impEraStartEpochNo,
  impSetSeed,
  modifyImpInitProtVer,
  modifyImpInitExpectLedgerRuleConformance,

  -- * Logging
  Doc,
  AnsiStyle,
  logDoc,
  logText,
  logString,
  logToExpr,
  logStakeDistr,
  logFeeMismatch,

  -- * Combinators
  withCustomFixup,
  withFixup,
  withNoFixup,
  withPostFixup,
  withPreFixup,
  withCborRoundTripFailures,
  impNESL,
  impGlobalsL,
  impLastTickG,
  impKeyPairsG,
  impNativeScriptsG,
  produceScript,
  advanceToPointOfNoReturn,

  -- * ImpSpec re-exports
  ImpM,
  ImpInit,
) where

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.UTxO as Byron (empty)
import Cardano.Ledger.Address (
  Addr (..),
  BootstrapAddress (..),
  RewardAccount (..),
  bootstrapKeyHash,
 )
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Block (Block)
import Cardano.Ledger.CertState (certDStateL, dsUnifiedL)
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..))
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  asWitness,
  bootstrapWitKeyHash,
  makeBootstrapWitness,
  witVKeyHash,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo)
import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Genesis (
  ShelleyGenesis (..),
  describeValidationErr,
  fromNominalDiffTimeMicro,
  mkShelleyGlobals,
  validateGenesis,
 )
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  NewEpochState (..),
  StashedAVVMAddresses,
  asTreasuryL,
  consumed,
  curPParamsEpochStateL,
  epochStateIncrStakeDistrL,
  epochStateUMapL,
  esAccountStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  prevPParamsEpochStateL,
  produced,
  utxosDonationL,
  utxosUtxoL,
 )
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  LedgerEnv (..),
  ShelleyBbodyState,
  epochFromSlot,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext)
import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn)
import Cardano.Ledger.Tools (
  calcMinFeeTxNativeScriptWits,
  setMinCoinTxOut,
 )
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UMap as UMap
import Cardano.Ledger.UTxO (
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO (..),
  txinLookup,
 )
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader (..), asks)
import Control.Monad.State.Strict (MonadState (..), evalStateT, gets, modify)
import Control.Monad.Trans.Fail.String (errorFail)
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Writer.Class (MonadWriter (..))
import Control.State.Transition (STS (..), TRC (..), applySTSOptsEither)
import Control.State.Transition.Extended (
  ApplySTSOpts (..),
  AssertionPolicy (..),
  SingEP (..),
  ValidationPolicy (..),
 )
import Data.Bifunctor (first)
import Data.Coerce (coerce)
import Data.Data (Proxy (..), type (:~:) (..))
import Data.Default (Default (..))
import Data.Foldable (toList, traverse_)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Data.TreeDiff (ansiWlExpr)
import Data.Type.Equality (TestEquality (..))
import Data.Void
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Lens.Micro (Lens', SimpleGetter, lens, to, (%~), (&), (.~), (<>~), (^.))
import Lens.Micro.Mtl (use, view, (%=), (+=), (.=))
import Numeric.Natural (Natural)
import Prettyprinter (Doc)
import Prettyprinter.Render.Terminal (AnsiStyle)
import qualified System.Random.Stateful as R
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation)
import Test.Cardano.Ledger.Core.KeyPair (
  ByronKeyPair (..),
  KeyPair (..),
  mkAddr,
  mkWitnessesVKey,
 )
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext)
import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..))
import Test.Cardano.Slotting.Numeric ()
import Test.ImpSpec
import Type.Reflection (Typeable, typeOf)
import UnliftIO (evaluateDeep)

type ImpTestM era = ImpM (LedgerSpec era)

-- TODO remove this once we get rid of the CPP directives
{- FOURMOLU_DISABLE -}
type BaseImpM a = -- TODO get rid of the CPP once we have deprecated GHC8
#if __GLASGOW_HASKELL__ < 906
  Expectation
#else
  forall t. ImpM t a
  -- ^ Note the use of higher ranked types here. This prevents the hook from
  -- accessing the state while still permitting the use of more general
  -- functions that return some `ImpM t a` and that don't constrain the
  -- state in any way (e.g. `logString`, `shouldBe` are still fine to use).
#endif
{- FOURMOLU_ENABLE -}

data LedgerSpec era

instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where
  type ImpSpecEnv (LedgerSpec era) = ImpTestEnv era
  type ImpSpecState (LedgerSpec era) = ImpTestState era
  impInitIO :: QCGen -> IO (ImpInit (LedgerSpec era))
impInitIO QCGen
qcGen = do
    IOGenM QCGen
ioGen <- forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
R.newIOGenM QCGen
qcGen
    ImpTestState era
initState <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (ImpTestState era)
initImpTestState IOGenM QCGen
ioGen) (forall a. Monoid a => a
mempty :: ImpPrepState)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      ImpInit
        { impInitEnv :: ImpSpecEnv (LedgerSpec era)
impInitEnv =
            ImpTestEnv
              { iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx
              , iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
True
              , iteExpectLedgerRuleConformance :: Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
iteExpectLedgerRuleConformance = \Globals
_ Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
_ LedgerEnv era
_ LedgerState era
_ Tx era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              }
        , impInitState :: ImpSpecState (LedgerSpec era)
impInitState = ImpTestState era
initState
        }

  -- There is an important step here of running TICK rule. This is necessary as a final
  -- step of `era` initialization, because on the very first TICK of an era the
  -- `futurePParams` are applied and the epoch number is updated to the first epoch
  -- number of the current era
  impPrepAction :: ImpM (LedgerSpec era) ()
impPrepAction = forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick

data SomeSTSEvent era
  = forall (rule :: Symbol).
    ( Typeable (Event (EraRule rule era))
    , Eq (Event (EraRule rule era))
    , ToExpr (Event (EraRule rule era))
    ) =>
    SomeSTSEvent (Event (EraRule rule era))

instance Eq (SomeSTSEvent era) where
  SomeSTSEvent Event (EraRule rule era)
x == :: SomeSTSEvent era -> SomeSTSEvent era -> Bool
== SomeSTSEvent Event (EraRule rule era)
y
    | Just Event (EraRule rule era) :~: Event (EraRule rule era)
Refl <- forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
x) (forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
y) = Event (EraRule rule era)
x forall a. Eq a => a -> a -> Bool
== Event (EraRule rule era)
y
    | Bool
otherwise = Bool
False

instance ToExpr (SomeSTSEvent era) where
  toExpr :: SomeSTSEvent era -> Expr
toExpr (SomeSTSEvent Event (EraRule rule era)
ev) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"SomeSTSEvent" [forall a. ToExpr a => a -> Expr
toExpr Event (EraRule rule era)
ev]

data ImpTestState era = ImpTestState
  { forall era. ImpTestState era -> NewEpochState era
impNES :: !(NewEpochState era)
  , forall era. ImpTestState era -> TxIn
impRootTxIn :: !TxIn
  , forall era.
ImpTestState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness))
  , forall era. ImpTestState era -> Map BootstrapAddress ByronKeyPair
impByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair)
  , forall era. ImpTestState era -> Map ScriptHash (NativeScript era)
impNativeScripts :: !(Map ScriptHash (NativeScript era))
  , forall era. ImpTestState era -> SlotNo
impLastTick :: !SlotNo
  , forall era. ImpTestState era -> Globals
impGlobals :: !Globals
  , forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents :: [SomeSTSEvent era]
  }

-- | This is a preliminary state that is used to prepare the actual `ImpTestState`
data ImpPrepState = ImpPrepState
  { ImpPrepState -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness))
  , ImpPrepState -> Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair)
  }

instance Semigroup ImpPrepState where
  <> :: ImpPrepState -> ImpPrepState -> ImpPrepState
(<>) ImpPrepState
ips1 ImpPrepState
ips2 =
    ImpPrepState
      { impPrepKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs = ImpPrepState -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs ImpPrepState
ips1 forall a. Semigroup a => a -> a -> a
<> ImpPrepState -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs ImpPrepState
ips2
      , impPrepByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs = ImpPrepState -> Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs ImpPrepState
ips1 forall a. Semigroup a => a -> a -> a
<> ImpPrepState -> Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs ImpPrepState
ips2
      }

instance Monoid ImpPrepState where
  mempty :: ImpPrepState
mempty =
    ImpPrepState
      { impPrepKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs = forall a. Monoid a => a
mempty
      , impPrepByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs = forall a. Monoid a => a
mempty
      }

class HasKeyPairs t where
  keyPairsL :: Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness))
  keyPairsByronL :: Lens' t (Map BootstrapAddress ByronKeyPair)

instance Era era => HasKeyPairs (ImpTestState era) where
  keyPairsL :: Lens'
  (ImpTestState era) (Map (KeyHash 'Witness) (KeyPair 'Witness))
keyPairsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ImpTestState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs (\ImpTestState era
x Map (KeyHash 'Witness) (KeyPair 'Witness)
y -> ImpTestState era
x {impKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs = Map (KeyHash 'Witness) (KeyPair 'Witness)
y})
  keyPairsByronL :: Lens' (ImpTestState era) (Map BootstrapAddress ByronKeyPair)
keyPairsByronL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Map BootstrapAddress ByronKeyPair
impByronKeyPairs (\ImpTestState era
x Map BootstrapAddress ByronKeyPair
y -> ImpTestState era
x {impByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impByronKeyPairs = Map BootstrapAddress ByronKeyPair
y})

instance HasKeyPairs ImpPrepState where
  keyPairsL :: Lens' ImpPrepState (Map (KeyHash 'Witness) (KeyPair 'Witness))
keyPairsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpPrepState -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs (\ImpPrepState
x Map (KeyHash 'Witness) (KeyPair 'Witness)
y -> ImpPrepState
x {impPrepKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs = Map (KeyHash 'Witness) (KeyPair 'Witness)
y})
  keyPairsByronL :: Lens' ImpPrepState (Map BootstrapAddress ByronKeyPair)
keyPairsByronL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpPrepState -> Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs (\ImpPrepState
x Map BootstrapAddress ByronKeyPair
y -> ImpPrepState
x {impPrepByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs = Map BootstrapAddress ByronKeyPair
y})

impGlobalsL :: Lens' (ImpTestState era) Globals
impGlobalsL :: forall era. Lens' (ImpTestState era) Globals
impGlobalsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Globals
impGlobals (\ImpTestState era
x Globals
y -> ImpTestState era
x {impGlobals :: Globals
impGlobals = Globals
y})

impNESL :: Lens' (ImpTestState era) (NewEpochState era)
impNESL :: forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> NewEpochState era
impNES (\ImpTestState era
x NewEpochState era
y -> ImpTestState era
x {impNES :: NewEpochState era
impNES = NewEpochState era
y})

impLastTickL :: Lens' (ImpTestState era) SlotNo
impLastTickL :: forall era. Lens' (ImpTestState era) SlotNo
impLastTickL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> SlotNo
impLastTick (\ImpTestState era
x SlotNo
y -> ImpTestState era
x {impLastTick :: SlotNo
impLastTick = SlotNo
y})

impLastTickG :: SimpleGetter (ImpTestState era) SlotNo
impLastTickG :: forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG = forall era. Lens' (ImpTestState era) SlotNo
impLastTickL

impRootTxInL :: Lens' (ImpTestState era) TxIn
impRootTxInL :: forall era. Lens' (ImpTestState era) TxIn
impRootTxInL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> TxIn
impRootTxIn (\ImpTestState era
x TxIn
y -> ImpTestState era
x {impRootTxIn :: TxIn
impRootTxIn = TxIn
y})

impKeyPairsG ::
  SimpleGetter
    (ImpTestState era)
    (Map (KeyHash 'Witness) (KeyPair 'Witness))
impKeyPairsG :: forall era.
SimpleGetter
  (ImpTestState era) (Map (KeyHash 'Witness) (KeyPair 'Witness))
impKeyPairsG = forall s a. (s -> a) -> SimpleGetter s a
to forall era.
ImpTestState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs

impNativeScriptsL :: Lens' (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsL :: forall era.
Lens' (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Map ScriptHash (NativeScript era)
impNativeScripts (\ImpTestState era
x Map ScriptHash (NativeScript era)
y -> ImpTestState era
x {impNativeScripts :: Map ScriptHash (NativeScript era)
impNativeScripts = Map ScriptHash (NativeScript era)
y})

impNativeScriptsG ::
  SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsG :: forall era.
SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsG = forall era.
Lens' (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsL

impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL :: forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents (\ImpTestState era
x [SomeSTSEvent era]
y -> ImpTestState era
x {impEvents :: [SomeSTSEvent era]
impEvents = [SomeSTSEvent era]
y})

class
  ( EraGov era
  , EraUTxO era
  , EraTxOut era
  , EraPParams era
  , ShelleyEraTxCert era
  , ShelleyEraScript era
  , ToExpr (Tx era)
  , NFData (Tx era)
  , ToExpr (TxBody era)
  , ToExpr (TxOut era)
  , ToExpr (Value era)
  , ToExpr (PParams era)
  , ToExpr (PParamsHKD Identity era)
  , ToExpr (PParamsHKD StrictMaybe era)
  , Show (NewEpochState era)
  , ToExpr (NewEpochState era)
  , ToExpr (GovState era)
  , Eq (StashedAVVMAddresses era)
  , Show (StashedAVVMAddresses era)
  , ToExpr (StashedAVVMAddresses era)
  , NFData (StashedAVVMAddresses era)
  , Default (StashedAVVMAddresses era)
  , -- For BBODY rule
    STS (EraRule "BBODY" era)
  , BaseM (EraRule "BBODY" era) ~ ShelleyBase
  , Environment (EraRule "BBODY" era) ~ BbodyEnv era
  , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
  , Signal (EraRule "BBODY" era) ~ Block BHeaderView era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , -- For the LEDGER rule
    STS (EraRule "LEDGER" era)
  , BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , Signal (EraRule "LEDGER" era) ~ Tx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Show (PredicateFailure (EraRule "LEDGER" era))
  , ToExpr (PredicateFailure (EraRule "LEDGER" era))
  , NFData (PredicateFailure (EraRule "LEDGER" era))
  , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
  , DecCBOR (PredicateFailure (EraRule "LEDGER" era))
  , EraRuleEvent "LEDGER" era ~ Event (EraRule "LEDGER" era)
  , Eq (EraRuleEvent "LEDGER" era)
  , ToExpr (EraRuleEvent "LEDGER" era)
  , NFData (EraRuleEvent "LEDGER" era)
  , Typeable (EraRuleEvent "LEDGER" era)
  , -- For the TICK rule
    STS (EraRule "TICK" era)
  , BaseM (EraRule "TICK" era) ~ ShelleyBase
  , Signal (EraRule "TICK" era) ~ SlotNo
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Environment (EraRule "TICK" era) ~ ()
  , NFData (PredicateFailure (EraRule "TICK" era))
  , EraRuleEvent "TICK" era ~ Event (EraRule "TICK" era)
  , Eq (EraRuleEvent "TICK" era)
  , ToExpr (EraRuleEvent "TICK" era)
  , NFData (EraRuleEvent "TICK" era)
  , Typeable (EraRuleEvent "TICK" era)
  , ToExpr (PredicateFailure (EraRule "UTXOW" era))
  ) =>
  ShelleyEraImp era
  where
  initGenesis ::
    (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
    m (Genesis era)
  default initGenesis ::
    (Monad m, Genesis era ~ NoGenesis era) =>
    m (Genesis era)
  initGenesis = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall era. NoGenesis era
NoGenesis

  initNewEpochState ::
    (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
    m (NewEpochState era)
  default initNewEpochState ::
    ( HasKeyPairs s
    , MonadState s m
    , HasStatefulGen g m
    , MonadFail m
    , ShelleyEraImp (PreviousEra era)
    , TranslateEra era NewEpochState
    , TranslationError era NewEpochState ~ Void
    , TranslationContext era ~ Genesis era
    ) =>
    m (NewEpochState era)
  initNewEpochState = 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 forall a. a -> a
id

  initImpTestState ::
    ( HasKeyPairs s
    , MonadState s m
    , HasStatefulGen g m
    , MonadFail m
    ) =>
    m (ImpTestState era)
  initImpTestState = forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
initNewEpochState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era s g (m :: * -> *).
(EraGov era, EraTxOut era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState

  -- | Try to find a sufficient number of KeyPairs that would satisfy a native script.
  -- Whenever script can't be satisfied, Nothing is returned
  impSatisfyNativeScript ::
    -- | Set of Witnesses that have already been satisfied
    Set.Set (KeyHash 'Witness) ->
    -- | The transaction body that the script will be applied to
    TxBody era ->
    NativeScript era ->
    ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))

  -- | This modifer should change not only the current PParams, but also the future
  -- PParams. If the future PParams are not updated, then they will overwrite the
  -- mofication of the current PParams at the next epoch.
  modifyPParams ::
    (PParams era -> PParams era) ->
    ImpTestM era ()
  modifyPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

  fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era)

defaultInitNewEpochState ::
  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 :: 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 NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)
modifyPrevEraNewEpochState = do
  Genesis era
genesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @era
  NewEpochState (PreviousEra era)
nes <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
initNewEpochState @(PreviousEra era)
  let majProtVer :: Version
majProtVer = forall era. Era era => Version
eraProtVerLow @era
      -- We need to set the protocol version for the current era and for debugging
      -- purposes we start the era at the epoch number that matches the protocol version
      -- times a 100. However, because this is the NewEpochState from the previous era, we
      -- initialize it with futurePParams preset and epoch number that is one behind the
      -- beginning of this era. Note that all imp tests will start with a TICK, in order
      -- for theses changes to be applied.
      prevEraNewEpochState :: NewEpochState (PreviousEra era)
prevEraNewEpochState =
        NewEpochState (PreviousEra era)
nes
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer Version
majProtVer Natural
0
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) EpochNo
nesELL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Enum a => a -> a
pred (forall era. Era era => EpochNo
impEraStartEpochNo @era)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra' Genesis era
genesis forall a b. (a -> b) -> a -> b
$ NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)
modifyPrevEraNewEpochState NewEpochState (PreviousEra era)
prevEraNewEpochState

-- | For debugging purposes we start the era at the epoch number that matches the starting
-- protocol version for the era times a 100
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo = Word64 -> EpochNo
EpochNo (forall i. Integral i => Version -> i
getVersion Version
majProtVer forall a. Num a => a -> a -> a
* Word64
100)
  where
    majProtVer :: Version
majProtVer = forall era. Era era => Version
eraProtVerLow @era

defaultInitImpTestState ::
  forall era s g m.
  ( EraGov era
  , EraTxOut era
  , HasKeyPairs s
  , MonadState s m
  , HasStatefulGen g m
  , MonadFail m
  ) =>
  NewEpochState era ->
  m (ImpTestState era)
defaultInitImpTestState :: forall era s g (m :: * -> *).
(EraGov era, EraTxOut era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
NewEpochState era -> m (ImpTestState era)
defaultInitImpTestState NewEpochState era
nes = do
  ShelleyGenesis
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
  KeyHash 'Payment
rootKeyHash <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  let
    rootAddr :: Addr
    rootAddr :: Addr
rootAddr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Payment
rootKeyHash) StakeReference
StakeRefNull
    rootTxOut :: TxOut era
    rootTxOut :: TxOut era
rootTxOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
rootAddr forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject Coin
rootCoin
    rootCoin :: Coin
rootCoin = Integer -> Coin
Coin (forall a. Integral a => a -> Integer
toInteger (ShelleyGenesis -> Word64
sgMaxLovelaceSupply ShelleyGenesis
shelleyGenesis))
    rootTxIn :: TxIn
    rootTxIn :: TxIn
rootTxIn = TxId -> TxIx -> TxIn
TxIn (Int -> TxId
mkTxId Int
0) forall a. Bounded a => a
minBound
    nesWithRoot :: NewEpochState era
nesWithRoot =
      NewEpochState era
nes forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (forall k a. k -> a -> Map k a
Map.singleton TxIn
rootTxIn TxOut era
rootTxOut)
  s
prepState <- forall s (m :: * -> *). MonadState s m => m s
get
  let epochInfoE :: EpochInfo (Either Text)
epochInfoE =
        forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
          (ShelleyGenesis -> EpochSize
sgEpochLength ShelleyGenesis
shelleyGenesis)
          (NominalDiffTime -> SlotLength
mkSlotLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NominalDiffTimeMicro
sgSlotLength ShelleyGenesis
shelleyGenesis)
      globals :: Globals
globals = ShelleyGenesis -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals ShelleyGenesis
shelleyGenesis EpochInfo (Either Text)
epochInfoE
      epochNo :: EpochNo
epochNo = NewEpochState era
nesWithRoot forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
      slotNo :: SlotNo
slotNo = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    ImpTestState
      { impNES :: NewEpochState era
impNES = NewEpochState era
nesWithRoot
      , impRootTxIn :: TxIn
impRootTxIn = TxIn
rootTxIn
      , impKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs = s
prepState forall s a. s -> Getting a s a -> a
^. forall t.
HasKeyPairs t =>
Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness))
keyPairsL
      , impByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impByronKeyPairs = s
prepState forall s a. s -> Getting a s a -> a
^. forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
keyPairsByronL
      , impNativeScripts :: Map ScriptHash (NativeScript era)
impNativeScripts = forall a. Monoid a => a
mempty
      , impLastTick :: SlotNo
impLastTick = SlotNo
slotNo
      , impGlobals :: Globals
impGlobals = Globals
globals
      , impEvents :: [SomeSTSEvent era]
impEvents = forall a. Monoid a => a
mempty
      }

modifyImpInitProtVer ::
  forall era.
  ShelleyEraImp era =>
  Version ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer :: forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer Version
ver =
  forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitState :: ImpSpecState (LedgerSpec era)
impInitState =
          forall t. ImpInit t -> ImpSpecState t
impInitState ImpInit (LedgerSpec era)
impInit
            forall a b. a -> (a -> b) -> b
& forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer Version
ver Natural
0
      }

modifyImpInitExpectLedgerRuleConformance ::
  forall era.
  ( Globals ->
    Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
    LedgerEnv era ->
    LedgerState era ->
    Tx era ->
    BaseImpM ()
  ) ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitExpectLedgerRuleConformance :: forall era.
(Globals
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
 -> LedgerEnv era
 -> LedgerState era
 -> Tx era
 -> BaseImpM ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitExpectLedgerRuleConformance Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
f =
  forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitEnv :: ImpSpecEnv (LedgerSpec era)
impInitEnv =
          forall t. ImpInit t -> ImpSpecEnv t
impInitEnv ImpInit (LedgerSpec era)
impInit
            forall a b. a -> (a -> b) -> b
& forall era.
Lens'
  (ImpTestEnv era)
  (Globals
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> LedgerEnv era
   -> LedgerState era
   -> Tx era
   -> BaseImpM ())
iteExpectLedgerRuleConformanceL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
f
      }

impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv :: forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
nes = do
  SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  EpochNo
epochNo <- forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase forall a b. (a -> b) -> a -> b
$ SlotNo -> Reader Globals EpochNo
epochFromSlot SlotNo
slotNo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LedgerEnv
      { ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
slotNo
      , ledgerEpochNo :: Maybe EpochNo
ledgerEpochNo = forall a. a -> Maybe a
Just EpochNo
epochNo
      , ledgerPp :: PParams era
ledgerPp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      , ledgerIx :: TxIx
ledgerIx = Word64 -> TxIx
TxIx Word64
0
      , ledgerAccount :: AccountState
ledgerAccount = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL
      , ledgerMempool :: Bool
ledgerMempool = Bool
False
      }

-- | Modify the previous PParams in the current state with the given function. For current
-- and future PParams, use `modifyPParams`
modifyPrevPParams ::
  EraGov era =>
  (PParams era -> PParams era) ->
  ImpTestM era ()
modifyPrevPParams :: forall era.
EraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPrevPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

-- | Logs the current stake distribution
logStakeDistr :: HasCallStack => ImpTestM era ()
logStakeDistr :: forall era. HasCallStack => ImpTestM era ()
logStakeDistr = do
  Map (Credential 'Staking) (CompactForm Coin)
stakeDistr <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (EpochState era) (Map (Credential 'Staking) (CompactForm Coin))
epochStateIncrStakeDistrL
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Stake distr: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Map (Credential 'Staking) (CompactForm Coin)
stakeDistr

mkTxId :: Int -> TxId
mkTxId :: Int -> TxId
mkTxId Int
idx = SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
mkDummySafeHash Int
idx)

instance
  ShelleyEraScript ShelleyEra =>
  ShelleyEraImp ShelleyEra
  where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (Genesis ShelleyEra)
initGenesis = do
    let
      gen :: ShelleyGenesis
gen =
        ShelleyGenesis
          { sgSystemStart :: UTCTime
sgSystemStart = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t.
(MonadFail m, ISO8601 t) =>
ConstructorName -> m t
iso8601ParseM ConstructorName
"2017-09-23T21:44:51Z"
          , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123456 -- Mainnet value: 764824073
          , sgNetworkId :: Network
sgNetworkId = Network
Testnet
          , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
20 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100 -- Mainnet value: 5 %! 100
          , sgSecurityParam :: Word64
sgSecurityParam = Word64
108 -- Mainnet value: 2160
          , sgEpochLength :: EpochSize
sgEpochLength = EpochSize
4320 -- Mainnet value: 432000
          , sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod = Word64
129600
          , sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions = Word64
62
          , sgSlotLength :: NominalDiffTimeMicro
sgSlotLength = NominalDiffTimeMicro
1
          , sgUpdateQuorum :: Word64
sgUpdateQuorum = Word64
5
          , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
45_000_000_000_000_000
          , sgProtocolParams :: PParams ShelleyEra
sgProtocolParams =
              forall era. EraPParams era => PParams era
emptyPParams
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155_381
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
65536
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
16384
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
500_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
18
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word16
ppNOptL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16
150
                forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1000)
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Nonce
NeutralNonce
                forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
340_000_000
          , -- TODO: Add a top level definition and add private keys to ImpState:
            sgGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs = forall a. Monoid a => a
mempty
          , sgInitialFunds :: ListMap Addr Coin
sgInitialFunds = forall a. Monoid a => a
mempty
          , sgStaking :: ShelleyGenesisStaking
sgStaking = forall a. Monoid a => a
mempty
          }
    case ShelleyGenesis -> Either [ValidationErr] ()
validateGenesis ShelleyGenesis
gen of
      Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis
gen
      Left [ValidationErr]
errs -> forall (m :: * -> *) a. MonadFail m => ConstructorName -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConstructorName
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ValidationErr -> Text
describeValidationErr [ValidationErr]
errs

  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState ShelleyEra)
initNewEpochState = do
    ShelleyGenesis
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
    let transContext :: FromByronTranslationContext
transContext = ShelleyGenesis -> FromByronTranslationContext
toFromByronTranslationContext ShelleyGenesis
shelleyGenesis
        startEpochNo :: EpochNo
startEpochNo = forall era. Era era => EpochNo
impEraStartEpochNo @ShelleyEra
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext
-> EpochNo -> UTxO -> NewEpochState ShelleyEra
translateToShelleyLedgerStateFromUtxo FromByronTranslationContext
transContext EpochNo
startEpochNo UTxO
Byron.empty

  impSatisfyNativeScript :: Set (KeyHash 'Witness)
-> TxBody ShelleyEra
-> NativeScript ShelleyEra
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript Set (KeyHash 'Witness)
providedVKeyHashes TxBody ShelleyEra
_txBody NativeScript ShelleyEra
script = do
    Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era.
ImpTestState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs
    let
      satisfyMOf :: Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript ShelleyEra)
Empty
        | Int
m forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise = forall a. Maybe a
Nothing
      satisfyMOf Int
m (NativeScript ShelleyEra
x :<| StrictSeq (NativeScript ShelleyEra)
xs) =
        case NativeScript ShelleyEra
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript NativeScript ShelleyEra
x of
          Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
Nothing -> Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript ShelleyEra)
xs
          Just Map (KeyHash 'Witness) (KeyPair 'Witness)
kps -> do
            Map (KeyHash 'Witness) (KeyPair 'Witness)
kps' <- Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf (Int
m forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript ShelleyEra)
xs
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Witness) (KeyPair 'Witness)
kps forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'Witness) (KeyPair 'Witness)
kps'
      satisfyScript :: NativeScript ShelleyEra
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript = \case
        RequireSignature KeyHash 'Witness
keyHash
          | KeyHash 'Witness
keyHash forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness)
providedVKeyHashes -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
          | Bool
otherwise -> do
              KeyPair 'Witness
keyPair <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Witness
keyHash Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton KeyHash 'Witness
keyHash KeyPair 'Witness
keyPair
        RequireAllOf StrictSeq (NativeScript ShelleyEra)
ss -> Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript ShelleyEra)
ss) StrictSeq (NativeScript ShelleyEra)
ss
        RequireAnyOf StrictSeq (NativeScript ShelleyEra)
ss -> Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
1 StrictSeq (NativeScript ShelleyEra)
ss
        RequireMOf Int
m StrictSeq (NativeScript ShelleyEra)
ss -> Int
-> StrictSeq (NativeScript ShelleyEra)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript ShelleyEra)
ss
        NativeScript ShelleyEra
_ -> forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Impossible: All NativeScripts should have been accounted for"

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NativeScript ShelleyEra
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript NativeScript ShelleyEra
script

  fixupTx :: HasCallStack =>
Tx ShelleyEra -> ImpTestM ShelleyEra (Tx ShelleyEra)
fixupTx = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx

-- | Figure out all the Byron Addresses that need witnesses as well as all of the
-- KeyHashes for Shelley Key witnesses that are required.
impWitsVKeyNeeded ::
  EraUTxO era =>
  TxBody era ->
  ImpTestM
    era
    ( Set.Set BootstrapAddress -- Byron Based Addresses
    , Set.Set (KeyHash 'Witness) -- Shelley Based KeyHashes
    )
impWitsVKeyNeeded :: forall era.
EraUTxO era =>
TxBody era
-> ImpTestM era (Set BootstrapAddress, Set (KeyHash 'Witness))
impWitsVKeyNeeded TxBody era
txBody = do
  LedgerState era
ls <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL)
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let toBootAddr :: TxIn -> Maybe BootstrapAddress
toBootAddr TxIn
txIn = do
        TxOut era
txOut <- forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txIn UTxO era
utxo
        TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF
      bootAddrs :: Set BootstrapAddress
bootAddrs = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxIn -> Maybe BootstrapAddress
toBootAddr forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
spendableInputsTxBodyF)
      bootKeyHashes :: Set (KeyHash 'Witness)
bootKeyHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash) Set BootstrapAddress
bootAddrs
      allKeyHashes :: Set (KeyHash 'Witness)
allKeyHashes =
        forall era.
EraUTxO era =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getWitsVKeyNeeded (LedgerState era
ls forall s a. s -> Getting a s a -> a
^. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL) (LedgerState era
ls forall s a. s -> Getting a s a -> a
^. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL) TxBody era
txBody
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set BootstrapAddress
bootAddrs, Set (KeyHash 'Witness)
allKeyHashes forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness)
bootKeyHashes)

data ImpTestEnv era = ImpTestEnv
  { forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup :: Tx era -> ImpTestM era (Tx era)
  , forall era.
ImpTestEnv era
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
iteExpectLedgerRuleConformance ::
      Globals ->
      Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
      LedgerEnv era ->
      LedgerState era ->
      Tx era ->
      BaseImpM ()
  , forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures :: !Bool
  -- ^ Expect failures in CBOR round trip serialization tests for predicate failures
  }

iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL :: forall era.
Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup (\ImpTestEnv era
x Tx era -> ImpTestM era (Tx era)
y -> ImpTestEnv era
x {iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = Tx era -> ImpTestM era (Tx era)
y})

iteExpectLedgerRuleConformanceL ::
  forall era.
  Lens'
    (ImpTestEnv era)
    ( Globals ->
      Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
      LedgerEnv era ->
      LedgerState era ->
      Tx era ->
      BaseImpM ()
    )
iteExpectLedgerRuleConformanceL :: forall era.
Lens'
  (ImpTestEnv era)
  (Globals
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> LedgerEnv era
   -> LedgerState era
   -> Tx era
   -> BaseImpM ())
iteExpectLedgerRuleConformanceL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
ImpTestEnv era
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
iteExpectLedgerRuleConformance (\ImpTestEnv era
x Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
y -> ImpTestEnv era
x {iteExpectLedgerRuleConformance :: Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
iteExpectLedgerRuleConformance = Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
y})

iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL :: forall era. Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures (\ImpTestEnv era
x Bool
y -> ImpTestEnv era
x {iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
y})

instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
  writer :: forall a. (a, [SomeSTSEvent era]) -> ImpTestM era a
writer (a
x, [SomeSTSEvent era]
evs) = (forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> [SomeSTSEvent era]
evs)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
x
  listen :: forall a. ImpTestM era a -> ImpTestM era (a, [SomeSTSEvent era])
listen ImpTestM era a
act = do
    [SomeSTSEvent era]
oldEvs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL
    forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Monoid a => a
mempty
    a
res <- ImpTestM era a
act
    [SomeSTSEvent era]
newEvs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL
    forall era. Lens' (ImpTestState era) [SomeSTSEvent era]
impEventsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [SomeSTSEvent era]
oldEvs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
res, [SomeSTSEvent era]
newEvs)
  pass :: forall a.
ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
-> ImpTestM era a
pass ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act = do
    ((a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f), [SomeSTSEvent era]
evs) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act
    forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f [SomeSTSEvent era]
evs)

runShelleyBase :: ShelleyBase a -> ImpTestM era a
runShelleyBase :: forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase ShelleyBase a
act = do
  Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ShelleyBase a
act Globals
globals

getRewardAccountAmount :: RewardAccount -> ImpTestM era Coin
getRewardAccountAmount :: forall era. RewardAccount -> ImpTestM era Coin
getRewardAccountAmount RewardAccount
rewardAccount = do
  UMap
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) UMap
epochStateUMapL
  let cred :: Credential 'Staking
cred = RewardAccount -> Credential 'Staking
raCredential RewardAccount
rewardAccount
  case forall k v. k -> UView k v -> Maybe v
UMap.lookup Credential 'Staking
cred (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
umap) of
    Maybe RDPair
Nothing -> forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
ConstructorName -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ ConstructorName
"Expected a reward account: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show Credential 'Staking
cred
    Just RDPair {CompactForm Coin
rdReward :: RDPair -> CompactForm Coin
rdReward :: CompactForm Coin
rdReward} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
rdReward

lookupImpRootTxOut :: ImpTestM era (TxIn, TxOut era)
lookupImpRootTxOut :: forall era. ImpTestM era (TxIn, TxOut era)
lookupImpRootTxOut = do
  ImpTestState {TxIn
impRootTxIn :: TxIn
impRootTxIn :: forall era. ImpTestState era -> TxIn
impRootTxIn} <- forall s (m :: * -> *). MonadState s m => m s
get
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
impRootTxIn UTxO era
utxo of
    Maybe (TxOut era)
Nothing -> forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Root txId no longer points to an existing unspent output"
    Just TxOut era
rootTxOut -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
impRootTxIn, TxOut era
rootTxOut)

impAddNativeScript ::
  forall era.
  EraScript era =>
  NativeScript era ->
  ImpTestM era ScriptHash
impAddNativeScript :: forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript NativeScript era
nativeScript = do
  let script :: Script era
script = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
nativeScript
      scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script
  forall era.
Lens' (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash NativeScript era
nativeScript
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

impNativeScriptsRequired ::
  EraUTxO era =>
  Tx era ->
  ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired :: forall era.
EraUTxO era =>
Tx era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx era
tx = do
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  ImpTestState {Map ScriptHash (NativeScript era)
impNativeScripts :: Map ScriptHash (NativeScript era)
impNativeScripts :: forall era. ImpTestState era -> Map ScriptHash (NativeScript era)
impNativeScripts} <- forall s (m :: * -> *). MonadState s m => m s
get
  let needed :: ScriptsNeeded era
needed = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
      hashesNeeded :: Set ScriptHash
hashesNeeded = forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded ScriptsNeeded era
needed
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map ScriptHash (NativeScript era)
impNativeScripts forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set ScriptHash
hashesNeeded

-- | Modifies transaction by adding necessary scripts
addNativeScriptTxWits ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
addNativeScriptTxWits :: forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"addNativeScriptTxWits" forall a b. (a -> b) -> a -> b
$ do
  Map ScriptHash (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx era
tx
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let ScriptsProvided Map ScriptHash (Script era)
provided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
      scriptsToAdd :: Map ScriptHash (NativeScript era)
scriptsToAdd = Map ScriptHash (NativeScript era)
scriptsRequired forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ Map ScriptHash (Script era)
provided
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraScript era => NativeScript era -> Script era
fromNativeScript Map ScriptHash (NativeScript era)
scriptsToAdd

-- | Adds @TxWits@ that will satisfy all of the required key witnesses
updateAddrTxWits ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
updateAddrTxWits :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"updateAddrTxWits" forall a b. (a -> b) -> a -> b
$ do
  let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody
  (Set BootstrapAddress
bootAddrs, Set (KeyHash 'Witness)
witsVKeyNeeded) <- forall era.
EraUTxO era =>
TxBody era
-> ImpTestM era (Set BootstrapAddress, Set (KeyHash 'Witness))
impWitsVKeyNeeded TxBody era
txBody
  -- Shelley Based Addr Witnesses
  let curAddrWitHashes :: Set (KeyHash 'Witness)
curAddrWitHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL
  [KeyPair 'Witness]
extraKeyPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
lookupKeyPair forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (Set (KeyHash 'Witness)
witsVKeyNeeded forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness)
curAddrWitHashes)
  let extraAddrVKeyWits :: Set (WitVKey 'Witness)
extraAddrVKeyWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
txBodyHash [KeyPair 'Witness]
extraKeyPairs
      addrWitHashes :: Set (KeyHash 'Witness)
addrWitHashes = Set (KeyHash 'Witness)
curAddrWitHashes forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash Set (WitVKey 'Witness)
extraAddrVKeyWits
  -- Shelley Based Native Script Witnesses
  Map ScriptHash (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx era
tx
  [Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))]
nativeScriptsKeyPairs <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript Set (KeyHash 'Witness)
addrWitHashes TxBody era
txBody) (forall k a. Map k a -> [a]
Map.elems Map ScriptHash (NativeScript era)
scriptsRequired)
  let extraNativeScriptVKeyWits :: Set (WitVKey 'Witness)
extraNativeScriptVKeyWits =
        forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
txBodyHash forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems (forall a. Monoid a => [a] -> a
mconcat (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))]
nativeScriptsKeyPairs))
  -- Byron Based Witessed
  let curBootAddrWitHashes :: Set (KeyHash 'Witness)
curBootAddrWitHashes = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map BootstrapWitness -> KeyHash 'Witness
bootstrapWitKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL
      bootAddrWitsNeeded :: [BootstrapAddress]
bootAddrWitsNeeded =
        [ BootstrapAddress
bootAddr
        | BootstrapAddress
bootAddr <- forall a. Set a -> [a]
Set.toList Set BootstrapAddress
bootAddrs
        , Bool -> Bool
not (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash BootstrapAddress
bootAddr) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness)
curBootAddrWitHashes)
        ]
  [BootstrapWitness]
extraBootAddrWits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [BootstrapAddress]
bootAddrWitsNeeded forall a b. (a -> b) -> a -> b
$ \bootAddr :: BootstrapAddress
bootAddr@(BootstrapAddress Address
byronAddr) -> do
    ByronKeyPair VerificationKey
_ SigningKey
signingKey <- forall s (m :: * -> *).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
BootstrapAddress -> m ByronKeyPair
lookupByronKeyPair BootstrapAddress
bootAddr
    let attrs :: Attributes AddrAttributes
attrs = Address -> Attributes AddrAttributes
Byron.addrAttributes Address
byronAddr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Hash HASH EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness
makeBootstrapWitness (forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentTxBody
txBodyHash) SigningKey
signingKey Attributes AddrAttributes
attrs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness)
extraAddrVKeyWits forall a. Semigroup a => a -> a -> a
<> Set (WitVKey 'Witness)
extraNativeScriptVKeyWits
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall a. Ord a => [a] -> Set a
Set.fromList [BootstrapWitness]
extraBootAddrWits

-- | This fixup step ensures that there are enough funds in the transaction.
addRootTxIn ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
addRootTxIn :: forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"addRootTxIn" forall a b. (a -> b) -> a -> b
$ do
  TxIn
rootTxIn <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ImpTestM era (TxIn, TxOut era)
lookupImpRootTxOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert TxIn
rootTxIn

impNativeScriptKeyPairs ::
  ShelleyEraImp era =>
  Tx era ->
  ImpTestM
    era
    (Map (KeyHash 'Witness) (KeyPair 'Witness))
impNativeScriptKeyPairs :: forall era.
ShelleyEraImp era =>
Tx era -> ImpTestM era (Map (KeyHash 'Witness) (KeyPair 'Witness))
impNativeScriptKeyPairs Tx era
tx = do
  Map ScriptHash (NativeScript era)
scriptsRequired <- forall era.
EraUTxO era =>
Tx era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx era
tx
  let nativeScripts :: [NativeScript era]
nativeScripts = forall k a. Map k a -> [a]
Map.elems Map ScriptHash (NativeScript era)
scriptsRequired
      curAddrWits :: Set (KeyHash 'Witness)
curAddrWits = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL
  [Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))]
keyPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript Set (KeyHash 'Witness)
curAddrWits forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL) [NativeScript era]
nativeScripts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))]
keyPairs

fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)
fixupTxOuts :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts Tx era
tx = do
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let
    txOuts :: StrictSeq (TxOut era)
txOuts = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
  StrictSeq (TxOut era)
fixedUpTxOuts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM StrictSeq (TxOut era)
txOuts forall a b. (a -> b) -> a -> b
$ \TxOut era
txOut -> do
    if TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall a. Eq a => a -> a -> Bool
== forall t. Val t => t
zero
      then do
        let txOut' :: TxOut era
txOut' = forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
txOut
        forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle
"Fixed up the amount in the TxOut to " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (TxOut era
txOut' forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut'
      else do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
fixedUpTxOuts

fixupFees ::
  (ShelleyEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupFees :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees Tx era
txOriginal = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"fixupFees" forall a b. (a -> b) -> a -> b
$ do
  -- Fee will be overwritten later on, unless it wasn't set to zero to begin with:
  let tx :: Tx era
tx = Tx era
txOriginal forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t. Val t => t
zero
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  CertState era
certState <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL
  (KeyHash 'Payment
_, KeyPair 'Payment
kpSpending) <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair
  (KeyHash 'Staking
_, KeyPair 'Staking
kpStaking) <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair
  Map (KeyHash 'Witness) (KeyPair 'Witness)
nativeScriptKeyPairs <- forall era.
ShelleyEraImp era =>
Tx era -> ImpTestM era (Map (KeyHash 'Witness) (KeyPair 'Witness))
impNativeScriptKeyPairs Tx era
tx
  let
    nativeScriptKeyWits :: Set (KeyHash 'Witness)
nativeScriptKeyWits = forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Witness) (KeyPair 'Witness)
nativeScriptKeyPairs
    consumedValue :: Value era
consumedValue = forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
    producedValue :: Value era
producedValue = forall era.
EraUTxO era =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
    ensureNonNegativeCoin :: p -> ImpM t p
ensureNonNegativeCoin p
v
      | forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
pointwise forall a. Ord a => a -> a -> Bool
(<=) forall t. Val t => t
zero p
v = forall (f :: * -> *) a. Applicative f => a -> f a
pure p
v
      | Bool
otherwise = do
          forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Failed to validate coin: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr p
v
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall t. Val t => t
zero
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating changeBeforeFee"
  Coin
changeBeforeFee <- forall {p} {t}. (Val p, ToExpr p) => p -> ImpM t p
ensureNonNegativeCoin forall a b. (a -> b) -> a -> b
$ forall t. Val t => t -> Coin
coin Value era
consumedValue forall t. Val t => t -> t -> t
<-> forall t. Val t => t -> Coin
coin Value era
producedValue
  forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Coin
changeBeforeFee
  let
    changeBeforeFeeTxOut :: TxOut era
changeBeforeFeeTxOut =
      forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
        ((KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
kpSpending, KeyPair 'Staking
kpStaking))
        (forall t s. Inject t s => t -> s
inject Coin
changeBeforeFee)
    txNoWits :: Tx era
txNoWits = Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeBeforeFeeTxOut)
    outsBeforeFee :: StrictSeq (TxOut era)
outsBeforeFee = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
    suppliedFee :: Coin
suppliedFee = Tx era
txOriginal forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
    fee0 :: Coin
fee0
      | Coin
suppliedFee forall a. Eq a => a -> a -> Bool
== forall t. Val t => t
zero = forall era.
EraUTxO era =>
UTxO era -> PParams era -> Tx era -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxNativeScriptWits UTxO era
utxo PParams era
pp Tx era
txNoWits Set (KeyHash 'Witness)
nativeScriptKeyWits
      | Bool
otherwise = Coin
suppliedFee
    fee :: Coin
fee = Rational -> Coin
rationalToCoinViaCeiling forall a b. (a -> b) -> a -> b
$ Coin -> Rational
coinToRational Coin
fee0 forall a. Num a => a -> a -> a
* (Integer
11 forall a. Integral a => a -> a -> Ratio a
% Integer
10)
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating change"
  Coin
change <- forall {p} {t}. (Val p, ToExpr p) => p -> ImpM t p
ensureNonNegativeCoin forall a b. (a -> b) -> a -> b
$ TxOut era
changeBeforeFeeTxOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall t. Val t => t -> t -> t
<-> Coin
fee
  forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Coin
change
  let
    changeTxOut :: TxOut era
changeTxOut = TxOut era
changeBeforeFeeTxOut forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
change
    -- If the remainder is sufficently big we add it to outputs, otherwise we add the
    -- extraneous coin to the fee and discard the remainder TxOut
    txWithFee :: Tx era
txWithFee
      | Coin
change forall a. Ord a => a -> a -> Bool
>= forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
changeTxOut =
          Tx era
txNoWits
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (StrictSeq (TxOut era)
outsBeforeFee forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeTxOut)
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
      | Bool
otherwise =
          Tx era
txNoWits
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
outsBeforeFee
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
fee forall a. Semigroup a => a -> a -> a
<> Coin
change)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
txWithFee

-- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not.
fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era)
fixupAuxDataHash :: forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash Tx era
tx
  | StrictMaybe TxAuxDataHash
SNothing <- Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL
  , SJust TxAuxData era
auxData <- Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxAuxData era
auxData)))
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

shelleyFixupTx ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
shelleyFixupTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx =
  forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (\Tx era
tx -> forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx era -> ImpTestM era ()
logFeeMismatch Tx era
tx forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Tx era
tx)

logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era ()
logFeeMismatch :: forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx era -> ImpTestM era ()
logFeeMismatch Tx era
tx = do
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
  let Coin Integer
feeUsed = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
      Coin Integer
feeMin = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
feeUsed forall a. Eq a => a -> a -> Bool
/= Integer
feeMin) forall a b. (a -> b) -> a -> b
$ do
    forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle
"Estimated fee " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeUsed forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" while required fee is " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeMin

submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era ()
submitTx_ :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx

submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era)
submitTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a, b) -> a
fst

-- TODO remove this once we get rid of the CPP directives
{- FOURMOLU_DISABLE -}
trySubmitTx ::
  forall era.
  ( ShelleyEraImp era
  , HasCallStack
  ) =>
  Tx era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx = do
  Tx era
txFixed <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (a -> b) -> a -> b
$ Tx era
tx)
  forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txFixed
  NewEpochState era
st <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES
  LedgerEnv era
lEnv <- forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
st
  ImpTestState {TxIn
impRootTxIn :: TxIn
impRootTxIn :: forall era. ImpTestState era -> TxIn
impRootTxIn} <- forall s (m :: * -> *). MonadState s m => m s
get
  Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res <- forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @"LEDGER" LedgerEnv era
lEnv (NewEpochState era
st forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL) Tx era
txFixed
  Bool
roundTripCheck <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures
  Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL

  -- Check for conformance
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era.
ImpTestEnv era
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
iteExpectLedgerRuleConformance
  -- TODO get rid of the CPP once we have deprecated GHC8
#if __GLASGOW_HASKELL__ < 906
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
f -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> BaseImpM ()
f Globals
globals Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res LedgerEnv era
lEnv (NewEpochState era
st forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL) Tx era
txFixed)
#else
    >>= (\f -> f globals res lEnv (st ^. nesEsL . esLStateL) txFixed)
#endif

  case Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res of
    Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures -> do
      -- Verify that produced predicate failures are ready for the node-to-client protocol
      if Bool
roundTripCheck
        then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures forall a b. (a -> b) -> a -> b
$ forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> BaseImpM ()
roundTripEraExpectation @era
        else
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> BaseImpM ()
roundTripCborRangeFailureExpectation
              (forall era. Era era => Version
eraProtVerLow @era)
              (forall era. Era era => Version
eraProtVerHigh @era)
              NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
txFixed)
    Right (LedgerState era
st', [Event (EraRule "LEDGER" era)]
events) -> do
      let txId :: TxId
txId = SafeHash EraIndependentTxBody -> TxId
TxId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated forall a b. (a -> b) -> a -> b
$ Tx era
txFixed forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
          outsSize :: Int
outsSize = forall a. StrictSeq a -> Int
SSeq.length forall a b. (a -> b) -> a -> b
$ Tx era
txFixed forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
          rootIndex :: Int
rootIndex
            | Int
outsSize forall a. Ord a => a -> a -> Bool
> Int
0 = Int
outsSize forall a. Num a => a -> a -> a
- Int
1
            | Bool
otherwise = forall a. HasCallStack => ConstructorName -> a
error (ConstructorName
"Expected at least 1 output after submitting tx: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show TxId
txId)
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"LEDGER") [Event (EraRule "LEDGER" era)]
events
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ LedgerState era
st'
      UTxO Map TxIn (TxOut era)
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
      -- This TxIn is in the utxo, and thus can be the new root, only if the transaction
      -- was phase2-valid.  Otherwise, no utxo with this id would have been created, and
      -- so we need to set the new root to what it was before the submission.
      let assumedNewRoot :: TxIn
assumedNewRoot = TxId -> TxIx -> TxIn
TxIn TxId
txId (HasCallStack => Integer -> TxIx
mkTxIxPartial (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rootIndex))
      let newRoot :: TxIn
newRoot
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
assumedNewRoot Map TxIn (TxOut era)
utxo = TxIn
assumedNewRoot
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
impRootTxIn Map TxIn (TxOut era)
utxo = TxIn
impRootTxIn
            | Bool
otherwise = forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Root not found in UTxO"
      forall era. Lens' (ImpTestState era) TxIn
impRootTxInL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TxIn
newRoot
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Tx era
txFixed
{- FOURMOLU_ENABLE -}

-- | Submit a transaction that is expected to be rejected with the given predicate failures.
-- The inputs and outputs are automatically balanced.
submitFailingTx ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx = forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Submit a transaction that is expected to be rejected, and compute
-- the expected predicate failures from the fixed-up tx using the supplied action.
-- The inputs and outputs are automatically balanced.
submitFailingTxM ::
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Tx era ->
  (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) ->
  ImpTestM era ()
submitFailingTxM :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures = do
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
fixedUpTx) <- forall b a (m :: * -> *).
(HasCallStack, ToExpr b, NFData a, MonadIO m) =>
Either a b -> m a
expectLeftDeepExpr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures <- Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures Tx era
fixedUpTx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures

tryRunImpRule ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRule :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule = forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' @rule AssertionPolicy
AssertionsAll

tryRunImpRuleNoAssertions ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRuleNoAssertions :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRuleNoAssertions = forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' @rule AssertionPolicy
AssertionsOff

tryRunImpRule' ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  AssertionPolicy ->
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRule' :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' AssertionPolicy
assertionPolicy Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let trc :: TRC (EraRule rule era)
trc = forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule rule era)
stsEnv, State (EraRule rule era)
stsState, Signal (EraRule rule era)
stsSignal)
  let
    stsOpts :: ApplySTSOpts 'EventPolicyReturn
stsOpts =
      ApplySTSOpts
        { asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
        , asoEvents :: SingEP 'EventPolicyReturn
asoEvents = SingEP 'EventPolicyReturn
EPReturn
        , asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
assertionPolicy
        }
  forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase (forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
        (NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule rule era) ApplySTSOpts 'EventPolicyReturn
stsOpts TRC (EraRule rule era)
trc)

runImpRule ::
  forall rule era.
  ( HasCallStack
  , KnownSymbol rule
  , STS (EraRule rule era)
  , BaseM (EraRule rule era) ~ ShelleyBase
  , NFData (State (EraRule rule era))
  , NFData (Event (EraRule rule era))
  , ToExpr (Event (EraRule rule era))
  , Eq (Event (EraRule rule era))
  , Typeable (Event (EraRule rule era))
  ) =>
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM era (State (EraRule rule era))
runImpRule :: forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let ruleName :: ConstructorName
ruleName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> ConstructorName
symbolVal (forall {k} (t :: k). Proxy t
Proxy @rule)
  (State (EraRule rule era)
res, [Event (EraRule rule era)]
ev) <-
    forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @rule Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left NonEmpty (PredicateFailure (EraRule rule era))
fs ->
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
ConstructorName -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
          [ConstructorName] -> ConstructorName
unlines forall a b. (a -> b) -> a -> b
$
            (ConstructorName
"Failed to run " forall a. Semigroup a => a -> a -> a
<> ConstructorName
ruleName forall a. Semigroup a => a -> a -> a
<> ConstructorName
":") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> ConstructorName
show (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PredicateFailure (EraRule rule era))
fs)
      Right (State (EraRule rule era), [Event (EraRule rule era)])
res -> forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (State (EraRule rule era), [Event (EraRule rule era)])
res
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @rule) [Event (EraRule rule era)]
ev
  forall (f :: * -> *) a. Applicative f => a -> f a
pure State (EraRule rule era)
res

-- | Runs the TICK rule once
passTick ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era ()
passTick :: forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick = do
  SlotNo
impLastTick <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  NewEpochState era
curNES <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a. a -> a
id
  NewEpochState era
nes <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"TICK" () NewEpochState era
curNES SlotNo
impLastTick
  forall era. Lens' (ImpTestState era) SlotNo
impLastTickL forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= SlotNo
1
  forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= NewEpochState era
nes

-- | Runs the TICK rule until the next epoch is reached
passEpoch ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  ImpTestM era ()
passEpoch :: forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch = do
  let
    tickUntilNewEpoch :: EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo = do
      forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick @era
      EpochNo
newEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EpochNo
newEpochNo forall a. Ord a => a -> a -> Bool
> EpochNo
curEpochNo) forall a b. (a -> b) -> a -> b
$ EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo
  NewEpochState era
preNES <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES
  let startEpoch :: EpochNo
startEpoch = NewEpochState era
preNES forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Entering " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (forall a. Enum a => a -> a
succ EpochNo
startEpoch)
  EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
startEpoch
  forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> NewEpochState era
impNES forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(EraTxOut era, EraGov era, HasCallStack) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
preNES

epochBoundaryCheck ::
  (EraTxOut era, EraGov era, HasCallStack) =>
  NewEpochState era ->
  NewEpochState era ->
  ImpTestM era ()
epochBoundaryCheck :: forall era.
(EraTxOut era, EraGov era, HasCallStack) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
preNES NewEpochState era
postNES = do
  forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking ADA preservation at the epoch boundary" forall a b. (a -> b) -> a -> b
$ do
    let preSum :: Coin
preSum = forall {era}.
(EraTxOut era, EraGov era) =>
NewEpochState era -> Coin
tot NewEpochState era
preNES
        postSum :: Coin
postSum = forall {era}.
(EraTxOut era, EraGov era) =>
NewEpochState era -> Coin
tot NewEpochState era
postNES
    forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Coin
preSum Coin
postSum
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Coin
preSum forall a. Eq a => a -> a -> Bool
== Coin
postSum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$
      ConstructorName
"Total ADA in the epoch state is not preserved\n\tpost - pre = "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show (Coin
postSum forall t. Val t => t -> t -> t
<-> Coin
preSum)
  where
    tot :: NewEpochState era -> Coin
tot NewEpochState era
nes =
      forall t. Val t => t -> t -> t
(<+>)
        (AdaPots -> Coin
sumAdaPots (forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL)))
        (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) Coin
utxosDonationL)

-- | Runs the TICK rule until the `n` epochs are passed
passNEpochs ::
  forall era.
  ShelleyEraImp era =>
  Natural ->
  ImpTestM era ()
passNEpochs :: forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
n =
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

-- | Runs the TICK rule until the `n` epochs are passed, running the `checks`
-- each time.
passNEpochsChecking ::
  forall era.
  ShelleyEraImp era =>
  Natural ->
  ImpTestM era () ->
  ImpTestM era ()
passNEpochsChecking :: forall era.
ShelleyEraImp era =>
Natural -> ImpTestM era () -> ImpTestM era ()
passNEpochsChecking Natural
n ImpTestM era ()
checks =
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) forall a b. (a -> b) -> a -> b
$ forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ImpTestM era ()
checks

-- | Adds a ToExpr to the log, which is only shown if the test fails
logToExpr :: (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr :: forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr = forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc AnsiStyle
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr

-- | Adds the result of an action to the log, which is only shown if the test fails
impLogToExpr :: (HasCallStack, ToExpr a) => ImpTestM era a -> ImpTestM era a
impLogToExpr :: forall a era.
(HasCallStack, ToExpr a) =>
ImpTestM era a -> ImpTestM era a
impLogToExpr ImpTestM era a
action = do
  a
e <- ImpTestM era a
action
  forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc AnsiStyle
ansiWlExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExpr a => a -> Expr
toExpr forall a b. (a -> b) -> a -> b
$ a
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
e

-- | Creates a fresh @SafeHash@
freshSafeHash :: ImpTestM era (SafeHash a)
freshSafeHash :: forall era a. ImpTestM era (SafeHash a)
freshSafeHash = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary

freshKeyHashVRF ::
  ImpTestM era (VRFVerKeyHash (r :: KeyRoleVRF))
freshKeyHashVRF :: forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary

-- | Adds a key pair to the keyhash lookup map
addKeyPair ::
  (HasKeyPairs s, MonadState s m) =>
  KeyPair r ->
  m (KeyHash r)
addKeyPair :: forall s (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s, MonadState s m) =>
KeyPair r -> m (KeyHash r)
addKeyPair keyPair :: KeyPair r
keyPair@(KeyPair VKey r
vk SignKeyDSIGN DSIGN
_) = do
  let keyHash :: KeyHash r
keyHash = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey r
vk
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t.
HasKeyPairs t =>
Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness))
keyPairsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash r
keyHash) (coerce :: forall a b. Coercible a b => a -> b
coerce KeyPair r
keyPair)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash r
keyHash

-- | Looks up the `KeyPair` corresponding to the `KeyHash`. The `KeyHash` must be
-- created with `freshKeyHash` for this to work.
lookupKeyPair ::
  (HasCallStack, HasKeyPairs s, MonadState s m) =>
  KeyHash r ->
  m (KeyPair r)
lookupKeyPair :: forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
lookupKeyPair KeyHash r
keyHash = do
  Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall t.
HasKeyPairs t =>
Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness))
keyPairsL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash r
keyHash) Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs of
    Just KeyPair 'Witness
keyPair -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce KeyPair 'Witness
keyPair
    Maybe (KeyPair 'Witness)
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show KeyHash r
keyHash
          forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `KeyPair` in the
-- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for
-- generation or `lookupKeyPair` to look up the `KeyPair` corresponding to the `KeyHash`
freshKeyHash ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r)
freshKeyHash :: forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair

-- | Generate a random `KeyPair` and add it to the known keys in the Imp state
freshKeyPair ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r, KeyPair r)
freshKeyPair :: forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair = do
  KeyPair r
keyPair <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  KeyHash r
keyHash <- forall s (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s, MonadState s m) =>
KeyPair r -> m (KeyHash r)
addKeyPair KeyPair r
keyPair
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash r
keyHash, KeyPair r
keyPair)

-- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair`
-- to the known keys in the Imp state.
freshKeyAddr_ ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => m Addr
freshKeyAddr_ :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshKeyAddr_ = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, Addr)
freshKeyAddr

-- | Generate a random `Addr` that uses a `KeyHash`, add the corresponding `KeyPair`
-- to the known keys in the Imp state, and return the `KeyHash` as well as the `Addr`.
freshKeyAddr ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r, Addr)
freshKeyAddr :: forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, Addr)
freshKeyAddr = do
  KeyHash 'Payment
keyHash <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Payment
keyHash, Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Payment
keyHash) StakeReference
StakeRefNull)

-- | Looks up the keypair corresponding to the `BootstrapAddress`. The `BootstrapAddress`
-- must be created with `freshBootstrapAddess` for this to work.
lookupByronKeyPair ::
  (HasCallStack, HasKeyPairs s, MonadState s m) =>
  BootstrapAddress ->
  m ByronKeyPair
lookupByronKeyPair :: forall s (m :: * -> *).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
BootstrapAddress -> m ByronKeyPair
lookupByronKeyPair BootstrapAddress
bootAddr = do
  Map BootstrapAddress ByronKeyPair
keyPairs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
keyPairsByronL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BootstrapAddress
bootAddr Map BootstrapAddress ByronKeyPair
keyPairs of
    Just ByronKeyPair
keyPair -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByronKeyPair
keyPair
    Maybe ByronKeyPair
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ConstructorName
show BootstrapAddress
bootAddr
          forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshByronKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `ByronKeyPair` in the
-- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for
-- generation or `lookupByronKeyPair` to look up the `ByronKeyPair` corresponding to the `KeyHash`
freshByronKeyHash ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r)
freshByronKeyHash :: forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshByronKeyHash = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstapAddress

freshBootstapAddress ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m BootstrapAddress
freshBootstapAddress :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstapAddress = do
  keyPair :: ByronKeyPair
keyPair@(ByronKeyPair VerificationKey
verificationKey SigningKey
_) <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Bool
hasPayload <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Maybe HDAddressPayload
payload <-
    if Bool
hasPayload
      then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HDAddressPayload
Byron.HDAddressPayload forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteString
uniformByteStringM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Int
0, Int
63))
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  let asd :: AddrSpendingData
asd = VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
verificationKey
      attrs :: AddrAttributes
attrs = Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes Maybe HDAddressPayload
payload (Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
0)
      bootAddr :: BootstrapAddress
bootAddr = Address -> BootstrapAddress
BootstrapAddress forall a b. (a -> b) -> a -> b
$ AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress AddrSpendingData
asd AddrAttributes
attrs
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
keyPairsByronL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BootstrapAddress
bootAddr ByronKeyPair
keyPair
  forall (f :: * -> *) a. Applicative f => a -> f a
pure BootstrapAddress
bootAddr

sendCoinTo ::
  (ShelleyEraImp era, HasCallStack) =>
  Addr ->
  Coin ->
  ImpTestM era TxIn
sendCoinTo :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr = forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Value era -> ImpTestM era TxIn
sendValueTo Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject

sendValueTo ::
  (ShelleyEraImp era, HasCallStack) =>
  Addr ->
  Value era ->
  ImpTestM era TxIn
sendValueTo :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Value era -> ImpTestM era TxIn
sendValueTo Addr
addr Value era
amount = do
  Tx era
tx <-
    forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn
      (ConstructorName
"Giving " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Value era
amount forall a. Semigroup a => a -> a -> a
<> ConstructorName
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Addr
addr)
      forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
        forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
amount)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
tx

-- | Modify the current new epoch state with a function
modifyNES :: (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES :: forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES = (forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%=)

-- | Get a value from the current new epoch state using the lens
getsNES :: SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES :: forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES SimpleGetter (NewEpochState era) a
l = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleGetter (NewEpochState era) a
l

getUTxO :: ImpTestM era (UTxO era)
getUTxO :: forall era. ImpTestM era (UTxO era)
getUTxO = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL

getProtVer :: EraGov era => ImpTestM era ProtVer
getProtVer :: forall era. EraGov era => ImpTestM era ProtVer
getProtVer = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL

submitTxAnn ::
  (HasCallStack, ShelleyEraImp era) =>
  String ->
  Tx era ->
  ImpTestM era (Tx era)
submitTxAnn :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn ConstructorName
msg Tx era
tx = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
msg (forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr)

submitTxAnn_ ::
  (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era ()
submitTxAnn_ :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
msg = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn ConstructorName
msg

getRewardAccountFor ::
  Credential 'Staking ->
  ImpTestM era RewardAccount
getRewardAccountFor :: forall era. Credential 'Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential 'Staking
stakingC = do
  Network
networkId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall era. Lens' (ImpTestState era) Globals
impGlobalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
networkId Credential 'Staking
stakingC

registerStakeCredential ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Credential 'Staking ->
  ImpTestM era RewardAccount
registerStakeCredential :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred = do
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ (ConstructorName
"Register Reward Account: " forall a. Semigroup a => a -> a -> a
<> Text -> ConstructorName
T.unpack (forall (kr :: KeyRole). Credential kr -> Text
credToText Credential 'Staking
cred)) forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList [forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert @era Credential 'Staking
cred]
  Network
networkId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall era. Lens' (ImpTestState era) Globals
impGlobalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
networkId Credential 'Staking
cred

delegateStake ::
  ShelleyEraImp era =>
  Credential 'Staking ->
  KeyHash 'StakePool ->
  ImpTestM era ()
delegateStake :: forall era.
ShelleyEraImp era =>
Credential 'Staking -> KeyHash 'StakePool -> ImpTestM era ()
delegateStake Credential 'Staking
cred KeyHash 'StakePool
poolKH = do
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ (ConstructorName
"Delegate Staking Credential: " forall a. Semigroup a => a -> a -> a
<> Text -> ConstructorName
T.unpack (forall (kr :: KeyRole). Credential kr -> Text
credToText Credential 'Staking
cred)) forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert Credential 'Staking
cred KeyHash 'StakePool
poolKH]

registerRewardAccount ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era RewardAccount
registerRewardAccount :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount = do
  KeyHash 'Staking
khDelegator <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
khDelegator)

tryLookupReward :: Credential 'Staking -> ImpTestM era (Maybe Coin)
tryLookupReward :: forall era. Credential 'Staking -> ImpTestM era (Maybe Coin)
tryLookupReward Credential 'Staking
stakingCredential = do
  UMap
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) UMap
epochStateUMapL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
rdReward forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. k -> UView k v -> Maybe v
UMap.lookup Credential 'Staking
stakingCredential (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
umap)

lookupReward :: HasCallStack => Credential 'Staking -> ImpTestM era Coin
lookupReward :: forall era.
HasCallStack =>
Credential 'Staking -> ImpTestM era Coin
lookupReward Credential 'Staking
stakingCredential = do
  Maybe Coin
mbyRwd <- forall era. Credential 'Staking -> ImpTestM era (Maybe Coin)
tryLookupReward Credential 'Staking
stakingCredential
  case Maybe Coin
mbyRwd of
    Just Coin
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
c
    Maybe Coin
Nothing ->
      forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Staking Credential is not found in the state: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show Credential 'Staking
stakingCredential
          forall a. Semigroup a => a -> a -> a
<> ConstructorName
"\nMake sure you have the reward account registered with `registerRewardAccount` "
          forall a. Semigroup a => a -> a -> a
<> ConstructorName
"or by some other means."

poolParams ::
  ShelleyEraImp era =>
  KeyHash 'StakePool ->
  RewardAccount ->
  ImpTestM era PoolParams
poolParams :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
poolParams KeyHash 'StakePool
khPool RewardAccount
rewardAccount = do
  VRFVerKeyHash 'StakePoolVRF
vrfHash <- forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let minCost :: Coin
minCost = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL
  Coin
poolCostExtra <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
100_000_000)
  Coin
pledge <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
100_000_000)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    PoolParams
      { ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf = VRFVerKeyHash 'StakePoolVRF
vrfHash
      , ppRewardAccount :: RewardAccount
ppRewardAccount = RewardAccount
rewardAccount
      , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. Monoid a => a
mempty
      , ppPledge :: Coin
ppPledge = Coin
pledge
      , ppOwners :: Set (KeyHash 'Staking)
ppOwners = forall a. Monoid a => a
mempty
      , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata = forall a. StrictMaybe a
SNothing
      , ppMargin :: UnitInterval
ppMargin = forall a. Default a => a
def
      , ppId :: KeyHash 'StakePool
ppId = KeyHash 'StakePool
khPool
      , ppCost :: Coin
ppCost = Coin
minCost forall a. Semigroup a => a -> a -> a
<> Coin
poolCostExtra
      }

registerPool ::
  ShelleyEraImp era =>
  KeyHash 'StakePool ->
  ImpTestM era ()
registerPool :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> ImpTestM era ()
registerPool KeyHash 'StakePool
khPool = forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool
khPool

registerPoolWithRewardAccount ::
  ShelleyEraImp era =>
  KeyHash 'StakePool ->
  RewardAccount ->
  ImpTestM era ()
registerPoolWithRewardAccount :: forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool
khPool RewardAccount
rewardAccount = do
  PoolParams
pps <- forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
poolParams KeyHash 'StakePool
khPool RewardAccount
rewardAccount
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
"Registering a new stake pool" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
pps)

registerAndRetirePoolToMakeReward ::
  ShelleyEraImp era =>
  Credential 'Staking ->
  ImpTestM era ()
registerAndRetirePoolToMakeReward :: forall era.
ShelleyEraImp era =>
Credential 'Staking -> ImpTestM era ()
registerAndRetirePoolToMakeReward Credential 'Staking
stakingCred = do
  KeyHash 'StakePool
poolId <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool
poolId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era. Credential 'Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential 'Staking
stakingCred
  forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  let poolLifetime :: Word32
poolLifetime = Word32
2
      poolExpiry :: EpochNo
poolExpiry = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
poolLifetime
  forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ ConstructorName
"Retiring the temporary stake pool" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool
poolId EpochNo
poolExpiry)
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
poolLifetime

withCborRoundTripFailures :: ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures :: forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall era. Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False

-- | Compose given function with the configured fixup
withCustomFixup ::
  ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withCustomFixup :: forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall era.
Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
iteFixupL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f

-- | Replace all fixup with the given function
withFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (forall a b. a -> b -> a
const Tx era -> ImpTestM era (Tx era)
f)

-- | Performs the action without running the fix-up function on any transactions
withNoFixup :: ImpTestM era a -> ImpTestM era a
withNoFixup :: forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup = forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Apply given fixup function before the configured fixup
withPreFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPreFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPreFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era)
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>)

-- | Apply given fixup function after the configured fixup
withPostFixup ::
  (Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPostFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup Tx era -> ImpTestM era (Tx era)
f = forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpTestM era (Tx era)
f)

expectUTxOContent ::
  (HasCallStack, ToExpr (TxOut era)) =>
  UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent :: forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn, Maybe (TxOut era) -> Bool
test) -> do
  let result :: Maybe (TxOut era)
result = TxIn
txIn forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TxOut era) -> Bool
test Maybe (TxOut era)
result) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$
      ConstructorName
"UTxO content failed predicate:\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> ConstructorName
ansiExprString TxIn
txIn forall a. Semigroup a => a -> a -> a
<> ConstructorName
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> ConstructorName
ansiExprString Maybe (TxOut era)
result

expectRegisteredRewardAddress :: RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress :: forall era. RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking
cred) = do
  UMap
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL
  forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking
cred (UMap -> Map (Credential 'Staking) RDPair
rdPairMap UMap
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True

expectNotRegisteredRewardAddress :: RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress :: forall era. RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking
cred) = do
  UMap
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL
  forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking
cred (UMap -> Map (Credential 'Staking) RDPair
rdPairMap UMap
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
False

expectTreasury :: HasCallStack => Coin -> ImpTestM era ()
expectTreasury :: forall era. HasCallStack => Coin -> ImpTestM era ()
expectTreasury Coin
c =
  forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking treasury amount" forall a b. (a -> b) -> a -> b
$ do
    Coin
treasuryAmt <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' AccountState Coin
asTreasuryL
    Coin
c forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
treasuryAmt

-- Ensure no fees reach the treasury since that complicates withdrawal checks
disableTreasuryExpansion :: ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion :: forall era. ShelleyEraImp era => ImpM (LedgerSpec era) ()
disableTreasuryExpansion = forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
0 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)

impGetNativeScript :: ScriptHash -> ImpTestM era (Maybe (NativeScript era))
impGetNativeScript :: forall era. ScriptHash -> ImpTestM era (Maybe (NativeScript era))
impGetNativeScript ScriptHash
sh = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
sh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> Map ScriptHash (NativeScript era)
impNativeScripts

impLookupUTxO :: ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impLookupUTxO :: forall era. ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impLookupUTxO TxIn
txIn = forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Looking up TxOut" forall a b. (a -> b) -> a -> b
$ do
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txIn UTxO era
utxo of
    Just TxOut era
txOut -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut
    Maybe (TxOut era)
Nothing -> forall a. HasCallStack => ConstructorName -> a
error forall a b. (a -> b) -> a -> b
$ ConstructorName
"Failed to get TxOut for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show TxIn
txIn

produceScript ::
  (ShelleyEraImp era, HasCallStack) =>
  ScriptHash ->
  ImpTestM era TxIn
produceScript :: forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash = do
  let addr :: Addr
addr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) StakeReference
StakeRefNull
  let tx :: Tx era
tx =
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr forall a. Monoid a => a
mempty)
  forall t. HasCallStack => ConstructorName -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ ConstructorName
"Produced script: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ConstructorName
show ScriptHash
scriptHash
  forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx

advanceToPointOfNoReturn :: ImpTestM era ()
advanceToPointOfNoReturn :: forall era. ImpTestM era ()
advanceToPointOfNoReturn = do
  SlotNo
impLastTick <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> SlotNo
impLastTick
  (EpochNo
_, SlotNo
slotOfNoReturn, EpochNo
_) <- forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase forall a b. (a -> b) -> a -> b
$ HasCallStack => SlotNo -> ShelleyBase (EpochNo, SlotNo, EpochNo)
getTheSlotOfNoReturn SlotNo
impLastTick
  forall era. Lens' (ImpTestState era) SlotNo
impLastTickL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SlotNo
slotOfNoReturn