{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# 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 ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Shelley.ImpTest (
  ImpTestM,
  LedgerSpec,
  EraSpecificSpec (..),
  SomeSTSEvent (..),
  ImpTestState,
  ImpTestEnv (..),
  ImpException (..),
  ShelleyEraImp (..),
  PlutusArgs,
  ScriptTestContext,
  impWitsVKeyNeeded,
  modifyPrevPParams,
  passEpoch,
  passNEpochs,
  passNEpochsChecking,
  passTick,
  freshKeyAddr,
  freshKeyAddr_,
  freshKeyHash,
  freshKeyPair,
  getKeyPair,
  freshByronKeyHash,
  freshBootstapAddress,
  getByronKeyPair,
  freshSafeHash,
  freshKeyHashVRF,
  submitTx,
  submitTx_,
  submitTxAnn,
  submitTxAnn_,
  submitFailingTx,
  submitFailingTxM,
  trySubmitTx,
  impShelleyExpectTxSuccess,
  modifyNES,
  getProtVer,
  getsNES,
  getUTxO,
  impAddNativeScript,
  impAnn,
  impAnnDoc,
  impLogToExpr,
  runImpRule,
  tryRunImpRule,
  tryRunImpRuleNoAssertions,
  delegateStake,
  registerRewardAccount,
  registerStakeCredential,
  expectNotDelegatedToAnyPool,
  expectNotDelegatedToPool,
  expectStakeCredRegistered,
  expectStakeCredNotRegistered,
  expectDelegatedToPool,
  getRewardAccountFor,
  freshPoolParams,
  registerPool,
  registerPoolWithRewardAccount,
  registerAndRetirePoolToMakeReward,
  getBalance,
  lookupBalance,
  getAccountBalance,
  lookupAccountBalance,
  shelleyFixupTx,
  getImpRootTxOut,
  sendValueTo,
  sendValueTo_,
  sendCoinTo,
  sendCoinTo_,
  expectUTxOContent,
  expectRegisteredRewardAddress,
  expectNotRegisteredRewardAddress,
  expectTreasury,
  disableTreasuryExpansion,
  updateAddrTxWits,
  addNativeScriptTxWits,
  addRootTxIn,
  fixupTxOuts,
  fixupFees,
  fixupAuxDataHash,
  impLookupNativeScript,
  impGetUTxO,
  defaultInitNewEpochState,
  defaultInitImpTestState,
  impEraStartEpochNo,
  impSetSeed,
  shelleyModifyImpInitProtVer,
  modifyImpInitPostSubmitTxHook,
  disableImpInitPostSubmitTxHook,
  modifyImpInitPostEpochBoundaryHook,
  disableImpInitPostEpochBoundaryHook,
  disableInConformanceIt,
  minorFollow,
  majorFollow,
  cantFollow,
  whenMajorVersion,
  whenMajorVersionAtLeast,
  whenMajorVersionAtMost,
  unlessMajorVersion,
  getsPParams,
  withEachEraVersion,
  impSatisfyMNativeScripts,
  impSatisfySignature,
  shelleyGenRegTxCert,
  shelleyGenUnRegTxCert,
  shelleyDelegStakeTxCert,

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

  -- * Combinators
  withCustomFixup,
  withFixup,
  withNoFixup,
  withPostFixup,
  withPreFixup,
  impNESL,
  impGlobalsL,
  impCurSlotNoG,
  impKeyPairsG,
  impNativeScriptsG,
  produceScript,
  advanceToPointOfNoReturn,
  simulateThenRestore,

  -- * 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.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (..), credToText)
import Cardano.Ledger.Genesis
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  asWitness,
  bootstrapWitKeyHash,
  makeBootstrapWitness,
  witVKeyHash,
 )
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 (..),
  curPParamsEpochStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  prevPParamsEpochStateL,
  produced,
  utxosDonationL,
 )
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  LedgerEnv (..),
  ShelleyBbodyState,
  ShelleyDelegPredFailure,
  ShelleyPoolPredFailure,
  ShelleyUtxoPredFailure,
  ShelleyUtxowPredFailure,
  epochFromSlot,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext)
import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn)
import Cardano.Ledger.Tools (
  calcMinFeeTxNativeScriptWits,
  ensureMinCoinTxOut,
 )
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
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, get, gets, modify, put)
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, isNothing, mapMaybe)
import Data.Ratio (denominator, numerator, (%))
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 (KnownNat, KnownSymbol, Symbol, symbolVal, type (<=))
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.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation)
import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), mkStakeRef, 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.Era
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)

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
    ioGen <- QCGen -> IO (IOGenM QCGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
R.newIOGenM QCGen
qcGen
    initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: ImpPrepState)
    pure $
      ImpInit
        { impInitEnv =
            ImpTestEnv
              { iteFixup = fixupTx
              , itePostSubmitTxHook = \Globals
_ TRC (EraRule "LEDGER" era)
_ Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
_ -> () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              , itePostEpochBoundaryHook = \Globals
_ TRC (EraRule "NEWEPOCH" era)
_ State (EraRule "NEWEPOCH" era)
_ -> () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              }
        , impInitState = 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 = ImpM (LedgerSpec era) ()
forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick

class EraTest era => EraSpecificSpec era where
  eraSpecificSpec :: SpecWith (ImpInit (LedgerSpec era))
  eraSpecificSpec = () -> SpecWith (ImpInit (LedgerSpec era))
forall a. a -> SpecM (ImpInit (LedgerSpec era)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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 <- TypeRep (Event (EraRule rule era))
-> TypeRep (Event (EraRule rule era))
-> Maybe (Event (EraRule rule era) :~: Event (EraRule rule era))
forall a b. TypeRep a -> TypeRep b -> Maybe (a :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (Event (EraRule rule era) -> TypeRep (Event (EraRule rule era))
forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
x) (Event (EraRule rule era) -> TypeRep (Event (EraRule rule era))
forall a. Typeable a => a -> TypeRep a
typeOf Event (EraRule rule era)
y) = Event (EraRule rule era)
x Event (EraRule rule era) -> Event (EraRule rule era) -> Bool
forall a. Eq a => a -> a -> Bool
== Event (EraRule rule era)
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) = [Char] -> [Expr] -> Expr
App [Char]
"SomeSTSEvent" [Event (EraRule rule era) -> Expr
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
impCurSlotNo :: !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 Map (KeyHash Witness) (KeyPair Witness)
-> Map (KeyHash Witness) (KeyPair Witness)
-> Map (KeyHash Witness) (KeyPair Witness)
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 Map BootstrapAddress ByronKeyPair
-> Map BootstrapAddress ByronKeyPair
-> Map BootstrapAddress ByronKeyPair
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 = Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      , impPrepByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impPrepByronKeyPairs = Map BootstrapAddress ByronKeyPair
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 = (ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness))
-> (ImpTestState era
    -> Map (KeyHash Witness) (KeyPair Witness) -> ImpTestState era)
-> Lens'
     (ImpTestState era) (Map (KeyHash Witness) (KeyPair Witness))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness)
forall era.
ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness)
impKeyPairs (\ImpTestState era
x Map (KeyHash Witness) (KeyPair Witness)
y -> ImpTestState era
x {impKeyPairs = y})
  keyPairsByronL :: Lens' (ImpTestState era) (Map BootstrapAddress ByronKeyPair)
keyPairsByronL = (ImpTestState era -> Map BootstrapAddress ByronKeyPair)
-> (ImpTestState era
    -> Map BootstrapAddress ByronKeyPair -> ImpTestState era)
-> Lens' (ImpTestState era) (Map BootstrapAddress ByronKeyPair)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestState era -> Map BootstrapAddress ByronKeyPair
forall era. ImpTestState era -> Map BootstrapAddress ByronKeyPair
impByronKeyPairs (\ImpTestState era
x Map BootstrapAddress ByronKeyPair
y -> ImpTestState era
x {impByronKeyPairs = y})

instance HasKeyPairs ImpPrepState where
  keyPairsL :: Lens' ImpPrepState (Map (KeyHash Witness) (KeyPair Witness))
keyPairsL = (ImpPrepState -> Map (KeyHash Witness) (KeyPair Witness))
-> (ImpPrepState
    -> Map (KeyHash Witness) (KeyPair Witness) -> ImpPrepState)
-> Lens' ImpPrepState (Map (KeyHash Witness) (KeyPair Witness))
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 = y})
  keyPairsByronL :: Lens' ImpPrepState (Map BootstrapAddress ByronKeyPair)
keyPairsByronL = (ImpPrepState -> Map BootstrapAddress ByronKeyPair)
-> (ImpPrepState
    -> Map BootstrapAddress ByronKeyPair -> ImpPrepState)
-> Lens' ImpPrepState (Map BootstrapAddress ByronKeyPair)
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 = y})

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

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

impCurSlotNoL :: Lens' (ImpTestState era) SlotNo
impCurSlotNoL :: forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> ImpTestState era -> f (ImpTestState era)
impCurSlotNoL = (ImpTestState era -> SlotNo)
-> (ImpTestState era -> SlotNo -> ImpTestState era)
-> Lens (ImpTestState era) (ImpTestState era) SlotNo SlotNo
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestState era -> SlotNo
forall era. ImpTestState era -> SlotNo
impCurSlotNo (\ImpTestState era
x SlotNo
y -> ImpTestState era
x {impCurSlotNo = y})

impCurSlotNoG :: SimpleGetter (ImpTestState era) SlotNo
impCurSlotNoG :: forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG = (SlotNo -> Const r SlotNo)
-> ImpTestState era -> Const r (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> ImpTestState era -> f (ImpTestState era)
impCurSlotNoL

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

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

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

impNativeScriptsG ::
  SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsG :: forall era r.
Getting r (ImpTestState era) (Map ScriptHash (NativeScript era))
impNativeScriptsG = (Map ScriptHash (NativeScript era)
 -> Const r (Map ScriptHash (NativeScript era)))
-> ImpTestState era -> Const r (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Map ScriptHash (NativeScript era)
 -> f (Map ScriptHash (NativeScript era)))
-> ImpTestState era -> f (ImpTestState era)
impNativeScriptsL

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

class
  ( ShelleyEraTest 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
  , ToExpr (Event (EraRule "BBODY" 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 TopTx 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))
  , Environment (EraRule "NEWEPOCH" era) ~ ()
  , State (EraRule "NEWEPOCH" era) ~ NewEpochState era
  , Signal (EraRule "NEWEPOCH" era) ~ EpochNo
  , EraRuleFailure "BBODY" era ~ PredicateFailure (EraRule "BBODY" era)
  , EraRuleFailure "LEDGER" era ~ PredicateFailure (EraRule "LEDGER" era)
  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure 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 = Genesis era -> m (Genesis era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoGenesis era
Genesis era
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 = (NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
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)
forall a. a -> a
id

  initImpTestState ::
    ( HasKeyPairs s
    , MonadState s m
    , HasStatefulGen g m
    , MonadFail m
    ) =>
    m (ImpTestState era)
  initImpTestState = m (NewEpochState era)
forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState era)
initNewEpochState m (NewEpochState era)
-> (NewEpochState era -> m (ImpTestState era))
-> m (ImpTestState era)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NewEpochState era -> m (ImpTestState era)
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 l 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 = (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PParams era -> Identity (PParams era))
    -> EpochState era -> Identity (EpochState era))
-> (PParams era -> Identity (PParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (PParams era -> PParams era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

  modifyImpInitProtVer ::
    ShelleyEraImp era =>
    Version ->
    SpecWith (ImpInit (LedgerSpec era)) ->
    SpecWith (ImpInit (LedgerSpec era))

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

  expectTxSuccess :: HasCallStack => Tx TopTx era -> ImpTestM era ()

  genRegTxCert :: Credential Staking -> ImpTestM era (TxCert era)

  genUnRegTxCert :: Credential Staking -> ImpTestM era (TxCert era)

  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert era

impSatisfySignature ::
  KeyHash Witness ->
  Set.Set (KeyHash Witness) ->
  ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfySignature :: forall era.
KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfySignature KeyHash Witness
keyHash Set (KeyHash Witness)
providedVKeyHashes = do
  if KeyHash Witness
keyHash KeyHash Witness -> Set (KeyHash Witness) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash Witness)
providedVKeyHashes
    then
      Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpM
      (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
    else do
      keyPairs <- (ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness))
-> ImpM (LedgerSpec era) (Map (KeyHash Witness) (KeyPair Witness))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness)
forall era.
ImpTestState era -> Map (KeyHash Witness) (KeyPair Witness)
impKeyPairs
      pure $ Map.singleton keyHash <$> Map.lookup keyHash keyPairs

impSatisfyMNativeScripts ::
  ShelleyEraImp era =>
  Set.Set (KeyHash Witness) ->
  -- | Set of Witnesses that have already been satisfied
  TxBody l era ->
  -- | The transaction body that the scripts will be applied to
  Int ->
  -- | Number of scripts to satisfy
  StrictSeq (NativeScript era) ->
  -- | List of scripts that can be satisfied
  ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts :: forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody =
  Map (KeyHash Witness) (KeyPair Witness)
-> Int
-> StrictSeq (NativeScript era)
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
go Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
  where
    go :: Map (KeyHash Witness) (KeyPair Witness)
-> Int
-> StrictSeq (NativeScript era)
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
go !Map (KeyHash Witness) (KeyPair Witness)
acc Int
m StrictSeq (NativeScript era)
Empty
      | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpM
      (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
acc
      | Bool
otherwise = Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    go !Map (KeyHash Witness) (KeyPair Witness)
acc Int
m (NativeScript era
x :<| StrictSeq (NativeScript era)
xs) = do
      satisifed <- Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody NativeScript era
x
      case satisifed of
        Maybe (Map (KeyHash Witness) (KeyPair Witness))
Nothing -> Map (KeyHash Witness) (KeyPair Witness)
-> Int
-> StrictSeq (NativeScript era)
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
go Map (KeyHash Witness) (KeyPair Witness)
acc Int
m StrictSeq (NativeScript era)
xs
        Just Map (KeyHash Witness) (KeyPair Witness)
kps -> Map (KeyHash Witness) (KeyPair Witness)
-> Int
-> StrictSeq (NativeScript era)
-> ImpM
     (LedgerSpec era) (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
go (Map (KeyHash Witness) (KeyPair Witness)
kps Map (KeyHash Witness) (KeyPair Witness)
-> Map (KeyHash Witness) (KeyPair Witness)
-> Map (KeyHash Witness) (KeyPair Witness)
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash Witness) (KeyPair Witness)
acc) (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
xs

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 <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @era
  nes <- initNewEpochState @(PreviousEra era)
  let 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)
nes
          NewEpochState (PreviousEra era)
-> (NewEpochState (PreviousEra era)
    -> NewEpochState (PreviousEra era))
-> NewEpochState (PreviousEra era)
forall a b. a -> (a -> b) -> b
& (EpochState (PreviousEra era)
 -> Identity (EpochState (PreviousEra era)))
-> NewEpochState (PreviousEra era)
-> Identity (NewEpochState (PreviousEra era))
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState (PreviousEra era)
  -> Identity (EpochState (PreviousEra era)))
 -> NewEpochState (PreviousEra era)
 -> Identity (NewEpochState (PreviousEra era)))
-> ((ProtVer -> Identity ProtVer)
    -> EpochState (PreviousEra era)
    -> Identity (EpochState (PreviousEra era)))
-> (ProtVer -> Identity ProtVer)
-> NewEpochState (PreviousEra era)
-> Identity (NewEpochState (PreviousEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams (PreviousEra era) -> Identity (PParams (PreviousEra era)))
-> EpochState (PreviousEra era)
-> Identity (EpochState (PreviousEra era))
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState (PreviousEra era)) (PParams (PreviousEra era))
curPParamsEpochStateL ((PParams (PreviousEra era)
  -> Identity (PParams (PreviousEra era)))
 -> EpochState (PreviousEra era)
 -> Identity (EpochState (PreviousEra era)))
-> ((ProtVer -> Identity ProtVer)
    -> PParams (PreviousEra era)
    -> Identity (PParams (PreviousEra era)))
-> (ProtVer -> Identity ProtVer)
-> EpochState (PreviousEra era)
-> Identity (EpochState (PreviousEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Identity ProtVer)
-> PParams (PreviousEra era)
-> Identity (PParams (PreviousEra era))
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams (PreviousEra era)) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> NewEpochState (PreviousEra era)
 -> Identity (NewEpochState (PreviousEra era)))
-> ProtVer
-> NewEpochState (PreviousEra era)
-> NewEpochState (PreviousEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer Version
majProtVer Natural
0
          NewEpochState (PreviousEra era)
-> (NewEpochState (PreviousEra era)
    -> NewEpochState (PreviousEra era))
-> NewEpochState (PreviousEra era)
forall a b. a -> (a -> b) -> b
& (EpochNo -> Identity EpochNo)
-> NewEpochState (PreviousEra era)
-> Identity (NewEpochState (PreviousEra era))
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL ((EpochNo -> Identity EpochNo)
 -> NewEpochState (PreviousEra era)
 -> Identity (NewEpochState (PreviousEra era)))
-> EpochNo
-> NewEpochState (PreviousEra era)
-> NewEpochState (PreviousEra era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochNo -> EpochNo
forall a. Enum a => a -> a
pred (forall era. Era era => EpochNo
impEraStartEpochNo @era)
  pure $ translateEra' genesis $ modifyPrevEraNewEpochState 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 (Version -> Word64
forall i. Integral i => Version -> i
getVersion Version
majProtVer Word64 -> Word64 -> Word64
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 <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
  rootKeyHash <- freshKeyHash @Payment
  let
    rootAddr :: Addr
    rootAddr = KeyHash Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash Payment
rootKeyHash StakeReference
StakeRefNull
    rootTxOut :: TxOut era
    rootTxOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
rootAddr (Value era -> TxOut era) -> Value era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
rootCoin
    rootCoin = Integer -> Coin
Coin (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (ShelleyGenesis -> Word64
sgMaxLovelaceSupply Genesis ShelleyEra
ShelleyGenesis
shelleyGenesis))
    rootTxIn :: TxIn
    rootTxIn = TxId -> TxIx -> TxIn
TxIn (Int -> TxId
mkTxId Int
0) TxIx
forall a. Bounded a => a
minBound
    nesWithRoot = NewEpochState era
nes NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (UTxO era -> Identity (UTxO era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL ((UTxO era -> Identity (UTxO era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> UTxO era -> NewEpochState era -> NewEpochState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (TxIn -> TxOut era -> Map TxIn (TxOut era)
forall k a. k -> a -> Map k a
Map.singleton TxIn
rootTxIn TxOut era
rootTxOut)
  prepState <- get
  let epochInfoE =
        EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
          (ShelleyGenesis -> EpochSize
sgEpochLength Genesis ShelleyEra
ShelleyGenesis
shelleyGenesis)
          (NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength)
-> (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro
-> SlotLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro (NominalDiffTimeMicro -> SlotLength)
-> NominalDiffTimeMicro -> SlotLength
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NominalDiffTimeMicro
sgSlotLength Genesis ShelleyEra
ShelleyGenesis
shelleyGenesis)
      globals = ShelleyGenesis -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals Genesis ShelleyEra
ShelleyGenesis
shelleyGenesis EpochInfo (Either Text)
epochInfoE
      epochNo = NewEpochState era
nesWithRoot NewEpochState era
-> Getting EpochNo (NewEpochState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      slotNo = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo
  pure $
    ImpTestState
      { impNES = nesWithRoot
      , impRootTxIn = rootTxIn
      , impKeyPairs = prepState ^. keyPairsL
      , impByronKeyPairs = prepState ^. keyPairsByronL
      , impNativeScripts = mempty
      , impCurSlotNo = slotNo
      , impGlobals = globals
      , impEvents = mempty
      }

withEachEraVersion ::
  forall era.
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era)) ->
  Spec
withEachEraVersion :: forall era.
ShelleyEraImp era =>
SpecWith (ImpInit (LedgerSpec era)) -> Spec
withEachEraVersion SpecWith (ImpInit (LedgerSpec era))
specWith =
  forall t. ImpSpec t => SpecWith (ImpInit t) -> Spec
withImpInit @(LedgerSpec era) (SpecWith (ImpInit (LedgerSpec era)) -> Spec)
-> SpecWith (ImpInit (LedgerSpec era)) -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Version]
-> (Version -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. Era era => [Version]
eraProtVersions @era) ((Version -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Version -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Version
protVer ->
      [Char]
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
protVer) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
        Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
(ShelleyEraImp era, ShelleyEraImp era) =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer Version
protVer SpecWith (ImpInit (LedgerSpec era))
specWith

shelleyModifyImpInitProtVer ::
  forall era.
  ShelleyEraImp era =>
  Version ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer :: forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer Version
ver =
  (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit ((ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitState =
          impInitState impInit
            & impNESL . nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer ver 0
      }

modifyImpInitPostSubmitTxHook ::
  forall era.
  ( forall t.
    Globals ->
    TRC (EraRule "LEDGER" era) ->
    Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
    ImpM t ()
  ) ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostSubmitTxHook :: forall era.
(forall t.
 Globals
 -> TRC (EraRule "LEDGER" era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostSubmitTxHook forall t.
Globals
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> ImpM t ()
f =
  (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit ((ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitEnv =
          impInitEnv impInit
            & itePostSubmitTxHookL .~ f
      }

disableImpInitPostSubmitTxHook ::
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostSubmitTxHook :: forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostSubmitTxHook =
  (forall t.
 Globals
 -> TRC (EraRule "LEDGER" era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
(forall t.
 Globals
 -> TRC (EraRule "LEDGER" era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostSubmitTxHook ((forall t.
  Globals
  -> TRC (EraRule "LEDGER" era)
  -> Either
       (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
       (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
  -> ImpM t ())
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall t.
    Globals
    -> TRC (EraRule "LEDGER" era)
    -> Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
         (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
    -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Globals
_ TRC (EraRule "LEDGER" era)
_ Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
_ -> () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

modifyImpInitPostEpochBoundaryHook ::
  forall era.
  ( forall t.
    Globals ->
    TRC (EraRule "NEWEPOCH" era) ->
    State (EraRule "NEWEPOCH" era) ->
    ImpM t ()
  ) ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostEpochBoundaryHook :: forall era.
(forall t.
 Globals
 -> TRC (EraRule "NEWEPOCH" era)
 -> State (EraRule "NEWEPOCH" era)
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostEpochBoundaryHook forall t.
Globals
-> TRC (EraRule "NEWEPOCH" era)
-> State (EraRule "NEWEPOCH" era)
-> ImpM t ()
f = (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit ((ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
  ImpInit (LedgerSpec era)
impInit
    { impInitEnv =
        impInitEnv impInit
          & itePostEpochBoundaryHookL .~ f
    }

disableImpInitPostEpochBoundaryHook ::
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostEpochBoundaryHook :: forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostEpochBoundaryHook =
  (forall t.
 Globals
 -> TRC (EraRule "NEWEPOCH" era)
 -> State (EraRule "NEWEPOCH" era)
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
(forall t.
 Globals
 -> TRC (EraRule "NEWEPOCH" era)
 -> State (EraRule "NEWEPOCH" era)
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitPostEpochBoundaryHook ((forall t.
  Globals
  -> TRC (EraRule "NEWEPOCH" era)
  -> State (EraRule "NEWEPOCH" era)
  -> ImpM t ())
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall t.
    Globals
    -> TRC (EraRule "NEWEPOCH" era)
    -> State (EraRule "NEWEPOCH" era)
    -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Globals
_ TRC (EraRule "NEWEPOCH" era)
_ State (EraRule "NEWEPOCH" era)
_ -> () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

disableInConformanceIt ::
  ShelleyEraImp era =>
  String ->
  ImpTestM era () ->
  SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt :: forall era.
ShelleyEraImp era =>
[Char] -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt [Char]
s =
  SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostSubmitTxHook
    (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era ()
-> SpecWith (ImpInit (LedgerSpec era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitPostEpochBoundaryHook
    (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era ()
-> SpecWith (ImpInit (LedgerSpec era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it ([Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [disabled in conformance]")

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 <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> SlotNo
forall era. ImpTestState era -> SlotNo
impCurSlotNo
  epochNo <- runShelleyBase $ epochFromSlot slotNo
  pure
    LedgerEnv
      { ledgerSlotNo = slotNo
      , ledgerEpochNo = Just epochNo
      , ledgerPp = nes ^. nesEsL . curPParamsEpochStateL
      , ledgerIx = TxIx 0
      , ledgerAccount = nes ^. chainAccountStateL
      }

-- | 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 = (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PParams era -> Identity (PParams era))
    -> EpochState era -> Identity (EpochState era))
-> (PParams era -> Identity (PParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (PParams era -> PParams era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f

-- | Logs the current stake distribution
logInstantStake :: ToExpr (InstantStake era) => HasCallStack => ImpTestM era ()
logInstantStake :: forall era.
(ToExpr (InstantStake era), HasCallStack) =>
ImpTestM era ()
logInstantStake = do
  stakeDistr <- SimpleGetter (NewEpochState era) (InstantStake era)
-> ImpTestM era (InstantStake era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES Getting r (NewEpochState era) (InstantStake era)
SimpleGetter (NewEpochState era) (InstantStake era)
forall era. SimpleGetter (NewEpochState era) (InstantStake era)
forall (t :: * -> *) era.
CanGetInstantStake t =>
SimpleGetter (t era) (InstantStake era)
instantStakeG
  logDoc $ "Instant Stake: " <> ansiExpr stakeDistr

mkTxId :: Int -> TxId
mkTxId :: Int -> TxId
mkTxId Int
idx = SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
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 = Fail UTCTime -> UTCTime
forall a. HasCallStack => Fail a -> a
errorFail (Fail UTCTime -> UTCTime) -> Fail UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ [Char] -> Fail UTCTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => [Char] -> m t
iso8601ParseM [Char]
"2017-09-23T21:44:51Z"
          , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123_456 -- Mainnet value: 764824073
          , sgNetworkId :: Network
sgNetworkId = Network
Testnet
          , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
20 Integer -> Integer -> PositiveUnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100 -- Mainnet value: 5 %! 100
          , sgSecurityParam :: NonZero Word64
sgSecurityParam = forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @108 -- Mainnet value: 2160
          , sgEpochLength :: EpochSize
sgEpochLength = EpochSize
4320 -- Mainnet value: 432000
          , sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod = Word64
129_600
          , 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 =
              PParams ShelleyEra
forall era. EraPParams era => PParams era
emptyPParams
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinFeeAL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinFeeBL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155_381
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams ShelleyEra) Word32
ppMaxBBSizeL ((Word32 -> Identity Word32)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Word32 -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
65_536
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams ShelleyEra) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Word32 -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
16_384
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppKeyDepositL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppPoolDepositL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
500_000_000
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams ShelleyEra) EpochInterval
ppEMaxL ((EpochInterval -> Identity EpochInterval)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> EpochInterval -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
18
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Word16 -> Identity Word16)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams ShelleyEra) Word16
ppNOptL ((Word16 -> Identity Word16)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Word16 -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16
150
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (NonNegativeInterval -> Identity NonNegativeInterval)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams ShelleyEra) NonNegativeInterval
ppA0L ((NonNegativeInterval -> Identity NonNegativeInterval)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> NonNegativeInterval -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (UnitInterval -> Identity UnitInterval)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) UnitInterval
Lens' (PParams ShelleyEra) UnitInterval
ppRhoL ((UnitInterval -> Identity UnitInterval)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> UnitInterval -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1000)
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (UnitInterval -> Identity UnitInterval)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) UnitInterval
Lens' (PParams ShelleyEra) UnitInterval
ppTauL ((UnitInterval -> Identity UnitInterval)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> UnitInterval -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (UnitInterval -> Identity UnitInterval)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era.
(EraPParams era, AtMostEra "Alonzo" era) =>
Lens' (PParams era) UnitInterval
Lens' (PParams ShelleyEra) UnitInterval
ppDL ((UnitInterval -> Identity UnitInterval)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> UnitInterval -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Nonce -> Identity Nonce)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era.
(EraPParams era, AtMostEra "Alonzo" era) =>
Lens' (PParams era) Nonce
Lens' (PParams ShelleyEra) Nonce
ppExtraEntropyL ((Nonce -> Identity Nonce)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Nonce -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Nonce
NeutralNonce
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era.
(EraPParams era, AtMostEra "Mary" era) =>
Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinUTxOValueL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
                PParams ShelleyEra
-> (PParams ShelleyEra -> PParams ShelleyEra) -> PParams ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams ShelleyEra -> Identity (PParams ShelleyEra)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinPoolCostL ((Coin -> Identity Coin)
 -> PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> Coin -> PParams ShelleyEra -> PParams ShelleyEra
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 GenesisRole) GenDelegPair
sgGenDelegs = Map (KeyHash GenesisRole) GenDelegPair
forall a. Monoid a => a
mempty
          , sgInitialFunds :: ListMap Addr Coin
sgInitialFunds = ListMap Addr Coin
forall a. Monoid a => a
mempty
          , sgStaking :: ShelleyGenesisStaking
sgStaking = ShelleyGenesisStaking
forall a. Monoid a => a
mempty
          }
    case ShelleyGenesis -> Either [ValidationErr] ()
validateGenesis ShelleyGenesis
gen of
      Right () -> ShelleyGenesis -> m ShelleyGenesis
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis
gen
      Left [ValidationErr]
errs -> [Char] -> m (Genesis ShelleyEra)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m (Genesis ShelleyEra))
-> ([Text] -> [Char]) -> [Text] -> m (Genesis ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> ([Text] -> Text) -> [Text] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> m (Genesis ShelleyEra))
-> [Text] -> m (Genesis ShelleyEra)
forall a b. (a -> b) -> a -> b
$ (ValidationErr -> Text) -> [ValidationErr] -> [Text]
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 <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
    let transContext = ShelleyGenesis -> FromByronTranslationContext
toFromByronTranslationContext Genesis ShelleyEra
ShelleyGenesis
shelleyGenesis
        startEpochNo = forall era. Era era => EpochNo
impEraStartEpochNo @ShelleyEra
    pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty

  impSatisfyNativeScript :: forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l ShelleyEra
-> NativeScript ShelleyEra
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript Set (KeyHash Witness)
providedVKeyHashes TxBody l ShelleyEra
txBody NativeScript ShelleyEra
script = do
    case NativeScript ShelleyEra
script of
      RequireSignature KeyHash Witness
keyHash -> KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era.
KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfySignature KeyHash Witness
keyHash Set (KeyHash Witness)
providedVKeyHashes
      RequireAllOf StrictSeq (NativeScript ShelleyEra)
ss -> Set (KeyHash Witness)
-> TxBody l ShelleyEra
-> Int
-> StrictSeq (NativeScript ShelleyEra)
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l ShelleyEra
txBody (StrictSeq (NativeScript ShelleyEra) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript ShelleyEra)
ss) StrictSeq (NativeScript ShelleyEra)
ss
      RequireAnyOf StrictSeq (NativeScript ShelleyEra)
ss -> do
        m <- [(Int, ImpM (LedgerSpec ShelleyEra) Int)]
-> ImpM (LedgerSpec ShelleyEra) Int
forall (m :: * -> *) a. MonadGen m => [(Int, m a)] -> m a
frequency [(Int
9, Int -> ImpM (LedgerSpec ShelleyEra) Int
forall a. a -> ImpM (LedgerSpec ShelleyEra) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1), (Int
1, (Int, Int) -> ImpM (LedgerSpec ShelleyEra) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec ShelleyEra) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, StrictSeq (NativeScript ShelleyEra) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript ShelleyEra)
ss))]
        impSatisfyMNativeScripts providedVKeyHashes txBody m ss
      RequireMOf Int
m StrictSeq (NativeScript ShelleyEra)
ss -> Set (KeyHash Witness)
-> TxBody l ShelleyEra
-> Int
-> StrictSeq (NativeScript ShelleyEra)
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l ShelleyEra
txBody Int
m StrictSeq (NativeScript ShelleyEra)
ss
      NativeScript ShelleyEra
_ -> [Char]
-> ImpTestM
     ShelleyEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: All NativeScripts should have been accounted for"

  fixupTx :: HasCallStack =>
Tx TopTx ShelleyEra -> ImpTestM ShelleyEra (Tx TopTx ShelleyEra)
fixupTx = Tx TopTx ShelleyEra -> ImpTestM ShelleyEra (Tx TopTx ShelleyEra)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
shelleyFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx ShelleyEra -> ImpTestM ShelleyEra ()
expectTxSuccess = Tx TopTx ShelleyEra -> ImpTestM ShelleyEra ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era ()
impShelleyExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp ShelleyEra =>
Version
-> SpecWith (ImpInit (LedgerSpec ShelleyEra))
-> SpecWith (ImpInit (LedgerSpec ShelleyEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec ShelleyEra))
-> SpecWith (ImpInit (LedgerSpec ShelleyEra))
forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM ShelleyEra (TxCert ShelleyEra)
genRegTxCert = Credential Staking -> ImpTestM ShelleyEra (TxCert ShelleyEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM ShelleyEra (TxCert ShelleyEra)
genUnRegTxCert = Credential Staking -> ImpTestM ShelleyEra (TxCert ShelleyEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert ShelleyEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert ShelleyEra
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
shelleyDelegStakeTxCert

-- | 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 l era ->
  ImpTestM
    era
    ( Set.Set BootstrapAddress -- Byron Based Addresses
    , Set.Set (KeyHash Witness) -- Shelley Based KeyHashes
    )
impWitsVKeyNeeded :: forall era (l :: TxLevel).
EraUTxO era =>
TxBody l era
-> ImpTestM era (Set BootstrapAddress, Set (KeyHash Witness))
impWitsVKeyNeeded TxBody l era
txBody = do
  ls <- SimpleGetter (NewEpochState era) (LedgerState era)
-> ImpTestM era (LedgerState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((LedgerState era -> Const r (LedgerState era))
    -> EpochState era -> Const r (EpochState era))
-> (LedgerState era -> Const r (LedgerState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL)
  utxo <- getUTxO
  let toBootAddr TxIn
txIn = do
        txOut <- TxIn -> UTxO era -> Maybe (TxOut era)
forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txIn UTxO era
utxo
        txOut ^. bootAddrTxOutF
      bootAddrs = [BootstrapAddress] -> Set BootstrapAddress
forall a. Ord a => [a] -> Set a
Set.fromList ([BootstrapAddress] -> Set BootstrapAddress)
-> [BootstrapAddress] -> Set BootstrapAddress
forall a b. (a -> b) -> a -> b
$ (TxIn -> Maybe BootstrapAddress) -> [TxIn] -> [BootstrapAddress]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxIn -> Maybe BootstrapAddress
toBootAddr ([TxIn] -> [BootstrapAddress]) -> [TxIn] -> [BootstrapAddress]
forall a b. (a -> b) -> a -> b
$ Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
SimpleGetter (TxBody l era) (Set TxIn)
forall (l :: TxLevel). SimpleGetter (TxBody l era) (Set TxIn)
spendableInputsTxBodyF)
      bootKeyHashes = (BootstrapAddress -> KeyHash Witness)
-> Set BootstrapAddress -> Set (KeyHash Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (KeyHash Payment -> KeyHash Witness
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (KeyHash Payment -> KeyHash Witness)
-> (BootstrapAddress -> KeyHash Payment)
-> BootstrapAddress
-> KeyHash Witness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BootstrapAddress -> KeyHash Payment
bootstrapKeyHash) Set BootstrapAddress
bootAddrs
      allKeyHashes =
        CertState era -> UTxO era -> TxBody l era -> Set (KeyHash Witness)
forall era (t :: TxLevel).
EraUTxO era =>
CertState era -> UTxO era -> TxBody t era -> Set (KeyHash Witness)
forall (t :: TxLevel).
CertState era -> UTxO era -> TxBody t era -> Set (KeyHash Witness)
getWitsVKeyNeeded (LedgerState era
ls LedgerState era
-> Getting (CertState era) (LedgerState era) (CertState era)
-> CertState era
forall s a. s -> Getting a s a -> a
^. Getting (CertState era) (LedgerState era) (CertState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL) (LedgerState era
ls LedgerState era
-> Getting (UTxO era) (LedgerState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (LedgerState era) (UTxO era)
forall era. Lens' (LedgerState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL) TxBody l era
txBody
  pure (bootAddrs, allKeyHashes Set.\\ bootKeyHashes)

data ImpTestEnv era = ImpTestEnv
  { forall era.
ImpTestEnv era -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
iteFixup :: Tx TopTx era -> ImpTestM era (Tx TopTx era)
  , forall era.
ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "LEDGER" era)
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> ImpM t ()
itePostSubmitTxHook ::
      forall t.
      Globals ->
      TRC (EraRule "LEDGER" era) ->
      Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
      ImpM t ()
  , forall era.
ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "NEWEPOCH" era)
   -> State (EraRule "NEWEPOCH" era)
   -> ImpM t ()
itePostEpochBoundaryHook ::
      forall t.
      Globals ->
      TRC (EraRule "NEWEPOCH" era) ->
      State (EraRule "NEWEPOCH" era) ->
      ImpM t ()
  }

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

itePostSubmitTxHookL ::
  forall era.
  Lens'
    (ImpTestEnv era)
    ( forall t.
      Globals ->
      TRC (EraRule "LEDGER" era) ->
      Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
      ImpM t ()
    )
itePostSubmitTxHookL :: forall era (f :: * -> *).
Functor f =>
((forall t.
  Globals
  -> TRC (EraRule "LEDGER" era)
  -> Either
       (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
       (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
  -> ImpM t ())
 -> f (forall t.
       Globals
       -> TRC (EraRule "LEDGER" era)
       -> Either
            (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
            (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
       -> ImpM t ()))
-> ImpTestEnv era -> f (ImpTestEnv era)
itePostSubmitTxHookL = (ImpTestEnv era
 -> forall t.
    Globals
    -> TRC (EraRule "LEDGER" era)
    -> Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
         (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
    -> ImpM t ())
-> (ImpTestEnv era
    -> (forall t.
        Globals
        -> TRC (EraRule "LEDGER" era)
        -> Either
             (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
             (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
        -> ImpM t ())
    -> ImpTestEnv era)
-> Lens
     (ImpTestEnv era)
     (ImpTestEnv era)
     (forall t.
      Globals
      -> TRC (EraRule "LEDGER" era)
      -> Either
           (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
           (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
      -> ImpM t ())
     (forall t.
      Globals
      -> TRC (EraRule "LEDGER" era)
      -> Either
           (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
           (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
      -> ImpM t ())
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "LEDGER" era)
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> ImpM t ()
forall era.
ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "LEDGER" era)
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> ImpM t ()
itePostSubmitTxHook (\ImpTestEnv era
x forall t.
Globals
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> ImpM t ()
y -> ImpTestEnv era
x {itePostSubmitTxHook = y})

itePostEpochBoundaryHookL ::
  forall era.
  Lens'
    (ImpTestEnv era)
    ( forall t.
      Globals ->
      TRC (EraRule "NEWEPOCH" era) ->
      State (EraRule "NEWEPOCH" era) ->
      ImpM t ()
    )
itePostEpochBoundaryHookL :: forall era (f :: * -> *).
Functor f =>
((forall t.
  Globals
  -> TRC (EraRule "NEWEPOCH" era)
  -> State (EraRule "NEWEPOCH" era)
  -> ImpM t ())
 -> f (forall t.
       Globals
       -> TRC (EraRule "NEWEPOCH" era)
       -> State (EraRule "NEWEPOCH" era)
       -> ImpM t ()))
-> ImpTestEnv era -> f (ImpTestEnv era)
itePostEpochBoundaryHookL = (ImpTestEnv era
 -> forall t.
    Globals
    -> TRC (EraRule "NEWEPOCH" era)
    -> State (EraRule "NEWEPOCH" era)
    -> ImpM t ())
-> (ImpTestEnv era
    -> (forall t.
        Globals
        -> TRC (EraRule "NEWEPOCH" era)
        -> State (EraRule "NEWEPOCH" era)
        -> ImpM t ())
    -> ImpTestEnv era)
-> Lens
     (ImpTestEnv era)
     (ImpTestEnv era)
     (forall t.
      Globals
      -> TRC (EraRule "NEWEPOCH" era)
      -> State (EraRule "NEWEPOCH" era)
      -> ImpM t ())
     (forall t.
      Globals
      -> TRC (EraRule "NEWEPOCH" era)
      -> State (EraRule "NEWEPOCH" era)
      -> ImpM t ())
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "NEWEPOCH" era)
   -> State (EraRule "NEWEPOCH" era)
   -> ImpM t ()
forall era.
ImpTestEnv era
-> forall t.
   Globals
   -> TRC (EraRule "NEWEPOCH" era)
   -> State (EraRule "NEWEPOCH" era)
   -> ImpM t ()
itePostEpochBoundaryHook (\ImpTestEnv era
x forall t.
Globals
-> TRC (EraRule "NEWEPOCH" era)
-> State (EraRule "NEWEPOCH" era)
-> ImpM t ()
y -> ImpTestEnv era
x {itePostEpochBoundaryHook = y})

instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
  writer :: forall a. (a, [SomeSTSEvent era]) -> ImpTestM era a
writer (a
x, [SomeSTSEvent era]
evs) = (([SomeSTSEvent era] -> Identity [SomeSTSEvent era])
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
([SomeSTSEvent era] -> f [SomeSTSEvent era])
-> ImpTestState era -> f (ImpTestState era)
impEventsL (([SomeSTSEvent era] -> Identity [SomeSTSEvent era])
 -> ImpTestState era -> Identity (ImpTestState era))
-> ([SomeSTSEvent era] -> [SomeSTSEvent era]) -> ImpTestM era ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([SomeSTSEvent era] -> [SomeSTSEvent era] -> [SomeSTSEvent era]
forall a. Semigroup a => a -> a -> a
<> [SomeSTSEvent era]
evs)) ImpTestM era () -> a -> ImpM (LedgerSpec era) a
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
    oldEvs <- Getting [SomeSTSEvent era] (ImpTestState era) [SomeSTSEvent era]
-> ImpM (LedgerSpec era) [SomeSTSEvent era]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [SomeSTSEvent era] (ImpTestState era) [SomeSTSEvent era]
forall era (f :: * -> *).
Functor f =>
([SomeSTSEvent era] -> f [SomeSTSEvent era])
-> ImpTestState era -> f (ImpTestState era)
impEventsL
    impEventsL .= mempty
    res <- act
    newEvs <- use impEventsL
    impEventsL .= oldEvs
    pure (res, 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, f), evs) <- ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
-> ImpM
     (LedgerSpec era)
     ((a, [SomeSTSEvent era] -> [SomeSTSEvent era]), [SomeSTSEvent era])
forall a. ImpTestM era a -> ImpTestM era (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act
    writer (a, f evs)

runShelleyBase :: ShelleyBase a -> ImpTestM era a
runShelleyBase :: forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase ShelleyBase a
act = do
  globals <- Getting Globals (ImpTestState era) Globals
-> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL
  pure $ runIdentity $ runReaderT act globals

lookupBalance :: EraCertState era => Credential Staking -> ImpTestM era (Maybe Coin)
lookupBalance :: forall era.
EraCertState era =>
Credential Staking -> ImpTestM era (Maybe Coin)
lookupBalance Credential Staking
cred = do
  accountsMap <- SimpleGetter
  (NewEpochState era) (Map (Credential Staking) (AccountState era))
-> ImpTestM era (Map (Credential Staking) (AccountState era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era) (Map (Credential Staking) (AccountState era))
 -> ImpTestM era (Map (Credential Staking) (AccountState era)))
-> SimpleGetter
     (NewEpochState era) (Map (Credential Staking) (AccountState era))
-> ImpTestM era (Map (Credential Staking) (AccountState era))
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const r (Map (Credential Staking) (AccountState era)))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const r (Map (Credential Staking) (AccountState era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const r (Map (Credential Staking) (AccountState era)))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const r (Map (Credential Staking) (AccountState era)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const r (Map (Credential Staking) (AccountState era)))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const r (Map (Credential Staking) (AccountState era)))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const r (Map (Credential Staking) (AccountState era)))
    -> DState era -> Const r (DState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const r (Map (Credential Staking) (AccountState era)))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Const r (Accounts era))
 -> DState era -> Const r (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const r (Map (Credential Staking) (AccountState era)))
    -> Accounts era -> Const r (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Const r (Map (Credential Staking) (AccountState era)))
-> DState era
-> Const r (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const r (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Const r (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
  pure $
    (\AccountState era
accountState -> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL))
      <$> Map.lookup cred accountsMap

lookupAccountBalance ::
  (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era (Maybe Coin)
lookupAccountBalance :: forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era (Maybe Coin)
lookupAccountBalance ra :: RewardAccount
ra@RewardAccount {Network
raNetwork :: Network
raNetwork :: RewardAccount -> Network
raNetwork, Credential Staking
raCredential :: Credential Staking
raCredential :: RewardAccount -> Credential Staking
raCredential} = do
  networkId <- Getting Network (ImpTestState era) Network
-> ImpM (LedgerSpec era) Network
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Globals -> Const Network Globals)
-> ImpTestState era -> Const Network (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const Network Globals)
 -> ImpTestState era -> Const Network (ImpTestState era))
-> ((Network -> Const Network Network)
    -> Globals -> Const Network Globals)
-> Getting Network (ImpTestState era) Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> Network) -> SimpleGetter Globals Network
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  when (raNetwork /= networkId) $
    error $
      "Reward Account with an unexpected NetworkId: " ++ show ra
  lookupBalance raCredential

getBalance :: (HasCallStack, EraCertState era) => Credential Staking -> ImpTestM era Coin
getBalance :: forall era.
(HasCallStack, EraCertState era) =>
Credential Staking -> ImpTestM era Coin
getBalance Credential Staking
cred =
  Credential Staking -> ImpTestM era (Maybe Coin)
forall era.
EraCertState era =>
Credential Staking -> ImpTestM era (Maybe Coin)
lookupBalance Credential Staking
cred ImpTestM era (Maybe Coin)
-> (Maybe Coin -> ImpM (LedgerSpec era) Coin)
-> ImpM (LedgerSpec era) Coin
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Coin
Nothing ->
      [Char] -> ImpM (LedgerSpec era) Coin
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure ([Char] -> ImpM (LedgerSpec era) Coin)
-> [Char] -> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$
        [Char]
"Expected a registered account: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Credential Staking -> [Char]
forall a. Show a => a -> [Char]
show Credential Staking
cred
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Use `registerRewardAccount` to register a new account in ImpSpec"
    Just Coin
balance -> Coin -> ImpM (LedgerSpec era) Coin
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
balance

getAccountBalance :: (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era Coin
getAccountBalance :: forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era Coin
getAccountBalance RewardAccount
ra =
  RewardAccount -> ImpTestM era (Maybe Coin)
forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era (Maybe Coin)
lookupAccountBalance RewardAccount
ra ImpTestM era (Maybe Coin)
-> (Maybe Coin -> ImpM (LedgerSpec era) Coin)
-> ImpM (LedgerSpec era) Coin
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Coin
Nothing ->
      [Char] -> ImpM (LedgerSpec era) Coin
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure ([Char] -> ImpM (LedgerSpec era) Coin)
-> [Char] -> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$
        [Char]
"Expected a registered account: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RewardAccount -> [Char]
forall a. Show a => a -> [Char]
show RewardAccount
ra
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Use `registerRewardAccount` to register a new account in ImpSpec"
    Just Coin
balance -> Coin -> ImpM (LedgerSpec era) Coin
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
balance

getImpRootTxOut :: ImpTestM era (TxIn, TxOut era)
getImpRootTxOut :: forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut = do
  ImpTestState {impRootTxIn} <- ImpM (LedgerSpec era) (ImpTestState era)
forall s (m :: * -> *). MonadState s m => m s
get
  utxo <- getUTxO
  case txinLookup impRootTxIn utxo of
    Maybe (TxOut era)
Nothing -> [Char] -> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall a. HasCallStack => [Char] -> a
error [Char]
"Root txId no longer points to an existing unspent output"
    Just TxOut era
rootTxOut -> (TxIn, TxOut era) -> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
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 = NativeScript era -> Script era
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
  (Map ScriptHash (NativeScript era)
 -> Identity (Map ScriptHash (NativeScript era)))
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Map ScriptHash (NativeScript era)
 -> f (Map ScriptHash (NativeScript era)))
-> ImpTestState era -> f (ImpTestState era)
impNativeScriptsL ((Map ScriptHash (NativeScript era)
  -> Identity (Map ScriptHash (NativeScript era)))
 -> ImpTestState era -> Identity (ImpTestState era))
-> (Map ScriptHash (NativeScript era)
    -> Map ScriptHash (NativeScript era))
-> ImpM (LedgerSpec era) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ScriptHash
-> NativeScript era
-> Map ScriptHash (NativeScript era)
-> Map ScriptHash (NativeScript era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScriptHash
scriptHash NativeScript era
nativeScript
  ScriptHash -> ImpM (LedgerSpec era) ScriptHash
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptHash
scriptHash

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

-- | Modifies transaction by adding necessary scripts
addNativeScriptTxWits ::
  ShelleyEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
addNativeScriptTxWits :: forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits Tx l era
tx = [Char]
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"addNativeScriptTxWits" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  scriptsRequired <- Tx l era
-> ImpM (LedgerSpec era) (Map ScriptHash (NativeScript era))
forall era (l :: TxLevel).
EraUTxO era =>
Tx l era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx l era
tx
  utxo <- getUTxO
  let ScriptsProvided provided = getScriptsProvided utxo tx
      scriptsToAdd = Map ScriptHash (NativeScript era)
scriptsRequired Map ScriptHash (NativeScript era)
-> Map ScriptHash (Script era) -> Map ScriptHash (NativeScript era)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ Map ScriptHash (Script era)
provided
  pure $
    tx
      & witsTxL . scriptTxWitsL <>~ fmap fromNativeScript scriptsToAdd

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

-- | This fixup step ensures that there are enough funds in the transaction.
addRootTxIn ::
  ShelleyEraImp era =>
  Tx l era ->
  ImpTestM era (Tx l era)
addRootTxIn :: forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addRootTxIn Tx l era
tx = [Char]
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"addRootTxIn" (ImpM (LedgerSpec era) (Tx l era)
 -> ImpM (LedgerSpec era) (Tx l era))
-> ImpM (LedgerSpec era) (Tx l era)
-> ImpM (LedgerSpec era) (Tx l era)
forall a b. (a -> b) -> a -> b
$ do
  rootTxIn <- (TxIn, TxOut era) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut era) -> TxIn)
-> ImpM (LedgerSpec era) (TxIn, TxOut era)
-> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (TxIn, TxOut era)
forall era. ImpTestM era (TxIn, TxOut era)
getImpRootTxOut
  pure $
    tx
      & bodyTxL . inputsTxBodyL %~ Set.insert rootTxIn

impNativeScriptKeyPairs ::
  ShelleyEraImp era =>
  Tx l era ->
  ImpTestM era (Map (KeyHash Witness) (KeyPair Witness))
impNativeScriptKeyPairs :: forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Map (KeyHash Witness) (KeyPair Witness))
impNativeScriptKeyPairs Tx l era
tx = do
  scriptsRequired <- Tx l era
-> ImpM (LedgerSpec era) (Map ScriptHash (NativeScript era))
forall era (l :: TxLevel).
EraUTxO era =>
Tx l era -> ImpTestM era (Map ScriptHash (NativeScript era))
impNativeScriptsRequired Tx l era
tx
  let nativeScripts = Map ScriptHash (NativeScript era) -> [NativeScript era]
forall k a. Map k a -> [a]
Map.elems Map ScriptHash (NativeScript era)
scriptsRequired
      curAddrWits = (WitVKey Witness -> KeyHash Witness)
-> Set (WitVKey Witness) -> Set (KeyHash Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WitVKey Witness -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
witVKeyHash (Set (WitVKey Witness) -> Set (KeyHash Witness))
-> Set (WitVKey Witness) -> Set (KeyHash Witness)
forall a b. (a -> b) -> a -> b
$ Tx l era
tx Tx l era
-> Getting
     (Set (WitVKey Witness)) (Tx l era) (Set (WitVKey Witness))
-> Set (WitVKey Witness)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
-> Tx l era -> Const (Set (WitVKey Witness)) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
 -> Tx l era -> Const (Set (WitVKey Witness)) (Tx l era))
-> ((Set (WitVKey Witness)
     -> Const (Set (WitVKey Witness)) (Set (WitVKey Witness)))
    -> TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
-> Getting
     (Set (WitVKey Witness)) (Tx l era) (Set (WitVKey Witness))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness)
 -> Const (Set (WitVKey Witness)) (Set (WitVKey Witness)))
-> TxWits era -> Const (Set (WitVKey Witness)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL
  keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts
  pure . mconcat $ catMaybes keyPairs

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

fixupFees ::
  (ShelleyEraImp era, HasCallStack) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
fixupFees :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupFees Tx TopTx era
txOriginal = [Char]
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"fixupFees" (ImpM (LedgerSpec era) (Tx TopTx era)
 -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
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 TopTx era
tx = Tx TopTx era
txOriginal Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Coin -> Identity Coin)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Coin -> Identity Coin)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Coin -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall t. Val t => t
zero
  pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  utxo <- getUTxO
  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
  addr <- freshKeyAddr_
  nativeScriptKeyPairs <- impNativeScriptKeyPairs tx
  let
    nativeScriptKeyWits = Map (KeyHash Witness) (KeyPair Witness) -> Set (KeyHash Witness)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash Witness) (KeyPair Witness)
nativeScriptKeyPairs
    consumedValue = PParams era
-> CertState era -> UTxO era -> TxBody TopTx era -> Value era
forall era (t :: TxLevel).
EraUTxO era =>
PParams era
-> CertState era -> UTxO era -> TxBody t era -> Value era
forall (t :: TxLevel).
PParams era
-> CertState era -> UTxO era -> TxBody t era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo (Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL)
    producedValue = PParams era -> CertState era -> TxBody TopTx era -> Value era
forall era (l :: TxLevel).
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> TxBody l era -> Value era
produced PParams era
pp CertState era
certState (Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL)
    ensureNonNegativeCoin p
v
      | (Integer -> Integer -> Bool) -> p -> p -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=) p
forall t. Val t => t
zero p
v = p -> ImpM t p
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure p
v
      | Bool
otherwise = do
          Doc AnsiStyle -> ImpM t ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpM t ()) -> Doc AnsiStyle -> ImpM t ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Failed to validate coin: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> p -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr p
v
          p -> ImpM t p
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure p
forall t. Val t => t
zero
  logString "Validating changeBeforeFee"
  changeBeforeFee <- ensureNonNegativeCoin $ coin consumedValue <-> coin producedValue
  logToExpr changeBeforeFee
  let
    changeBeforeFeeTxOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
changeBeforeFee)
    txNoWits = Tx TopTx era
tx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut era) -> TxOut era -> StrictSeq (TxOut era)
forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeBeforeFeeTxOut)
    outsBeforeFee = Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody TopTx era
    -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx era) (StrictSeq (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era)
 -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
-> TxBody TopTx era
-> Const (StrictSeq (TxOut era)) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
    suppliedFee = Tx TopTx era
txOriginal Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL
    fee0
      | Coin
suppliedFee Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
forall t. Val t => t
zero = UTxO era
-> PParams era -> Tx TopTx era -> Set (KeyHash Witness) -> Coin
forall era.
(EraUTxO era, EraCertState era) =>
UTxO era
-> PParams era -> Tx TopTx era -> Set (KeyHash Witness) -> Coin
calcMinFeeTxNativeScriptWits UTxO era
utxo PParams era
pp Tx TopTx era
txNoWits Set (KeyHash Witness)
nativeScriptKeyWits
      | Bool
otherwise = Coin
suppliedFee
    fee = Rational -> Coin
rationalToCoinViaCeiling (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$ Coin -> Rational
coinToRational Coin
fee0 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Integer
11 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10)
  logString "Validating change"
  change <- ensureNonNegativeCoin $ changeBeforeFeeTxOut ^. coinTxOutL <-> fee
  logToExpr change
  let
    changeTxOut = TxOut era
changeBeforeFeeTxOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL ((Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era))
-> Coin -> TxOut era -> TxOut era
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
      | Coin
change Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
changeTxOut =
          Tx TopTx era
txNoWits
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (StrictSeq (TxOut era)
outsBeforeFee StrictSeq (TxOut era) -> TxOut era -> StrictSeq (TxOut era)
forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeTxOut)
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Coin -> Identity Coin)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Coin -> Identity Coin)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Coin -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
      | Bool
otherwise =
          Tx TopTx era
txNoWits
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
outsBeforeFee
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Coin -> Identity Coin)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Coin -> Identity Coin)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Coin -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
fee Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
change)
  pure txWithFee

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

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

impShelleyExpectTxSuccess ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  Tx TopTx era ->
  ImpTestM era ()
impShelleyExpectTxSuccess :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era ()
impShelleyExpectTxSuccess Tx TopTx era
tx = do
  utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  let inputs = Tx TopTx era
tx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL
      outputs = Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxIn (TxOut era) -> [(TxIn, TxOut era)])
-> (TxBody TopTx era -> Map TxIn (TxOut era))
-> TxBody TopTx era
-> [(TxIn, TxOut era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO era -> Map TxIn (TxOut era))
-> (TxBody TopTx era -> UTxO era)
-> TxBody TopTx era
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody TopTx era -> UTxO era
forall era (l :: TxLevel).
EraTxBody era =>
TxBody l era -> UTxO era
txouts (TxBody TopTx era -> [(TxIn, TxOut era)])
-> TxBody TopTx era -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
  impAnn "Inputs should be gone from UTxO" $
    expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs]
  impAnn "Outputs should be in UTxO" $
    expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs]

logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx TopTx era -> ImpTestM era ()
logFeeMismatch :: forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx TopTx era -> ImpTestM era ()
logFeeMismatch Tx TopTx era
tx = do
  pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  utxo <- getsNES utxoL
  let Coin feeUsed = tx ^. bodyTxL . feeTxBodyL
      Coin feeMin = getMinFeeTxUtxo pp tx utxo
  when (feeUsed /= feeMin) $ do
    logDoc $
      "Estimated fee " <> ansiExpr feeUsed <> " while required fee is " <> ansiExpr feeMin

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

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

trySubmitTx ::
  forall era.
  ( ShelleyEraImp era
  , HasCallStack
  ) =>
  Tx TopTx era ->
  ImpTestM
    era
    (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era))
trySubmitTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitTx Tx TopTx era
tx = do
  txFixed <- (ImpTestEnv era -> Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpM
     (LedgerSpec era) (Tx TopTx era -> ImpTestM era (Tx TopTx era))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
ImpTestEnv era -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
iteFixup ImpM (LedgerSpec era) (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
    -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx)
  logToExpr txFixed
  st <- gets impNES
  lEnv <- impLedgerEnv st
  ImpTestState {impRootTxIn} <- get
  res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed
  globals <- use impGlobalsL
  let trc = (Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
-> TRC (EraRule "LEDGER" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (EraRule "LEDGER" era)
lEnv, NewEpochState era
st NewEpochState era
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
-> LedgerState era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (LedgerState era) (EpochState era))
-> NewEpochState era -> Const (LedgerState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (LedgerState era) (EpochState era))
 -> NewEpochState era
 -> Const (LedgerState era) (NewEpochState era))
-> ((LedgerState era -> Const (LedgerState era) (LedgerState era))
    -> EpochState era -> Const (LedgerState era) (EpochState era))
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (LedgerState era) (LedgerState era))
-> EpochState era -> Const (LedgerState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL, Tx TopTx era
Signal (EraRule "LEDGER" era)
txFixed)

  -- Check for conformance
  asks itePostSubmitTxHook >>= (\forall t.
Globals
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> ImpM t ()
f -> Globals
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> ImpM (LedgerSpec era) ()
forall t.
Globals
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> ImpM t ()
f Globals
globals TRC (EraRule "LEDGER" era)
trc Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
res)

  case res of
    Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures -> do
      -- Verify that produced predicate failures are ready for the node-to-client protocol
      IO () -> ImpM (LedgerSpec era) ()
forall a. IO a -> ImpM (LedgerSpec era) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ImpM (LedgerSpec era) ())
-> IO () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> (PredicateFailure (EraRule "LEDGER" era) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures ((PredicateFailure (EraRule "LEDGER" era) -> IO ()) -> IO ())
-> (PredicateFailure (EraRule "LEDGER" era) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> IO ()
roundTripEraExpectation @era
      Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
  (Tx TopTx era)
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
   (Tx TopTx era)
 -> ImpM
      (LedgerSpec era)
      (Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
         (Tx TopTx era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
     (Tx TopTx era)
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
     (Tx TopTx era)
forall a b. a -> Either a b
Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx TopTx era
txFixed)
    Right (State (EraRule "LEDGER" era)
st', [Event (EraRule "LEDGER" era)]
events) -> do
      let txId :: TxId
txId = SafeHash EraIndependentTxBody -> TxId
TxId (SafeHash EraIndependentTxBody -> TxId)
-> (TxBody TopTx era -> SafeHash EraIndependentTxBody)
-> TxBody TopTx era
-> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (TxBody TopTx era -> TxId) -> TxBody TopTx era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
txFixed Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
          outsSize :: Int
outsSize = StrictSeq (TxOut era) -> Int
forall a. StrictSeq a -> Int
SSeq.length (StrictSeq (TxOut era) -> Int) -> StrictSeq (TxOut era) -> Int
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
txFixed Tx TopTx era
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody TopTx era
    -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx era) (StrictSeq (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era)
 -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
-> TxBody TopTx era
-> Const (StrictSeq (TxOut era)) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
          rootIndex :: Int
rootIndex
            | Int
outsSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int
outsSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            | Bool
otherwise = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"Expected at least 1 output after submitting tx: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TxId -> [Char]
forall a. Show a => a -> [Char]
show TxId
txId)
      [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([SomeSTSEvent era] -> ImpM (LedgerSpec era) ())
-> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (Event (EraRule "LEDGER" era) -> SomeSTSEvent era)
-> [Event (EraRule "LEDGER" era)] -> [SomeSTSEvent era]
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
      (ImpTestState era -> ImpTestState era) -> ImpM (LedgerSpec era) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ImpTestState era -> ImpTestState era)
 -> ImpM (LedgerSpec era) ())
-> (ImpTestState era -> ImpTestState era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (NewEpochState era -> Identity (NewEpochState era))
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ImpTestState era -> f (ImpTestState era)
impNESL ((NewEpochState era -> Identity (NewEpochState era))
 -> ImpTestState era -> Identity (ImpTestState era))
-> ((LedgerState era -> Identity (LedgerState era))
    -> NewEpochState era -> Identity (NewEpochState era))
-> (LedgerState era -> Identity (LedgerState era))
-> ImpTestState era
-> Identity (ImpTestState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((LedgerState era -> Identity (LedgerState era))
    -> EpochState era -> Identity (EpochState era))
-> (LedgerState era -> Identity (LedgerState era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> ImpTestState era -> Identity (ImpTestState era))
-> LedgerState era -> ImpTestState era -> ImpTestState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ State (EraRule "LEDGER" era)
LedgerState era
st'
      UTxO utxo <- ImpTestM era (UTxO era)
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 = TxId -> TxIx -> TxIn
TxIn TxId
txId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rootIndex))
      let newRoot
            | TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
assumedNewRoot Map TxIn (TxOut era)
utxo = TxIn
assumedNewRoot
            | TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
impRootTxIn Map TxIn (TxOut era)
utxo = TxIn
impRootTxIn
            | Bool
otherwise = [Char] -> TxIn
forall a. HasCallStack => [Char] -> a
error [Char]
"Root not found in UTxO"
      impRootTxInL .= newRoot
      expectTxSuccess txFixed
      pure $ Right txFixed

-- | 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 TopTx era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx = Tx TopTx era
-> (Tx TopTx era
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> (Tx TopTx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx TopTx era
tx ((Tx TopTx era
  -> ImpM
       (LedgerSpec era)
       (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
 -> ImpM (LedgerSpec era) ())
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> Tx TopTx era
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpM
  (LedgerSpec era)
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> Tx TopTx era
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
forall a b. a -> b -> a
const (ImpM
   (LedgerSpec era)
   (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
 -> Tx TopTx era
 -> ImpM
      (LedgerSpec era)
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> Tx TopTx era
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
forall a. a -> ImpM (LedgerSpec era) a
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 TopTx era ->
  (Tx TopTx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) ->
  ImpTestM era ()
submitFailingTxM :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> (Tx TopTx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx TopTx era
tx Tx TopTx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures = do
  (predFailures, fixedUpTx) <- Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
  (Tx TopTx era)
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
forall b a (m :: * -> *).
(HasCallStack, ToExpr b, NFData a, MonadIO m) =>
Either a b -> m a
expectLeftDeepExpr (Either
   (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
   (Tx TopTx era)
 -> ImpM
      (LedgerSpec era)
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitTx Tx TopTx era
tx
  expectedFailures <- mkExpectedFailures fixedUpTx
  predFailures `shouldBeExpr` 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 = (Environment (EraRule rule era), State (EraRule rule era),
 Signal (EraRule rule era))
-> TRC (EraRule rule era)
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
        }
  ShelleyBase
  (Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (EventReturnType
        'EventPolicyReturn (EraRule rule era) (State (EraRule rule era))))
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (EventReturnType
           'EventPolicyReturn (EraRule rule era) (State (EraRule rule era))))
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 RuleContext 'Transition (EraRule rule era)
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)
env State (EraRule rule era)
st Signal (EraRule rule era)
sig = do
  let ruleName :: [Char]
ruleName = Proxy rule -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @rule)
  (res, 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)
env State (EraRule rule era)
st Signal (EraRule rule era)
sig ImpM
  (LedgerSpec era)
  (Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (State (EraRule rule era), [Event (EraRule rule era)]))
-> (Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (State (EraRule rule era), [Event (EraRule rule era)])
    -> ImpM
         (LedgerSpec era)
         (State (EraRule rule era), [Event (EraRule rule era)]))
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left NonEmpty (PredicateFailure (EraRule rule era))
fs ->
        [Char]
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure ([Char]
 -> ImpM
      (LedgerSpec era)
      (State (EraRule rule era), [Event (EraRule rule era)]))
-> [Char]
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
            ([Char]
"Failed to run " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
ruleName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":") [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PredicateFailure (EraRule rule era) -> [Char])
-> [PredicateFailure (EraRule rule era)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PredicateFailure (EraRule rule era) -> [Char]
forall a. Show a => a -> [Char]
show (NonEmpty (PredicateFailure (EraRule rule era))
-> [PredicateFailure (EraRule rule era)]
forall a. NonEmpty a -> [a]
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 -> (State (EraRule rule era), [Event (EraRule rule era)])
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (State (EraRule rule era), [Event (EraRule rule era)])
res
  tell $ fmap (SomeSTSEvent @era @rule) ev
  pure res

-- | Runs the TICK rule once
passTick ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era ()
passTick :: forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick = do
  impCurSlotNo <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> SlotNo
forall era. ImpTestState era -> SlotNo
impCurSlotNo
  curNES <- getsNES id
  nes <- runImpRule @"TICK" () curNES impCurSlotNo
  impCurSlotNoL += 1
  impNESL .= nes

-- | Win with supplied probability
drawBoolWithProbability ::
  HasStatefulGen g m =>
  -- | Probability with which this action should produce `True`
  UnitInterval ->
  m Bool
drawBoolWithProbability :: forall g (m :: * -> *).
HasStatefulGen g m =>
UnitInterval -> m Bool
drawBoolWithProbability UnitInterval
probability = do
  let p :: Rational
p = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
probability
  n <- (Integer, Integer) -> m Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
1, Rational -> Integer
forall a. Ratio a -> a
denominator Rational
p)
  pure (n <= numerator p)

-- | 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
  globals <- Getting Globals (ImpTestState era) Globals
-> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL
  preNES <- gets impNES
  let
    curEpochNo = NewEpochState era
preNES NewEpochState era
-> Getting EpochNo (NewEpochState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
    ticksPerSlot =
      PositiveUnitInterval -> UnitInterval
positiveUnitIntervalRelaxToUnitInterval (ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal (Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals))
    tickUntilNewEpoch = do
      tickHasBlock <- UnitInterval -> ImpM (LedgerSpec era) Bool
forall g (m :: * -> *).
HasStatefulGen g m =>
UnitInterval -> m Bool
drawBoolWithProbability UnitInterval
ticksPerSlot
      if tickHasBlock
        then do
          oldNES <- getsNES id
          passTick @era
          newEpochNo <- getsNES nesELL
          if newEpochNo > curEpochNo
            then do
              newNES <- getsNES id
              asks itePostEpochBoundaryHook >>= (\forall t.
Globals
-> TRC (EraRule "NEWEPOCH" era)
-> State (EraRule "NEWEPOCH" era)
-> ImpM t ()
f -> Globals
-> TRC (EraRule "NEWEPOCH" era)
-> State (EraRule "NEWEPOCH" era)
-> ImpM (LedgerSpec era) ()
forall t.
Globals
-> TRC (EraRule "NEWEPOCH" era)
-> State (EraRule "NEWEPOCH" era)
-> ImpM t ()
f Globals
globals ((Environment (EraRule "NEWEPOCH" era),
 State (EraRule "NEWEPOCH" era), Signal (EraRule "NEWEPOCH" era))
-> TRC (EraRule "NEWEPOCH" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "NEWEPOCH" era)
oldNES, EpochNo
Signal (EraRule "NEWEPOCH" era)
newEpochNo)) State (EraRule "NEWEPOCH" era)
newNES)
            else tickUntilNewEpoch
        else do
          impCurSlotNoL += 1
          tickUntilNewEpoch
  logDoc $ "Entering " <> ansiExpr (succ curEpochNo)
  tickUntilNewEpoch
  gets impNES >>= epochBoundaryCheck preNES

epochBoundaryCheck ::
  (EraTxOut era, EraGov era, HasCallStack, EraCertState era) =>
  NewEpochState era ->
  NewEpochState era ->
  ImpTestM era ()
epochBoundaryCheck :: forall era.
(EraTxOut era, EraGov era, HasCallStack, EraCertState era) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
preNES NewEpochState era
postNES = do
  [Char] -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Checking ADA preservation at the epoch boundary" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
    let preSum :: Coin
preSum = NewEpochState era -> Coin
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era, EraGov era, EraCertState era) =>
NewEpochState era -> Coin
tot NewEpochState era
preNES
        postSum :: Coin
postSum = NewEpochState era -> Coin
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era, EraGov era, EraCertState era) =>
NewEpochState era -> Coin
tot NewEpochState era
postNES
    Doc AnsiStyle -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpM (LedgerSpec era) ())
-> Doc AnsiStyle -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> Doc AnsiStyle
forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Coin
preSum Coin
postSum
    Bool -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Coin
preSum Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
postSum) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ([Char] -> ImpM (LedgerSpec era) ())
-> [Char]
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImpM (LedgerSpec era) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => [Char] -> m ()
expectationFailure ([Char] -> ImpM (LedgerSpec era) ())
-> [Char] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"Total ADA in the epoch state is not preserved\n\tpost - pre = "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Coin -> [Char]
forall a. Show a => a -> [Char]
show (Coin
postSum Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
preSum)
  where
    tot :: NewEpochState era -> Coin
tot NewEpochState era
nes =
      Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
(<+>)
        (AdaPots -> Coin
sumAdaPots (EpochState era -> AdaPots
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES (NewEpochState era
nes NewEpochState era
-> Getting (EpochState era) (NewEpochState era) (EpochState era)
-> EpochState era
forall s a. s -> Getting a s a -> a
^. Getting (EpochState era) (NewEpochState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL)))
        (NewEpochState era
nes NewEpochState era -> Getting Coin (NewEpochState era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const Coin (EpochState era))
-> NewEpochState era -> Const Coin (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const Coin (EpochState era))
 -> NewEpochState era -> Const Coin (NewEpochState era))
-> ((Coin -> Const Coin Coin)
    -> EpochState era -> Const Coin (EpochState era))
-> Getting Coin (NewEpochState era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const Coin (LedgerState era))
-> EpochState era -> Const Coin (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const Coin (LedgerState era))
 -> EpochState era -> Const Coin (EpochState era))
-> ((Coin -> Const Coin Coin)
    -> LedgerState era -> Const Coin (LedgerState era))
-> (Coin -> Const Coin Coin)
-> EpochState era
-> Const Coin (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const Coin (UTxOState era))
-> LedgerState era -> Const Coin (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const Coin (UTxOState era))
 -> LedgerState era -> Const Coin (LedgerState era))
-> ((Coin -> Const Coin Coin)
    -> UTxOState era -> Const Coin (UTxOState era))
-> (Coin -> Const Coin Coin)
-> LedgerState era
-> Const Coin (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> UTxOState era -> Const Coin (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
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 =
  [Char] -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn ([Char]
"Passing " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" epochs") (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
    [Natural]
-> (Natural -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Natural
Item [Natural]
1 .. Natural
Item [Natural]
n] :: [Natural]) ((Natural -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ())
-> (Natural -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Natural
i ->
      [Char] -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn ([Char]
"Passing epoch (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
i [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")") (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) ()
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 =
  Int -> ImpTestM era () -> ImpTestM era ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ ImpTestM era ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch ImpTestM era () -> ImpTestM era () -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) b
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 = CallStack -> Doc AnsiStyle -> ImpM t ()
forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
CallStack
?callStack (Doc AnsiStyle -> ImpM t ())
-> (a -> Doc AnsiStyle) -> a -> ImpM t ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Doc AnsiStyle
ansiWlExpr (Expr -> Doc AnsiStyle) -> (a -> Expr) -> a -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Expr
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
  e <- ImpTestM era a
action
  logWithCallStack ?callStack . ansiWlExpr . toExpr $ e
  pure e

-- | Creates a fresh @SafeHash@
freshSafeHash :: ImpTestM era (SafeHash a)
freshSafeHash :: forall era a. ImpTestM era (SafeHash a)
freshSafeHash = ImpM (LedgerSpec era) (SafeHash a)
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 = ImpM (LedgerSpec era) (VRFVerKeyHash r)
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 = VKey r -> KeyHash r
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey r
vk
  (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((s -> s) -> m ()) -> (s -> s) -> m ()
forall a b. (a -> b) -> a -> b
$ (Map (KeyHash Witness) (KeyPair Witness)
 -> Identity (Map (KeyHash Witness) (KeyPair Witness)))
-> s -> Identity s
forall t.
HasKeyPairs t =>
Lens' t (Map (KeyHash Witness) (KeyPair Witness))
Lens' s (Map (KeyHash Witness) (KeyPair Witness))
keyPairsL ((Map (KeyHash Witness) (KeyPair Witness)
  -> Identity (Map (KeyHash Witness) (KeyPair Witness)))
 -> s -> Identity s)
-> (Map (KeyHash Witness) (KeyPair Witness)
    -> Map (KeyHash Witness) (KeyPair Witness))
-> s
-> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash Witness
-> KeyPair Witness
-> Map (KeyHash Witness) (KeyPair Witness)
-> Map (KeyHash Witness) (KeyPair Witness)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (KeyHash r -> KeyHash Witness
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash r
keyHash) (KeyPair r -> KeyPair Witness
forall a b. Coercible a b => a -> b
coerce KeyPair r
keyPair)
  KeyHash r -> m (KeyHash r)
forall a. a -> m a
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.
getKeyPair ::
  (HasCallStack, HasKeyPairs s, MonadState s m) =>
  KeyHash r ->
  m (KeyPair r)
getKeyPair :: forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
getKeyPair KeyHash r
keyHash = do
  keyPairs <- Getting
  (Map (KeyHash Witness) (KeyPair Witness))
  s
  (Map (KeyHash Witness) (KeyPair Witness))
-> m (Map (KeyHash Witness) (KeyPair Witness))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map (KeyHash Witness) (KeyPair Witness))
  s
  (Map (KeyHash Witness) (KeyPair Witness))
forall t.
HasKeyPairs t =>
Lens' t (Map (KeyHash Witness) (KeyPair Witness))
Lens' s (Map (KeyHash Witness) (KeyPair Witness))
keyPairsL
  case Map.lookup (asWitness keyHash) keyPairs of
    Just KeyPair Witness
keyPair -> KeyPair r -> m (KeyPair r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyPair r -> m (KeyPair r)) -> KeyPair r -> m (KeyPair r)
forall a b. (a -> b) -> a -> b
$ KeyPair Witness -> KeyPair r
forall a b. Coercible a b => a -> b
coerce KeyPair Witness
keyPair
    Maybe (KeyPair Witness)
Nothing ->
      [Char] -> m (KeyPair r)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (KeyPair r)) -> [Char] -> m (KeyPair r)
forall a b. (a -> b) -> a -> b
$
        [Char]
"Could not find a keypair corresponding to: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ KeyHash r -> [Char]
forall a. Show a => a -> [Char]
show KeyHash r
keyHash
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\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 `getKeyPair` to look up the `KeyPair` corresponding to the `KeyHash`
freshKeyHash ::
  forall r s g m.
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r)
freshKeyHash :: forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash = (KeyHash r, KeyPair r) -> KeyHash r
forall a b. (a, b) -> a
fst ((KeyHash r, KeyPair r) -> KeyHash r)
-> m (KeyHash r, KeyPair r) -> m (KeyHash r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (KeyHash r, KeyPair r)
forall (r :: KeyRole) s g (m :: * -> *).
(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 ::
  forall r s g m.
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
  m (KeyHash r, KeyPair r)
freshKeyPair :: forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair = do
  keyPair <- m (KeyPair r)
forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  keyHash <- addKeyPair keyPair
  pure (keyHash, 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, MonadGen m) => m Addr
freshKeyAddr_ :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ = (KeyHash Payment, Addr) -> Addr
forall a b. (a, b) -> b
snd ((KeyHash Payment, Addr) -> Addr)
-> m (KeyHash Payment, Addr) -> m Addr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (KeyHash Payment, Addr)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash Payment, 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, MonadGen m) =>
  m (KeyHash Payment, Addr)
freshKeyAddr :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash Payment, Addr)
freshKeyAddr = do
  paymentKeyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment
  stakingKeyHash <-
    oneof
      [Just . mkStakeRef <$> freshKeyHash @Staking, Just . mkStakeRef @Ptr <$> arbitrary, pure Nothing]
  pure (paymentKeyHash, mkAddr paymentKeyHash stakingKeyHash)

-- | Looks up the keypair corresponding to the `BootstrapAddress`. The `BootstrapAddress`
-- must be created with `freshBootstrapAddess` for this to work.
getByronKeyPair ::
  (HasCallStack, HasKeyPairs s, MonadState s m) =>
  BootstrapAddress ->
  m ByronKeyPair
getByronKeyPair :: forall s (m :: * -> *).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
BootstrapAddress -> m ByronKeyPair
getByronKeyPair BootstrapAddress
bootAddr = do
  keyPairs <- Getting
  (Map BootstrapAddress ByronKeyPair)
  s
  (Map BootstrapAddress ByronKeyPair)
-> m (Map BootstrapAddress ByronKeyPair)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map BootstrapAddress ByronKeyPair)
  s
  (Map BootstrapAddress ByronKeyPair)
forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
Lens' s (Map BootstrapAddress ByronKeyPair)
keyPairsByronL
  case Map.lookup bootAddr keyPairs of
    Just ByronKeyPair
keyPair -> ByronKeyPair -> m ByronKeyPair
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByronKeyPair
keyPair
    Maybe ByronKeyPair
Nothing ->
      [Char] -> m ByronKeyPair
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ByronKeyPair) -> [Char] -> m ByronKeyPair
forall a b. (a -> b) -> a -> b
$
        [Char]
"Could not find a keypair corresponding to: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BootstrapAddress -> [Char]
forall a. Show a => a -> [Char]
show BootstrapAddress
bootAddr
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\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 `getByronKeyPair` 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 = KeyHash Payment -> KeyHash r
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (KeyHash Payment -> KeyHash r)
-> (BootstrapAddress -> KeyHash Payment)
-> BootstrapAddress
-> KeyHash r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BootstrapAddress -> KeyHash Payment
bootstrapKeyHash (BootstrapAddress -> KeyHash r)
-> m BootstrapAddress -> m (KeyHash r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m BootstrapAddress
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 verificationKey _) <- m ByronKeyPair
forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  hasPayload <- uniformM
  payload <-
    if hasPayload
      then Just . Byron.HDAddressPayload <$> (uniformByteStringM =<< uniformRM (0, 63))
      else pure Nothing
  let asd = VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
verificationKey
      attrs = Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes Maybe HDAddressPayload
payload (Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
0)
      bootAddr = Address -> BootstrapAddress
BootstrapAddress (Address -> BootstrapAddress) -> Address -> BootstrapAddress
forall a b. (a -> b) -> a -> b
$ AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress AddrSpendingData
asd AddrAttributes
attrs
  modify $ keyPairsByronL %~ Map.insert bootAddr keyPair
  pure bootAddr

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

sendCoinTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era ()
sendCoinTo_ :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era ()
sendCoinTo_ Addr
addr = ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ())
-> (Coin -> ImpM (LedgerSpec era) TxIn)
-> Coin
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr

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 <-
    [Char] -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTxAnn
      ([Char]
"Giving " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value era -> [Char]
forall a. Show a => a -> [Char]
show Value era
amount [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Addr -> [Char]
forall a. Show a => a -> [Char]
show Addr
addr)
      (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
        Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
amount)
  pure $ txInAt 0 tx

sendValueTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Value era -> ImpTestM era ()
sendValueTo_ :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Value era -> ImpTestM era ()
sendValueTo_ Addr
addr = ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ())
-> (Value era -> ImpM (LedgerSpec era) TxIn)
-> Value era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Value era -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Value era -> ImpTestM era TxIn
sendValueTo Addr
addr

-- | 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 = ((NewEpochState era -> Identity (NewEpochState era))
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ImpTestState era -> f (ImpTestState era)
impNESL ((NewEpochState era -> Identity (NewEpochState era))
 -> ImpTestState era -> Identity (ImpTestState era))
-> (NewEpochState era -> NewEpochState era)
-> ImpM (LedgerSpec era) ()
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 = (ImpTestState era -> a) -> ImpM (LedgerSpec era) a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((ImpTestState era -> a) -> ImpM (LedgerSpec era) a)
-> (Getting a (ImpTestState era) a -> ImpTestState era -> a)
-> Getting a (ImpTestState era) a
-> ImpM (LedgerSpec era) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting a (ImpTestState era) a -> ImpTestState era -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting a (ImpTestState era) a -> ImpM (LedgerSpec era) a)
-> Getting a (ImpTestState era) a -> ImpM (LedgerSpec era) a
forall a b. (a -> b) -> a -> b
$ (NewEpochState era -> Const a (NewEpochState era))
-> ImpTestState era -> Const a (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ImpTestState era -> f (ImpTestState era)
impNESL ((NewEpochState era -> Const a (NewEpochState era))
 -> ImpTestState era -> Const a (ImpTestState era))
-> ((a -> Const a a)
    -> NewEpochState era -> Const a (NewEpochState era))
-> Getting a (ImpTestState era) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a)
-> NewEpochState era -> Const a (NewEpochState era)
SimpleGetter (NewEpochState era) a
l

getUTxO :: ImpTestM era (UTxO era)
getUTxO :: forall era. ImpTestM era (UTxO era)
getUTxO = SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL

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

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

submitTxAnn_ ::
  (HasCallStack, ShelleyEraImp era) => String -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ :: forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ [Char]
msg = ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ())
-> (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> Tx TopTx era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTxAnn [Char]
msg

getRewardAccountFor ::
  Credential Staking ->
  ImpTestM era RewardAccount
getRewardAccountFor :: forall era. Credential Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential Staking
stakingC = do
  networkId <- Getting Network (ImpTestState era) Network
-> ImpM (LedgerSpec era) Network
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Globals -> Const Network Globals)
-> ImpTestState era -> Const Network (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const Network Globals)
 -> ImpTestState era -> Const Network (ImpTestState era))
-> ((Network -> Const Network Network)
    -> Globals -> Const Network Globals)
-> Getting Network (ImpTestState era) Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> Network) -> SimpleGetter Globals Network
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  pure $ RewardAccount networkId 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
  regTxCert <- Credential Staking -> ImpM (LedgerSpec era) (TxCert era)
forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era (TxCert era)
genRegTxCert Credential Staking
cred
  submitTxAnn_ ("Register Reward Account: " <> T.unpack (credToText cred)) $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList [regTxCert]
  networkId <- use (impGlobalsL . to networkId)
  pure $ RewardAccount networkId 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
  [Char] -> Tx TopTx era -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ ([Char]
"Delegate Staking Credential: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Credential Staking -> Text
forall (kr :: KeyRole). Credential kr -> Text
credToText Credential Staking
cred)) (Tx TopTx era -> ImpTestM era ())
-> Tx TopTx era -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
    TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
      Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Credential Staking -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraImp era =>
Credential Staking -> KeyHash StakePool -> TxCert era
delegStakeTxCert Credential Staking
cred KeyHash StakePool
poolKH]

expectStakeCredRegistered ::
  (HasCallStack, ShelleyEraImp era) =>
  Credential Staking ->
  ImpTestM era ()
expectStakeCredRegistered :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era ()
expectStakeCredRegistered Credential Staking
cred = do
  accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
  accountState <- expectJust $ lookupAccountState cred accounts
  impAnn (show cred <> " expected to be in Accounts with the correct deposit") $ do
    accountState ^. depositAccountStateL `shouldBe` compactCoinOrError expectedDeposit

expectStakeCredNotRegistered ::
  (HasCallStack, ShelleyEraImp era) =>
  Credential Staking ->
  ImpTestM era ()
expectStakeCredNotRegistered :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era ()
expectStakeCredNotRegistered Credential Staking
cred = do
  accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  impAnn (show cred <> " expected to not be in Accounts") $ do
    expectNothingExpr $ lookupAccountState cred accounts

expectDelegatedToPool ::
  (HasCallStack, ShelleyEraImp era) =>
  Credential Staking ->
  KeyHash StakePool ->
  ImpTestM era ()
expectDelegatedToPool :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> KeyHash StakePool -> ImpTestM era ()
expectDelegatedToPool Credential Staking
cred KeyHash StakePool
poolKh = do
  certState <- SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (CertState era)
 -> ImpTestM era (CertState era))
-> SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((CertState era -> Const r (CertState era))
    -> EpochState era -> Const r (EpochState era))
-> (CertState era -> Const r (CertState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((CertState era -> Const r (CertState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (CertState era -> Const r (CertState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
  let accounts = CertState era
certState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  let pools = CertState era
certState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
  impAnn (show cred <> " expected to have delegated to " <> show poolKh) $ do
    accountState <- expectJust $ lookupAccountState cred accounts
    accountState ^. stakePoolDelegationAccountStateL `shouldBe` Just poolKh
    case Map.lookup poolKh pools of
      Maybe StakePoolState
Nothing ->
        [Char] -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure ([Char] -> ImpM (LedgerSpec era) ())
-> [Char] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected stake pool state for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> KeyHash StakePool -> [Char]
forall a. Show a => a -> [Char]
show KeyHash StakePool
poolKh
      Just StakePoolState
poolState ->
        [Char] -> Bool -> ImpM (LedgerSpec era) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool
          ([Char]
"Expected pool delegations to contain the stake credential: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Credential Staking -> [Char]
forall a. Show a => a -> [Char]
show Credential Staking
cred)
          (Credential Staking
cred Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (StakePoolState
poolState StakePoolState
-> Getting
     (Set (Credential Staking))
     StakePoolState
     (Set (Credential Staking))
-> Set (Credential Staking)
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (Credential Staking))
  StakePoolState
  (Set (Credential Staking))
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL))

expectNotDelegatedToAnyPool ::
  (HasCallStack, ShelleyEraImp era) =>
  Credential Staking ->
  ImpTestM era ()
expectNotDelegatedToAnyPool :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era ()
expectNotDelegatedToAnyPool Credential Staking
cred = do
  certState <- SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (CertState era)
 -> ImpTestM era (CertState era))
-> SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((CertState era -> Const r (CertState era))
    -> EpochState era -> Const r (EpochState era))
-> (CertState era -> Const r (CertState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((CertState era -> Const r (CertState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (CertState era -> Const r (CertState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
  let accounts = CertState era
certState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  let pools = CertState era
certState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
  impAnn (show cred <> " expected to not have delegated to a stake pool") $ do
    forM_ (lookupAccountState cred accounts) $ \AccountState era
accountState ->
      Maybe (KeyHash StakePool) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
Maybe a -> m ()
expectNothingExpr (AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL)
    assertBool
      ("Expected no stake pool state delegation to contain the stake credential: " <> show cred)
      (all (Set.notMember cred . spsDelegators) pools)

expectNotDelegatedToPool ::
  (HasCallStack, ShelleyEraImp era) =>
  Credential Staking ->
  KeyHash StakePool ->
  ImpTestM era ()
expectNotDelegatedToPool :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> KeyHash StakePool -> ImpTestM era ()
expectNotDelegatedToPool Credential Staking
cred KeyHash StakePool
pool = do
  certState <- SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (CertState era)
 -> ImpTestM era (CertState era))
-> SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((CertState era -> Const r (CertState era))
    -> EpochState era -> Const r (EpochState era))
-> (CertState era -> Const r (CertState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((CertState era -> Const r (CertState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (CertState era -> Const r (CertState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
  let accounts = CertState era
certState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  let pools = CertState era
certState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
  impAnn (show cred <> " expected to not have delegated to a stake pool") $ do
    forM_ (lookupAccountState cred accounts) $ \AccountState era
accountState ->
      AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL Maybe (KeyHash StakePool)
-> Maybe (KeyHash StakePool) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldNotBe` KeyHash StakePool -> Maybe (KeyHash StakePool)
forall a. a -> Maybe a
Just KeyHash StakePool
pool
    assertBool
      ("Expected stake pool state delegation to not contain the stake credential: " <> show cred)
      (maybe True (Set.notMember cred . spsDelegators) (Map.lookup pool pools))

registerRewardAccount ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  ImpTestM era RewardAccount
registerRewardAccount :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount = ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) RewardAccount)
-> ImpM (LedgerSpec era) RewardAccount
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Credential Staking -> ImpM (LedgerSpec era) RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era RewardAccount
registerStakeCredential (Credential Staking -> ImpM (LedgerSpec era) RewardAccount)
-> (KeyHash Staking -> Credential Staking)
-> KeyHash Staking
-> ImpM (LedgerSpec era) RewardAccount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj

freshPoolParams ::
  ShelleyEraImp era =>
  KeyHash StakePool ->
  RewardAccount ->
  ImpTestM era StakePoolParams
freshPoolParams :: forall era.
ShelleyEraImp era =>
KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
khPool RewardAccount
rewardAccount = do
  vrfHash <- ImpTestM era (VRFVerKeyHash StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  let minCost = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL
  poolCostExtra <- uniformRM (Coin 0, Coin 100_000_000)
  pledge <- uniformRM (Coin 0, Coin 100_000_000)
  pure
    StakePoolParams
      { sppVrf = vrfHash
      , sppRewardAccount = rewardAccount
      , sppRelays = mempty
      , sppPledge = pledge
      , sppOwners = mempty
      , sppMetadata = SNothing
      , sppMargin = def
      , sppId = khPool
      , sppCost = minCost <> poolCostExtra
      }

registerPool ::
  ShelleyEraImp era =>
  KeyHash StakePool ->
  ImpTestM era ()
registerPool :: forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era ()
registerPool KeyHash StakePool
khPool = ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount ImpTestM era RewardAccount
-> (RewardAccount -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyHash StakePool -> RewardAccount -> ImpM (LedgerSpec era) ()
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
  pps <- KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
khPool RewardAccount
rewardAccount
  submitTxAnn_ "Registering a new stake pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert pps)

registerAndRetirePoolToMakeReward ::
  ShelleyEraImp era =>
  Credential Staking ->
  ImpTestM era ()
registerAndRetirePoolToMakeReward :: forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era ()
registerAndRetirePoolToMakeReward Credential Staking
stakingCred = do
  poolId <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  registerPoolWithRewardAccount poolId =<< getRewardAccountFor stakingCred
  passEpoch
  curEpochNo <- getsNES nesELL
  let poolLifetime = Word32
2
      poolExpiry = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
poolLifetime
  submitTxAnn_ "Retiring the temporary stake pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL .~ SSeq.singleton (RetirePoolTxCert poolId poolExpiry)
  passNEpochs $ fromIntegral poolLifetime

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

-- | Replace all fixup with the given function
withFixup ::
  (Tx TopTx era -> ImpTestM era (Tx TopTx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withFixup :: forall era a.
(Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx TopTx era -> ImpTestM era (Tx TopTx era)
f = ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
 -> Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
((Tx TopTx era -> ImpTestM era (Tx TopTx era))
 -> Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall a b. a -> b -> a
const Tx TopTx era -> ImpTestM era (Tx TopTx 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 = (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
(Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

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

-- | Apply given fixup function after the configured fixup
withPostFixup ::
  (Tx TopTx era -> ImpTestM era (Tx TopTx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPostFixup :: forall era a.
(Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup Tx TopTx era -> ImpTestM era (Tx TopTx era)
f = ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
 -> Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
((Tx TopTx era -> ImpTestM era (Tx TopTx era))
 -> Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
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 = ((TxIn, Maybe (TxOut era) -> Bool) -> ImpM (LedgerSpec era) ())
-> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((TxIn, Maybe (TxOut era) -> Bool) -> ImpM (LedgerSpec era) ())
 -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpM (LedgerSpec era) ())
-> ((TxIn, Maybe (TxOut era) -> Bool) -> ImpM (LedgerSpec era) ())
-> [(TxIn, Maybe (TxOut era) -> Bool)]
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn, Maybe (TxOut era) -> Bool
test) -> do
  let result :: Maybe (TxOut era)
result = TxIn
txIn TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo
  Bool -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TxOut era) -> Bool
test Maybe (TxOut era)
result) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> ImpM (LedgerSpec era) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => [Char] -> m ()
expectationFailure ([Char] -> ImpM (LedgerSpec era) ())
-> [Char] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"UTxO content failed predicate:\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TxIn -> [Char]
forall a. ToExpr a => a -> [Char]
ansiExprString TxIn
txIn [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe (TxOut era) -> [Char]
forall a. ToExpr a => a -> [Char]
ansiExprString Maybe (TxOut era)
result

expectRegisteredRewardAddress ::
  (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress :: forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress ra :: RewardAccount
ra@RewardAccount {Network
raNetwork :: RewardAccount -> Network
raNetwork :: Network
raNetwork, Credential Staking
raCredential :: RewardAccount -> Credential Staking
raCredential :: Credential Staking
raCredential} = do
  networkId <- Getting Network (ImpTestState era) Network
-> ImpM (LedgerSpec era) Network
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Globals -> Const Network Globals)
-> ImpTestState era -> Const Network (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const Network Globals)
 -> ImpTestState era -> Const Network (ImpTestState era))
-> ((Network -> Const Network Network)
    -> Globals -> Const Network Globals)
-> Getting Network (ImpTestState era) Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> Network) -> SimpleGetter Globals Network
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
  unless (raNetwork == networkId) $
    assertFailure $
      "Reward Account with an unexpected NetworkId: " ++ show ra
  accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
  unless (isAccountRegistered raCredential accounts) $
    assertFailure $
      "Expected account "
        ++ show ra
        ++ " to be registered, but it is not."

expectNotRegisteredRewardAddress ::
  (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress :: forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress ra :: RewardAccount
ra@RewardAccount {Network
raNetwork :: RewardAccount -> Network
raNetwork :: Network
raNetwork, Credential Staking
raCredential :: RewardAccount -> Credential Staking
raCredential :: Credential Staking
raCredential} = do
  accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  networkId <- use (impGlobalsL . to networkId)
  when (raNetwork == networkId && isAccountRegistered raCredential accounts) $
    assertFailure $
      "Expected account "
        ++ show ra
        ++ " to not be registered, but it is."

expectTreasury :: HasCallStack => Coin -> ImpTestM era ()
expectTreasury :: forall era. HasCallStack => Coin -> ImpTestM era ()
expectTreasury Coin
c =
  [Char] -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Checking treasury amount" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
    treasuryAmount <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (Coin -> Const r Coin)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) Coin
Lens' (NewEpochState era) Coin
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) Coin
treasuryL
    c `shouldBe` treasuryAmount

-- 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 = (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (UnitInterval -> Identity UnitInterval)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) UnitInterval
Lens' (PParams era) UnitInterval
ppTauL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)

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

impGetUTxO :: ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impGetUTxO :: forall era. ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era)
impGetUTxO TxIn
txIn = [Char]
-> ImpM (LedgerSpec era) (TxOut era)
-> ImpM (LedgerSpec era) (TxOut era)
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Looking up TxOut" (ImpM (LedgerSpec era) (TxOut era)
 -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (TxOut era)
-> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ do
  utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  case txinLookup txIn utxo of
    Just TxOut era
txOut -> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut era
txOut
    Maybe (TxOut era)
Nothing -> [Char] -> ImpM (LedgerSpec era) (TxOut era)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ImpM (LedgerSpec era) (TxOut era))
-> [Char] -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to get TxOut for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TxIn -> [Char]
forall a. Show a => a -> [Char]
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 = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
  let tx :: Tx TopTx era
tx =
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty)
  [Char] -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => [Char] -> ImpM t ()
logString ([Char] -> ImpM (LedgerSpec era) ())
-> [Char] -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Produced script: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> [Char]
forall a. Show a => a -> [Char]
show ScriptHash
scriptHash
  Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 (Tx TopTx era -> TxIn)
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTx Tx TopTx era
tx

advanceToPointOfNoReturn :: ImpTestM era ()
advanceToPointOfNoReturn :: forall era. ImpTestM era ()
advanceToPointOfNoReturn = do
  impCurSlotNo <- (ImpTestState era -> SlotNo) -> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> SlotNo
forall era. ImpTestState era -> SlotNo
impCurSlotNo
  (_, slotOfNoReturn, _) <- runShelleyBase $ getTheSlotOfNoReturn impCurSlotNo
  impCurSlotNoL .= slotOfNoReturn

-- | A legal ProtVer that differs in the minor Version
minorFollow :: ProtVer -> ProtVer
minorFollow :: ProtVer -> ProtVer
minorFollow (ProtVer Version
x Natural
y) = Version -> Natural -> ProtVer
ProtVer Version
x (Natural
y Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)

-- | A legal ProtVer that moves to the next major Version
majorFollow :: ProtVer -> ProtVer
majorFollow :: ProtVer -> ProtVer
majorFollow pv :: ProtVer
pv@(ProtVer Version
x Natural
_) = case Version -> Maybe Version
forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion Version
x of
  Just Version
x' -> Version -> Natural -> ProtVer
ProtVer Version
x' Natural
0
  Maybe Version
Nothing -> [Char] -> ProtVer
forall a. HasCallStack => [Char] -> a
error ([Char]
"The last major version can't be incremented. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProtVer -> [Char]
forall a. Show a => a -> [Char]
show ProtVer
pv)

-- | An illegal ProtVer that skips 3 minor versions
cantFollow :: ProtVer -> ProtVer
cantFollow :: ProtVer -> ProtVer
cantFollow (ProtVer Version
x Natural
y) = Version -> Natural -> ProtVer
ProtVer Version
x (Natural
y Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
3)

whenMajorVersion ::
  forall (v :: Natural) era.
  ( EraGov era
  , KnownNat v
  , MinVersion <= v
  , v <= MaxVersion
  ) =>
  ImpTestM era () ->
  ImpTestM era ()
whenMajorVersion :: forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersion ImpTestM era ()
a = do
  pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  when (pvMajor pv == natVersion @v) a

whenMajorVersionAtLeast ::
  forall (v :: Natural) era.
  ( EraGov era
  , KnownNat v
  , MinVersion <= v
  , v <= MaxVersion
  ) =>
  ImpTestM era () ->
  ImpTestM era ()
whenMajorVersionAtLeast :: forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast ImpTestM era ()
a = do
  pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  when (pvMajor pv >= natVersion @v) a

whenMajorVersionAtMost ::
  forall (v :: Natural) era.
  ( EraGov era
  , KnownNat v
  , MinVersion <= v
  , v <= MaxVersion
  ) =>
  ImpTestM era () ->
  ImpTestM era ()
whenMajorVersionAtMost :: forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost ImpTestM era ()
a = do
  pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  when (pvMajor pv <= natVersion @v) a

unlessMajorVersion ::
  forall (v :: Natural) era.
  ( EraGov era
  , KnownNat v
  , MinVersion <= v
  , v <= MaxVersion
  ) =>
  ImpTestM era () ->
  ImpTestM era ()
unlessMajorVersion :: forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
unlessMajorVersion ImpTestM era ()
a = do
  pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  unless (pvMajor pv == natVersion @v) a

getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams :: forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams Lens' (PParams era) a
f = SimpleGetter (NewEpochState era) a -> ImpTestM era a
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) a -> ImpTestM era a)
-> SimpleGetter (NewEpochState era) a -> ImpTestM era a
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((a -> Const r a) -> EpochState era -> Const r (EpochState era))
-> (a -> Const r a)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((a -> Const r a) -> PParams era -> Const r (PParams era))
-> (a -> Const r a)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const r a) -> PParams era -> Const r (PParams era)
Lens' (PParams era) a
f

-- | Runs a simulation action and then restores the ledger state to what it was
-- before the simulation started.
-- This is useful for testing or running actions whose effects on the ledger
-- state should not persist. The return value of the simulation is preserved,
-- but any changes to the internal state (e.g., the UTxO set, protocol parameters,
-- etc.) are discarded and replaced with the original snapshot.
simulateThenRestore ::
  ImpTestM era a ->
  ImpTestM era a
simulateThenRestore :: forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore ImpTestM era a
sim = do
  snapshot <- ImpM (LedgerSpec era) (ImpTestState era)
forall s (m :: * -> *). MonadState s m => m s
get
  result <- sim
  put snapshot
  pure result

shelleyGenRegTxCert ::
  ShelleyEraTxCert era =>
  Credential Staking ->
  ImpTestM era (TxCert era)
shelleyGenRegTxCert :: forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenRegTxCert = TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era -> ImpM (LedgerSpec era) (TxCert era))
-> (Credential Staking -> TxCert era)
-> Credential Staking
-> ImpM (LedgerSpec era) (TxCert era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
RegTxCert

shelleyGenUnRegTxCert ::
  ShelleyEraTxCert era =>
  Credential Staking ->
  ImpTestM era (TxCert era)
shelleyGenUnRegTxCert :: forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenUnRegTxCert = TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era -> ImpM (LedgerSpec era) (TxCert era))
-> (Credential Staking -> TxCert era)
-> Credential Staking
-> ImpM (LedgerSpec era) (TxCert era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
UnRegTxCert

shelleyDelegStakeTxCert ::
  ShelleyEraTxCert era =>
  Credential Staking ->
  KeyHash StakePool ->
  TxCert era
shelleyDelegStakeTxCert :: forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
shelleyDelegStakeTxCert Credential Staking
cred KeyHash StakePool
pool = Credential Staking -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
DelegStakeTxCert Credential Staking
cred KeyHash StakePool
pool