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

module Test.Cardano.Ledger.Shelley.ImpTest (
  ImpTestM,
  LedgerSpec,
  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,
  getRewardAccountFor,
  getReward,
  lookupReward,
  poolParams,
  registerPool,
  registerPoolWithRewardAccount,
  registerAndRetirePoolToMakeReward,
  getRewardAccountAmount,
  shelleyFixupTx,
  getImpRootTxOut,
  sendValueTo,
  sendValueTo_,
  sendCoinTo,
  sendCoinTo_,
  expectUTxOContent,
  expectRegisteredRewardAddress,
  expectNotRegisteredRewardAddress,
  expectTreasury,
  disableTreasuryExpansion,
  updateAddrTxWits,
  addNativeScriptTxWits,
  addRootTxIn,
  fixupTxOuts,
  fixupFees,
  fixupAuxDataHash,
  impLookupNativeScript,
  impGetUTxO,
  defaultInitNewEpochState,
  defaultInitImpTestState,
  impEraStartEpochNo,
  impSetSeed,
  modifyImpInitProtVer,
  modifyImpInitExpectLedgerRuleConformance,
  disableImpInitExpectLedgerRuleConformance,

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

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

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

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.UTxO as Byron (empty)
import Cardano.Ledger.Address (
  Addr (..),
  BootstrapAddress (..),
  RewardAccount (..),
  bootstrapKeyHash,
 )
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Block (Block)
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (..), credToText)
import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..))
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  asWitness,
  bootstrapWitKeyHash,
  makeBootstrapWitness,
  witVKeyHash,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo)
import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Genesis (
  ShelleyGenesis (..),
  describeValidationErr,
  fromNominalDiffTimeMicro,
  mkShelleyGlobals,
  validateGenesis,
 )
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  NewEpochState (..),
  curPParamsEpochStateL,
  epochStateUMapL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  prevPParamsEpochStateL,
  produced,
  utxosDonationL,
 )
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  LedgerEnv (..),
  ShelleyBbodyState,
  epochFromSlot,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext)
import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn)
import Cardano.Ledger.Tools (
  calcMinFeeTxNativeScriptWits,
  setMinCoinTxOut,
 )
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UMap as UMap
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader (..), asks)
import Control.Monad.State.Strict (MonadState (..), evalStateT, gets, modify)
import Control.Monad.Trans.Fail.String (errorFail)
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Writer.Class (MonadWriter (..))
import Control.State.Transition (STS (..), TRC (..), applySTSOptsEither)
import Control.State.Transition.Extended (
  ApplySTSOpts (..),
  AssertionPolicy (..),
  SingEP (..),
  ValidationPolicy (..),
 )
import Data.Bifunctor (first)
import Data.Coerce (coerce)
import Data.Data (Proxy (..), type (:~:) (..))
import Data.Default (Default (..))
import Data.Foldable (toList, traverse_)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Data.TreeDiff (ansiWlExpr)
import Data.Type.Equality (TestEquality (..))
import Data.Void
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Lens.Micro (Lens', SimpleGetter, lens, to, (%~), (&), (.~), (<>~), (^.))
import Lens.Micro.Mtl (use, view, (%=), (+=), (.=))
import Numeric.Natural (Natural)
import Prettyprinter (Doc)
import Prettyprinter.Render.Terminal (AnsiStyle)
import qualified System.Random.Stateful as R
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation)
import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), 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
    IOGenM QCGen
ioGen <- QCGen -> IO (IOGenM QCGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
R.newIOGenM QCGen
qcGen
    ImpTestState era
initState <- StateT ImpPrepState IO (ImpTestState era)
-> ImpPrepState -> IO (ImpTestState era)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT (IOGenM QCGen) (StateT ImpPrepState IO) (ImpTestState era)
-> IOGenM QCGen -> StateT ImpPrepState IO (ImpTestState era)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IOGenM QCGen) (StateT ImpPrepState IO) (ImpTestState era)
forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (ImpTestState era)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (ImpTestState era)
initImpTestState IOGenM QCGen
ioGen) (ImpPrepState
forall a. Monoid a => a
mempty :: ImpPrepState)
    ImpInit (LedgerSpec era) -> IO (ImpInit (LedgerSpec era))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImpInit (LedgerSpec era) -> IO (ImpInit (LedgerSpec era)))
-> ImpInit (LedgerSpec era) -> IO (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      ImpInit
        { impInitEnv :: ImpSpecEnv (LedgerSpec era)
impInitEnv =
            ImpTestEnv
              { iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = Tx era -> ImpTestM era (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx
              , iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
True
              , iteExpectLedgerRuleConformance :: forall t.
Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> ImpM t ()
iteExpectLedgerRuleConformance = \Globals
_ Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
_ LedgerEnv era
_ LedgerState era
_ Tx era
_ -> () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              }
        , impInitState :: ImpSpecState (LedgerSpec era)
impInitState = ImpSpecState (LedgerSpec era)
ImpTestState era
initState
        }

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

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

instance Eq (SomeSTSEvent era) where
  SomeSTSEvent Event (EraRule rule era)
x == :: SomeSTSEvent era -> SomeSTSEvent era -> Bool
== SomeSTSEvent Event (EraRule rule era)
y
    | Just Event (EraRule rule era) :~: Event (EraRule rule era)
Refl <- 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) = ConstructorName -> [Expr] -> Expr
App ConstructorName
"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
impLastTick :: !SlotNo
  , forall era. ImpTestState era -> Globals
impGlobals :: !Globals
  , forall era. ImpTestState era -> [SomeSTSEvent era]
impEvents :: [SomeSTSEvent era]
  }

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

instance Semigroup ImpPrepState where
  <> :: ImpPrepState -> ImpPrepState -> ImpPrepState
(<>) ImpPrepState
ips1 ImpPrepState
ips2 =
    ImpPrepState
      { impPrepKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs = ImpPrepState -> Map (KeyHash 'Witness) (KeyPair 'Witness)
impPrepKeyPairs ImpPrepState
ips1 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})

impLastTickL :: Lens' (ImpTestState era) SlotNo
impLastTickL :: forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> ImpTestState era -> f (ImpTestState era)
impLastTickL = (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
impLastTick (\ImpTestState era
x SlotNo
y -> ImpTestState era
x {impLastTick = y})

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

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
  ( ShelleyEraTxCert era
  , 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
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , -- For the LEDGER rule
    STS (EraRule "LEDGER" era)
  , BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , Signal (EraRule "LEDGER" era) ~ Tx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Show (PredicateFailure (EraRule "LEDGER" era))
  , ToExpr (PredicateFailure (EraRule "LEDGER" era))
  , NFData (PredicateFailure (EraRule "LEDGER" era))
  , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
  , DecCBOR (PredicateFailure (EraRule "LEDGER" era))
  , EraRuleEvent "LEDGER" era ~ Event (EraRule "LEDGER" era)
  , Eq (EraRuleEvent "LEDGER" era)
  , ToExpr (EraRuleEvent "LEDGER" era)
  , NFData (EraRuleEvent "LEDGER" era)
  , Typeable (EraRuleEvent "LEDGER" era)
  , -- For the TICK rule
    STS (EraRule "TICK" era)
  , BaseM (EraRule "TICK" era) ~ ShelleyBase
  , Signal (EraRule "TICK" era) ~ SlotNo
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Environment (EraRule "TICK" era) ~ ()
  , NFData (PredicateFailure (EraRule "TICK" era))
  , EraRuleEvent "TICK" era ~ Event (EraRule "TICK" era)
  , Eq (EraRuleEvent "TICK" era)
  , ToExpr (EraRuleEvent "TICK" era)
  , NFData (EraRuleEvent "TICK" era)
  , Typeable (EraRuleEvent "TICK" era)
  , ToExpr (PredicateFailure (EraRule "UTXOW" era))
  ) =>
  ShelleyEraImp era
  where
  initGenesis ::
    (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
    m (Genesis era)
  default initGenesis ::
    (Monad m, Genesis era ~ NoGenesis era) =>
    m (Genesis era)
  initGenesis = 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 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

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

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

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

-- | For debugging purposes we start the era at the epoch number that matches the starting
-- protocol version for the era times a 100
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo :: forall era. Era era => EpochNo
impEraStartEpochNo = Word64 -> EpochNo
EpochNo (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
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
  KeyHash 'Payment
rootKeyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment
  let
    rootAddr :: Addr
    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 :: 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 :: Coin
rootCoin = Integer -> Coin
Coin (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (ShelleyGenesis -> Word64
sgMaxLovelaceSupply ShelleyGenesis
shelleyGenesis))
    rootTxIn :: TxIn
    rootTxIn :: TxIn
rootTxIn = TxId -> TxIx -> TxIn
TxIn (Int -> TxId
mkTxId Int
0) TxIx
forall a. Bounded a => a
minBound
    nesWithRoot :: NewEpochState era
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)
  s
prepState <- m s
forall s (m :: * -> *). MonadState s m => m s
get
  let epochInfoE :: EpochInfo (Either Text)
epochInfoE =
        EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
          (ShelleyGenesis -> EpochSize
sgEpochLength 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 ShelleyGenesis
shelleyGenesis)
      globals :: Globals
globals = ShelleyGenesis -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals ShelleyGenesis
shelleyGenesis EpochInfo (Either Text)
epochInfoE
      epochNo :: EpochNo
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 :: SlotNo
slotNo = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo
  ImpTestState era -> m (ImpTestState era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImpTestState era -> m (ImpTestState era))
-> ImpTestState era -> m (ImpTestState era)
forall a b. (a -> b) -> a -> b
$
    ImpTestState
      { impNES :: NewEpochState era
impNES = NewEpochState era
nesWithRoot
      , impRootTxIn :: TxIn
impRootTxIn = TxIn
rootTxIn
      , impKeyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
impKeyPairs = s
prepState s
-> Getting
     (Map (KeyHash 'Witness) (KeyPair 'Witness))
     s
     (Map (KeyHash 'Witness) (KeyPair 'Witness))
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall s a. s -> Getting a s a -> a
^. 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
      , impByronKeyPairs :: Map BootstrapAddress ByronKeyPair
impByronKeyPairs = s
prepState s
-> Getting
     (Map BootstrapAddress ByronKeyPair)
     s
     (Map BootstrapAddress ByronKeyPair)
-> Map BootstrapAddress ByronKeyPair
forall s a. s -> Getting a s a -> a
^. Getting
  (Map BootstrapAddress ByronKeyPair)
  s
  (Map BootstrapAddress ByronKeyPair)
forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
Lens' s (Map BootstrapAddress ByronKeyPair)
keyPairsByronL
      , impNativeScripts :: Map ScriptHash (NativeScript era)
impNativeScripts = Map ScriptHash (NativeScript era)
forall a. Monoid a => a
mempty
      , impLastTick :: SlotNo
impLastTick = SlotNo
slotNo
      , impGlobals :: Globals
impGlobals = Globals
globals
      , impEvents :: [SomeSTSEvent era]
impEvents = [SomeSTSEvent era]
forall a. Monoid a => a
mempty
      }

modifyImpInitProtVer ::
  forall era.
  ShelleyEraImp era =>
  Version ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer :: forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitProtVer Version
ver =
  (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
      }

modifyImpInitExpectLedgerRuleConformance ::
  forall era.
  ( forall t.
    Globals ->
    Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
    LedgerEnv era ->
    LedgerState era ->
    Tx era ->
    ImpM t ()
  ) ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
modifyImpInitExpectLedgerRuleConformance :: forall era.
(forall t.
 Globals
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
 -> LedgerEnv era
 -> LedgerState era
 -> Tx era
 -> ImpM t ())
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
modifyImpInitExpectLedgerRuleConformance forall t.
Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx 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
            & iteExpectLedgerRuleConformanceL .~ f
      }

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

impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv :: forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
nes = do
  SlotNo
slotNo <- (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
impLastTick
  EpochNo
epochNo <- ShelleyBase EpochNo -> ImpTestM era EpochNo
forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase (ShelleyBase EpochNo -> ImpTestM era EpochNo)
-> ShelleyBase EpochNo -> ImpTestM era EpochNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> ShelleyBase EpochNo
epochFromSlot SlotNo
slotNo
  LedgerEnv era -> ImpTestM era (LedgerEnv era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LedgerEnv
      { ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
slotNo
      , ledgerEpochNo :: Maybe EpochNo
ledgerEpochNo = EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epochNo
      , ledgerPp :: PParams era
ledgerPp = NewEpochState era
nes NewEpochState era
-> Getting (PParams era) (NewEpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (PParams era) (EpochState era))
-> NewEpochState era -> Const (PParams era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (PParams era) (EpochState era))
 -> NewEpochState era -> Const (PParams era) (NewEpochState era))
-> ((PParams era -> Const (PParams era) (PParams era))
    -> EpochState era -> Const (PParams era) (EpochState era))
-> Getting (PParams era) (NewEpochState era) (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const (PParams era) (PParams era))
-> EpochState era -> Const (PParams era) (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      , ledgerIx :: TxIx
ledgerIx = Word16 -> TxIx
TxIx Word16
0
      , ledgerAccount :: ChainAccountState
ledgerAccount = NewEpochState era
nes NewEpochState era
-> Getting ChainAccountState (NewEpochState era) ChainAccountState
-> ChainAccountState
forall s a. s -> Getting a s a -> a
^. Getting ChainAccountState (NewEpochState era) ChainAccountState
forall era. Lens' (NewEpochState era) ChainAccountState
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) ChainAccountState
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
  InstantStake era
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
  Doc AnsiStyle -> ImpTestM era ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpTestM era ())
-> Doc AnsiStyle -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Instant Stake: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> InstantStake era -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr InstantStake era
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
$ ConstructorName -> Fail UTCTime
forall (m :: * -> *) t.
(MonadFail m, ISO8601 t) =>
ConstructorName -> m t
iso8601ParseM ConstructorName
"2017-09-23T21:44:51Z"
          , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123456 -- Mainnet value: 764824073
          , sgNetworkId :: Network
sgNetworkId = Network
Testnet
          , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
20 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
129600
          , sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions = Word64
62
          , sgSlotLength :: NominalDiffTimeMicro
sgSlotLength = NominalDiffTimeMicro
1
          , sgUpdateQuorum :: Word64
sgUpdateQuorum = Word64
5
          , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
45_000_000_000_000_000
          , sgProtocolParams :: PParams ShelleyEra
sgProtocolParams =
              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
65536
                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
16384
                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 => 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, ProtVerAtMost era 6) =>
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, ProtVerAtMost era 6) =>
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, ProtVerAtMost era 4) =>
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 'Genesis) GenDelegPair
sgGenDelegs = Map (KeyHash 'Genesis) 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 -> ConstructorName -> m (Genesis ShelleyEra)
forall a. ConstructorName -> m a
forall (m :: * -> *) a. MonadFail m => ConstructorName -> m a
fail (ConstructorName -> m (Genesis ShelleyEra))
-> ([Text] -> ConstructorName) -> [Text] -> m (Genesis ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConstructorName
T.unpack (Text -> ConstructorName)
-> ([Text] -> Text) -> [Text] -> ConstructorName
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
shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
    let transContext :: FromByronTranslationContext
transContext = ShelleyGenesis -> FromByronTranslationContext
toFromByronTranslationContext ShelleyGenesis
shelleyGenesis
        startEpochNo :: EpochNo
startEpochNo = forall era. Era era => EpochNo
impEraStartEpochNo @ShelleyEra
    NewEpochState ShelleyEra -> m (NewEpochState ShelleyEra)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState ShelleyEra -> m (NewEpochState ShelleyEra))
-> NewEpochState ShelleyEra -> m (NewEpochState ShelleyEra)
forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext
-> EpochNo -> UTxO -> NewEpochState ShelleyEra
translateToShelleyLedgerStateFromUtxo FromByronTranslationContext
transContext EpochNo
startEpochNo UTxO
Byron.empty

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

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

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

-- | Figure out all the Byron Addresses that need witnesses as well as all of the
-- KeyHashes for Shelley Key witnesses that are required.
impWitsVKeyNeeded ::
  EraUTxO era =>
  TxBody era ->
  ImpTestM
    era
    ( Set.Set BootstrapAddress -- Byron Based Addresses
    , Set.Set (KeyHash 'Witness) -- Shelley Based KeyHashes
    )
impWitsVKeyNeeded :: forall era.
EraUTxO era =>
TxBody era
-> ImpTestM era (Set BootstrapAddress, Set (KeyHash 'Witness))
impWitsVKeyNeeded TxBody era
txBody = do
  LedgerState era
ls <- 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 era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  let toBootAddr :: TxIn -> Maybe BootstrapAddress
toBootAddr TxIn
txIn = do
        TxOut era
txOut <- TxIn -> UTxO era -> Maybe (TxOut era)
forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txIn UTxO era
utxo
        TxOut era
txOut TxOut era
-> Getting
     (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
-> Maybe BootstrapAddress
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF
      bootAddrs :: Set BootstrapAddress
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 era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
SimpleGetter (TxBody era) (Set TxIn)
spendableInputsTxBodyF)
      bootKeyHashes :: Set (KeyHash 'Witness)
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 :: Set (KeyHash 'Witness)
allKeyHashes =
        CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
forall era.
EraUTxO era =>
CertState era -> UTxO era -> TxBody 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 era
txBody
  (Set BootstrapAddress, Set (KeyHash 'Witness))
-> ImpTestM era (Set BootstrapAddress, Set (KeyHash 'Witness))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set BootstrapAddress
bootAddrs, Set (KeyHash 'Witness)
allKeyHashes Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness)
bootKeyHashes)

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

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

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

iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool
iteCborRoundTripFailuresL :: forall era (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> ImpTestEnv era -> f (ImpTestEnv era)
iteCborRoundTripFailuresL = (ImpTestEnv era -> Bool)
-> (ImpTestEnv era -> Bool -> ImpTestEnv era)
-> Lens (ImpTestEnv era) (ImpTestEnv era) Bool Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ImpTestEnv era -> Bool
forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures (\ImpTestEnv era
x Bool
y -> ImpTestEnv era
x {iteCborRoundTripFailures = 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
    [SomeSTSEvent era]
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
    ([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] -> ImpTestM era ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [SomeSTSEvent era]
forall a. Monoid a => a
mempty
    a
res <- ImpTestM era a
act
    [SomeSTSEvent era]
newEvs <- 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
    ([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] -> ImpTestM era ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [SomeSTSEvent era]
oldEvs
    (a, [SomeSTSEvent era]) -> ImpTestM era (a, [SomeSTSEvent era])
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
res, [SomeSTSEvent era]
newEvs)
  pass :: forall a.
ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
-> ImpTestM era a
pass ImpTestM era (a, [SomeSTSEvent era] -> [SomeSTSEvent era])
act = do
    ((a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f), [SomeSTSEvent era]
evs) <- 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
    (a, [SomeSTSEvent era]) -> ImpTestM era a
forall a. (a, [SomeSTSEvent era]) -> ImpTestM era a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a
a, [SomeSTSEvent era] -> [SomeSTSEvent era]
f [SomeSTSEvent era]
evs)

runShelleyBase :: ShelleyBase a -> ImpTestM era a
runShelleyBase :: forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase ShelleyBase a
act = do
  Globals
globals <- 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
  a -> ImpTestM era a
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ImpTestM era a) -> a -> ImpTestM era a
forall a b. (a -> b) -> a -> b
$ Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ ShelleyBase a -> Globals -> Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ShelleyBase a
act Globals
globals

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

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

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

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

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

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

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

fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era)
fixupTxOuts :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts Tx era
tx = do
  PParams era
pp <- 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 :: StrictSeq (TxOut era)
txOuts = Tx era
tx Tx era
-> Getting (StrictSeq (TxOut era)) (Tx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Tx era -> Const (StrictSeq (TxOut era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
 -> Tx era -> Const (StrictSeq (TxOut era)) (Tx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Getting (StrictSeq (TxOut era)) (Tx 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 era -> Const (StrictSeq (TxOut era)) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
  StrictSeq (TxOut era)
fixedUpTxOuts <- StrictSeq (TxOut era)
-> (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (StrictSeq (TxOut era))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM StrictSeq (TxOut era)
txOuts ((TxOut era -> ImpM (LedgerSpec era) (TxOut era))
 -> ImpM (LedgerSpec era) (StrictSeq (TxOut era)))
-> (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (StrictSeq (TxOut era))
forall a b. (a -> b) -> a -> b
$ \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
        let txOut' :: TxOut era
txOut' = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
txOut
        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
$
          Doc AnsiStyle
"Fixed up the amount in the TxOut to " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Coin -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (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)
        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'
      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
  Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
fixedUpTxOuts

fixupFees ::
  (ShelleyEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupFees :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees Tx era
txOriginal = ConstructorName
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"fixupFees" (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx 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 era
tx = Tx era
txOriginal Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall t. Val t => t
zero
  PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  CertState era
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
  Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  Map (KeyHash 'Witness) (KeyPair 'Witness)
nativeScriptKeyPairs <- Tx era -> ImpTestM era (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall era.
ShelleyEraImp era =>
Tx era -> ImpTestM era (Map (KeyHash 'Witness) (KeyPair 'Witness))
impNativeScriptKeyPairs Tx era
tx
  let
    nativeScriptKeyWits :: Set (KeyHash 'Witness)
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 :: Value era
consumedValue = PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo (Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL)
    producedValue :: Value era
producedValue = PParams era -> CertState era -> TxBody era -> Value era
forall era.
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState (Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL)
    ensureNonNegativeCoin :: p -> ImpM t p
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
  ConstructorName -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating changeBeforeFee"
  Coin
changeBeforeFee <- Coin -> ImpM (LedgerSpec era) Coin
forall {p} {t}. (Val p, ToExpr p) => p -> ImpM t p
ensureNonNegativeCoin (Coin -> ImpM (LedgerSpec era) Coin)
-> Coin -> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
consumedValue Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
producedValue
  Coin -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Coin
changeBeforeFee
  let
    changeBeforeFeeTxOut :: TxOut era
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 era
txNoWits = Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx era
-> Tx 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 :: StrictSeq (TxOut era)
outsBeforeFee = Tx era
tx Tx era
-> Getting (StrictSeq (TxOut era)) (Tx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Tx era -> Const (StrictSeq (TxOut era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
 -> Tx era -> Const (StrictSeq (TxOut era)) (Tx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Getting (StrictSeq (TxOut era)) (Tx 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 era -> Const (StrictSeq (TxOut era)) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
    suppliedFee :: Coin
suppliedFee = Tx era
txOriginal Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
    fee0 :: Coin
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 era -> Set (KeyHash 'Witness) -> Coin
forall era.
(EraUTxO era, EraCertState era) =>
UTxO era -> PParams era -> Tx era -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxNativeScriptWits UTxO era
utxo PParams era
pp Tx era
txNoWits Set (KeyHash 'Witness)
nativeScriptKeyWits
      | Bool
otherwise = Coin
suppliedFee
    fee :: Coin
fee = Rational -> Coin
rationalToCoinViaCeiling (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)
  ConstructorName -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => ConstructorName -> ImpM t ()
logString ConstructorName
"Validating change"
  Coin
change <- Coin -> ImpM (LedgerSpec era) Coin
forall {p} {t}. (Val p, ToExpr p) => p -> ImpM t p
ensureNonNegativeCoin (Coin -> ImpM (LedgerSpec era) Coin)
-> Coin -> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ TxOut era
changeBeforeFeeTxOut 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 -> Coin
forall t. Val t => t -> t -> t
<-> Coin
fee
  Coin -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Coin
change
  let
    changeTxOut :: TxOut era
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 :: Tx era
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 era
txNoWits
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (StrictSeq (TxOut era)
outsBeforeFee StrictSeq (TxOut era) -> TxOut era -> StrictSeq (TxOut era)
forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut era
changeTxOut)
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
      | Bool
otherwise =
          Tx era
txNoWits
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
outsBeforeFee
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx 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)
  Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
txWithFee

-- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not.
fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era)
fixupAuxDataHash :: forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash Tx era
tx
  | StrictMaybe TxAuxDataHash
SNothing <- Tx era
tx Tx era
-> Getting
     (StrictMaybe TxAuxDataHash) (Tx era) (StrictMaybe TxAuxDataHash)
-> StrictMaybe TxAuxDataHash
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
-> Tx era -> Const (StrictMaybe TxAuxDataHash) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
 -> Tx era -> Const (StrictMaybe TxAuxDataHash) (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
-> Getting
     (StrictMaybe TxAuxDataHash) (Tx era) (StrictMaybe TxAuxDataHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash
 -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
-> TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL
  , SJust TxAuxData era
auxData <- Tx era
tx Tx era
-> Getting
     (StrictMaybe (TxAuxData era))
     (Tx era)
     (StrictMaybe (TxAuxData era))
-> StrictMaybe (TxAuxData era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (TxAuxData era))
  (Tx era)
  (StrictMaybe (TxAuxData era))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL =
      Tx era -> m (Tx era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe TxAuxDataHash -> Tx era -> Tx 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 era -> m (Tx era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

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

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

logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era ()
logFeeMismatch :: forall era.
(EraGov era, EraUTxO era, HasCallStack) =>
Tx era -> ImpTestM era ()
logFeeMismatch Tx era
tx = do
  PParams era
pp <- 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 era
utxo <- SimpleGetter (NewEpochState era) (UTxO era)
-> ImpTestM era (UTxO era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (UTxO era -> Const r (UTxO era))
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  let Coin Integer
feeUsed = Tx era
tx Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
      Coin Integer
feeMin = PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo
  Bool -> ImpTestM era () -> ImpTestM era ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
feeUsed Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
feeMin) (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    Doc AnsiStyle -> ImpTestM era ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpTestM era ())
-> Doc AnsiStyle -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle
"Estimated fee " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Integer -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeUsed Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" while required fee is " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Integer -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr Integer
feeMin

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

submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era)
submitTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx = Tx era
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx ImpM
  (LedgerSpec era)
  (Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era))
-> (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
      (Tx era)
    -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx 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 era)
-> ImpM (LedgerSpec era) (Tx 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 era)
 -> ImpM (LedgerSpec era) (Tx era))
-> (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
      (Tx era)
    -> Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx 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 era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a, b) -> a
fst

trySubmitTx ::
  forall era.
  ( ShelleyEraImp era
  , HasCallStack
  ) =>
  Tx era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitTx :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx = do
  Tx era
txFixed <- (ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ((Tx era -> ImpM (LedgerSpec era) (Tx era))
    -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx 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 era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx)
  Tx era -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txFixed
  NewEpochState era
st <- (ImpTestState era -> NewEpochState era)
-> ImpM (LedgerSpec era) (NewEpochState era)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> NewEpochState era
forall era. ImpTestState era -> NewEpochState era
impNES
  LedgerEnv era
lEnv <- NewEpochState era -> ImpTestM era (LedgerEnv era)
forall era.
EraGov era =>
NewEpochState era -> ImpTestM era (LedgerEnv era)
impLedgerEnv NewEpochState era
st
  ImpTestState {TxIn
impRootTxIn :: forall era. ImpTestState era -> TxIn
impRootTxIn :: TxIn
impRootTxIn} <- ImpM (LedgerSpec era) (ImpTestState era)
forall s (m :: * -> *). MonadState s m => m s
get
  Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res <- forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @"LEDGER" LedgerEnv era
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 era
Signal (EraRule "LEDGER" era)
txFixed
  Bool
roundTripCheck <- (ImpTestEnv era -> Bool) -> ImpM (LedgerSpec era) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era -> Bool
forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures
  Globals
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

  -- Check for conformance
  (ImpTestEnv era
 -> forall t.
    Globals
    -> Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
         (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
    -> LedgerEnv era
    -> LedgerState era
    -> Tx era
    -> ImpM t ())
-> ImpM
     (LedgerSpec era)
     (forall t.
      Globals
      -> Either
           (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
           (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
      -> LedgerEnv era
      -> LedgerState era
      -> Tx era
      -> ImpM t ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era
-> forall t.
   Globals
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> LedgerEnv era
   -> LedgerState era
   -> Tx era
   -> ImpM t ()
forall era.
ImpTestEnv era
-> forall t.
   Globals
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> LedgerEnv era
   -> LedgerState era
   -> Tx era
   -> ImpM t ()
iteExpectLedgerRuleConformance
    ImpM
  (LedgerSpec era)
  (forall t.
   Globals
   -> Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
   -> LedgerEnv era
   -> LedgerState era
   -> Tx era
   -> ImpM t ())
-> ((forall t.
     Globals
     -> Either
          (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
          (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
     -> LedgerEnv era
     -> LedgerState era
     -> Tx era
     -> ImpM t ())
    -> 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
>>= (\forall t.
Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> ImpM t ()
f -> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> ImpM (LedgerSpec era) ()
forall t.
Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> ImpM t ()
f Globals
globals Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)])
Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res LedgerEnv 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 era
txFixed)

  case Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (LedgerState era, [Event (EraRule "LEDGER" era)])
res of
    Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures -> do
      -- Verify that produced predicate failures are ready for the node-to-client protocol
      if Bool
roundTripCheck
        then 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
        else
          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
$
            Version
-> Version
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> IO ()
forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation
              (forall era. Era era => Version
eraProtVerLow @era)
              (forall era. Era era => Version
eraProtVerHigh @era)
              NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures
      Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
   (Tx era)
 -> ImpTestM
      era
      (Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
         (Tx era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
forall a b. a -> Either a b
Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
txFixed)
    Right (LedgerState era
st', [Event (EraRule "LEDGER" era)]
events) -> do
      let txId :: TxId
txId = SafeHash EraIndependentTxBody -> TxId
TxId (SafeHash EraIndependentTxBody -> TxId)
-> (TxBody era -> SafeHash EraIndependentTxBody)
-> TxBody era
-> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (TxBody era -> TxId) -> TxBody era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx era
txFixed Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
          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 era
txFixed Tx era
-> Getting (StrictSeq (TxOut era)) (Tx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Tx era -> Const (StrictSeq (TxOut era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
 -> Tx era -> Const (StrictSeq (TxOut era)) (Tx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Getting (StrictSeq (TxOut era)) (Tx 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 era -> Const (StrictSeq (TxOut era)) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody 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 = ConstructorName -> Int
forall a. HasCallStack => ConstructorName -> a
error (ConstructorName
"Expected at least 1 output after submitting tx: " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> TxId -> ConstructorName
forall a. Show a => a -> ConstructorName
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
.~ LedgerState era
st'
      UTxO Map TxIn (TxOut era)
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 :: TxIn
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
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 = ConstructorName -> TxIn
forall a. HasCallStack => ConstructorName -> a
error ConstructorName
"Root not found in UTxO"
      (TxIn -> Identity TxIn)
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(TxIn -> f TxIn) -> ImpTestState era -> f (ImpTestState era)
impRootTxInL ((TxIn -> Identity TxIn)
 -> ImpTestState era -> Identity (ImpTestState era))
-> TxIn -> ImpM (LedgerSpec era) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TxIn
newRoot
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era ()
expectTxSuccess Tx era
txFixed
      Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
   (Tx era)
 -> ImpTestM
      era
      (Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
         (Tx era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall a b. (a -> b) -> a -> b
$ Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era)
forall a b. b -> Either a b
Right Tx era
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 era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingTx :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx = Tx era
-> (Tx era
    -> ImpM
         (LedgerSpec era)
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx ((Tx era
  -> ImpM
       (LedgerSpec era)
       (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
 -> ImpM (LedgerSpec era) ())
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> Tx 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 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 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 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 era ->
  (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) ->
  ImpTestM era ()
submitFailingTxM :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> (Tx era
    -> ImpTestM
         era (NonEmpty (PredicateFailure (EraRule "LEDGER" era))))
-> ImpTestM era ()
submitFailingTxM Tx era
tx Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures = do
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures, Tx era
fixedUpTx) <- Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx 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 era)
   (Tx era)
 -> ImpM
      (LedgerSpec era)
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era))
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
-> ImpM
     (LedgerSpec era)
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx era
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures <- Tx era
-> ImpTestM
     era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
mkExpectedFailures Tx era
fixedUpTx
  NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailures NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures

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

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

tryRunImpRule' ::
  forall rule era.
  (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
  AssertionPolicy ->
  Environment (EraRule rule era) ->
  State (EraRule rule era) ->
  Signal (EraRule rule era) ->
  ImpTestM
    era
    ( Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)])
    )
tryRunImpRule' :: forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
AssertionPolicy
-> Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule' AssertionPolicy
assertionPolicy Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let trc :: TRC (EraRule rule era)
trc = (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)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal = do
  let ruleName :: ConstructorName
ruleName = Proxy rule -> ConstructorName
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> ConstructorName
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @rule)
  (State (EraRule rule era)
res, [Event (EraRule rule era)]
ev) <-
    forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @rule Environment (EraRule rule era)
stsEnv State (EraRule rule era)
stsState Signal (EraRule rule era)
stsSignal 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 ->
        ConstructorName
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
ConstructorName -> m a
assertFailure (ConstructorName
 -> ImpM
      (LedgerSpec era)
      (State (EraRule rule era), [Event (EraRule rule era)]))
-> ConstructorName
-> ImpM
     (LedgerSpec era)
     (State (EraRule rule era), [Event (EraRule rule era)])
forall a b. (a -> b) -> a -> b
$
          [ConstructorName] -> ConstructorName
unlines ([ConstructorName] -> ConstructorName)
-> [ConstructorName] -> ConstructorName
forall a b. (a -> b) -> a -> b
$
            (ConstructorName
"Failed to run " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> ConstructorName
ruleName ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> ConstructorName
":") ConstructorName -> [ConstructorName] -> [ConstructorName]
forall a. a -> [a] -> [a]
: (PredicateFailure (EraRule rule era) -> ConstructorName)
-> [PredicateFailure (EraRule rule era)] -> [ConstructorName]
forall a b. (a -> b) -> [a] -> [b]
map PredicateFailure (EraRule rule era) -> ConstructorName
forall a. Show a => a -> ConstructorName
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
  [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 rule era) -> SomeSTSEvent era)
-> [Event (EraRule rule 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 @rule) [Event (EraRule rule era)]
ev
  State (EraRule rule era) -> ImpTestM era (State (EraRule rule era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State (EraRule rule era)
res

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

-- | Runs the TICK rule until the next epoch is reached
passEpoch ::
  forall era.
  (ShelleyEraImp era, HasCallStack) =>
  ImpTestM era ()
passEpoch :: forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch = do
  let
    tickUntilNewEpoch :: EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo = do
      forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick @era
      EpochNo
newEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      Bool -> ImpTestM era () -> ImpTestM era ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EpochNo
newEpochNo EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
> EpochNo
curEpochNo) (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
curEpochNo
  NewEpochState era
preNES <- (ImpTestState era -> NewEpochState era)
-> ImpM (LedgerSpec era) (NewEpochState era)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> NewEpochState era
forall era. ImpTestState era -> NewEpochState era
impNES
  let startEpoch :: EpochNo
startEpoch = 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
  Doc AnsiStyle -> ImpTestM era ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpTestM era ())
-> Doc AnsiStyle -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Entering " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Doc AnsiStyle
forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
startEpoch)
  EpochNo -> ImpTestM era ()
tickUntilNewEpoch EpochNo
startEpoch
  (ImpTestState era -> NewEpochState era)
-> ImpM (LedgerSpec era) (NewEpochState era)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ImpTestState era -> NewEpochState era
forall era. ImpTestState era -> NewEpochState era
impNES ImpM (LedgerSpec era) (NewEpochState era)
-> (NewEpochState era -> ImpTestM era ()) -> ImpTestM 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
>>= NewEpochState era -> NewEpochState era -> ImpTestM era ()
forall era.
(EraTxOut era, EraGov era, HasCallStack, EraCertState era) =>
NewEpochState era -> NewEpochState era -> ImpTestM era ()
epochBoundaryCheck NewEpochState era
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
  ConstructorName -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking ADA preservation at the epoch boundary" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM 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 -> ImpTestM era ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpTestM era ())
-> Doc AnsiStyle -> ImpTestM 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 -> ImpTestM era () -> ImpTestM era ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Coin
preSum Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
postSum) (ImpTestM era () -> ImpTestM era ())
-> (ConstructorName -> ImpTestM era ())
-> ConstructorName
-> ImpTestM era ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorName -> ImpTestM era ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure (ConstructorName -> ImpTestM era ())
-> ConstructorName -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
      ConstructorName
"Total ADA in the epoch state is not preserved\n\tpost - pre = "
        ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> Coin -> ConstructorName
forall a. Show a => a -> ConstructorName
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 =
  Int -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec 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) 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
  a
e <- ImpTestM era a
action
  CallStack -> Doc AnsiStyle -> ImpM (LedgerSpec era) ()
forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
CallStack
?callStack (Doc AnsiStyle -> ImpM (LedgerSpec era) ())
-> (a -> Doc AnsiStyle) -> a -> ImpM (LedgerSpec era) ()
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 (a -> ImpM (LedgerSpec era) ()) -> a -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ a
e
  a -> ImpTestM era a
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
e

-- | Creates a fresh @SafeHash@
freshSafeHash :: ImpTestM era (SafeHash a)
freshSafeHash :: forall era a. ImpTestM era (SafeHash a)
freshSafeHash = 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
  Map (KeyHash 'Witness) (KeyPair 'Witness)
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 KeyHash 'Witness
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (KeyPair 'Witness)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (KeyHash r -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash r
keyHash) Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs of
    Just KeyPair 'Witness
keyPair -> 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 ->
      ConstructorName -> m (KeyPair r)
forall a. HasCallStack => ConstructorName -> a
error (ConstructorName -> m (KeyPair r))
-> ConstructorName -> m (KeyPair r)
forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ KeyHash r -> ConstructorName
forall a. Show a => a -> ConstructorName
show KeyHash r
keyHash
          ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `KeyPair` in the
-- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for
-- generation or `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 r
keyPair <- m (KeyPair r)
forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  KeyHash r
keyHash <- KeyPair r -> m (KeyHash r)
forall s (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s, MonadState s m) =>
KeyPair r -> m (KeyHash r)
addKeyPair KeyPair r
keyPair
  (KeyHash r, KeyPair r) -> m (KeyHash r, KeyPair r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash r
keyHash, KeyPair r
keyPair)

-- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair`
-- to the known keys in the Imp state.
freshKeyAddr_ ::
  (HasKeyPairs s, MonadState s m, HasStatefulGen g m, 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
  KeyHash 'Payment
paymentKeyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment
  Maybe StakeReference
stakingKeyHash <-
    [m (Maybe StakeReference)] -> m (Maybe StakeReference)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
oneof
      [StakeReference -> Maybe StakeReference
forall a. a -> Maybe a
Just (StakeReference -> Maybe StakeReference)
-> (KeyHash 'Staking -> StakeReference)
-> KeyHash 'Staking
-> Maybe StakeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'Staking -> StakeReference
forall c. MakeStakeReference c => c -> StakeReference
mkStakeRef (KeyHash 'Staking -> Maybe StakeReference)
-> m (KeyHash 'Staking) -> m (Maybe StakeReference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Staking, StakeReference -> Maybe StakeReference
forall a. a -> Maybe a
Just (StakeReference -> Maybe StakeReference)
-> (Ptr -> StakeReference) -> Ptr -> Maybe StakeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. MakeStakeReference c => c -> StakeReference
mkStakeRef @Ptr (Ptr -> Maybe StakeReference) -> m Ptr -> m (Maybe StakeReference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Ptr
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary, Maybe StakeReference -> m (Maybe StakeReference)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StakeReference
forall a. Maybe a
Nothing]
  (KeyHash 'Payment, Addr) -> m (KeyHash 'Payment, Addr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'Payment
paymentKeyHash, KeyHash 'Payment -> Maybe StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
paymentKeyHash Maybe StakeReference
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
  Map BootstrapAddress ByronKeyPair
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 BootstrapAddress
-> Map BootstrapAddress ByronKeyPair -> Maybe ByronKeyPair
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BootstrapAddress
bootAddr Map BootstrapAddress ByronKeyPair
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 ->
      ConstructorName -> m ByronKeyPair
forall a. HasCallStack => ConstructorName -> a
error (ConstructorName -> m ByronKeyPair)
-> ConstructorName -> m ByronKeyPair
forall a b. (a -> b) -> a -> b
$
        ConstructorName
"Could not find a keypair corresponding to: "
          ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ BootstrapAddress -> ConstructorName
forall a. Show a => a -> ConstructorName
show BootstrapAddress
bootAddr
          ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ ConstructorName
"\nAlways use `freshByronKeyHash` to create key hashes."

-- | Generates a fresh `KeyHash` and stores the corresponding `ByronKeyPair` in the
-- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for
-- generation or `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
keyPair@(ByronKeyPair VerificationKey
verificationKey SigningKey
_) <- m ByronKeyPair
forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Bool
hasPayload <- m Bool
forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  Maybe HDAddressPayload
payload <-
    if Bool
hasPayload
      then HDAddressPayload -> Maybe HDAddressPayload
forall a. a -> Maybe a
Just (HDAddressPayload -> Maybe HDAddressPayload)
-> (ByteString -> HDAddressPayload)
-> ByteString
-> Maybe HDAddressPayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HDAddressPayload
Byron.HDAddressPayload (ByteString -> Maybe HDAddressPayload)
-> m ByteString -> m (Maybe HDAddressPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> m ByteString
forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteString
uniformByteStringM (Int -> m ByteString) -> m Int -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int) -> m Int
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Int
0, Int
63))
      else Maybe HDAddressPayload -> m (Maybe HDAddressPayload)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HDAddressPayload
forall a. Maybe a
Nothing
  let asd :: AddrSpendingData
asd = VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
verificationKey
      attrs :: AddrAttributes
attrs = Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes Maybe HDAddressPayload
payload (Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
0)
      bootAddr :: BootstrapAddress
bootAddr = Address -> BootstrapAddress
BootstrapAddress (Address -> BootstrapAddress) -> Address -> BootstrapAddress
forall a b. (a -> b) -> a -> b
$ AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress AddrSpendingData
asd AddrAttributes
attrs
  (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 BootstrapAddress ByronKeyPair
 -> Identity (Map BootstrapAddress ByronKeyPair))
-> s -> Identity s
forall t.
HasKeyPairs t =>
Lens' t (Map BootstrapAddress ByronKeyPair)
Lens' s (Map BootstrapAddress ByronKeyPair)
keyPairsByronL ((Map BootstrapAddress ByronKeyPair
  -> Identity (Map BootstrapAddress ByronKeyPair))
 -> s -> Identity s)
-> (Map BootstrapAddress ByronKeyPair
    -> Map BootstrapAddress ByronKeyPair)
-> s
-> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ BootstrapAddress
-> ByronKeyPair
-> Map BootstrapAddress ByronKeyPair
-> Map BootstrapAddress ByronKeyPair
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BootstrapAddress
bootAddr ByronKeyPair
keyPair
  BootstrapAddress -> m BootstrapAddress
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BootstrapAddress
bootAddr

sendCoinTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era TxIn
sendCoinTo :: forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr = 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 era
tx <-
    ConstructorName -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn
      (ConstructorName
"Giving " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> Value era -> ConstructorName
forall a. Show a => a -> ConstructorName
show Value era
amount ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> ConstructorName
" to " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> Addr -> ConstructorName
forall a. Show a => a -> ConstructorName
show Addr
addr)
      (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
amount)
  TxIn -> ImpTestM era TxIn
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> ImpTestM era TxIn) -> TxIn -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
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 era ->
  ImpTestM era (Tx era)
submitTxAnn :: forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era (Tx era)
submitTxAnn ConstructorName
msg Tx era
tx = ConstructorName
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) (Tx era)
forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
msg (Tx era
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx ImpM
  (LedgerSpec era)
  (Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
     (Tx era))
-> (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
      (Tx era)
    -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx 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 era)
  (Tx era)
-> ImpM (LedgerSpec era) (Tx era)
forall a b (m :: * -> *).
(HasCallStack, ToExpr a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeepExpr)

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

getRewardAccountFor ::
  Credential 'Staking ->
  ImpTestM era RewardAccount
getRewardAccountFor :: forall era. Credential 'Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential 'Staking
stakingC = do
  Network
networkId <- 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)
  RewardAccount -> ImpTestM era RewardAccount
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardAccount -> ImpTestM era RewardAccount)
-> RewardAccount -> ImpTestM era RewardAccount
forall a b. (a -> b) -> a -> b
$ Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
networkId Credential 'Staking
stakingC

registerStakeCredential ::
  forall era.
  ( HasCallStack
  , ShelleyEraImp era
  ) =>
  Credential 'Staking ->
  ImpTestM era RewardAccount
registerStakeCredential :: forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred = do
  ConstructorName -> Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
ConstructorName -> Tx era -> ImpTestM era ()
submitTxAnn_ (ConstructorName
"Register Reward Account: " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> Text -> ConstructorName
T.unpack (Credential 'Staking -> Text
forall (kr :: KeyRole). Credential kr -> Text
credToText Credential 'Staking
cred)) (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
    TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList [forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert @era Credential 'Staking
cred]
  Network
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)
  RewardAccount -> ImpTestM era RewardAccount
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardAccount -> ImpTestM era RewardAccount)
-> RewardAccount -> ImpTestM era RewardAccount
forall a b. (a -> b) -> a -> b
$ Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
networkId Credential 'Staking
cred

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

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

lookupReward :: EraCertState era => Credential 'Staking -> ImpTestM era (Maybe Coin)
lookupReward :: forall era.
EraCertState era =>
Credential 'Staking -> ImpTestM era (Maybe Coin)
lookupReward Credential 'Staking
stakingCredential = do
  UMap
umap <- SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap
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))
-> ((UMap -> Const r UMap)
    -> EpochState era -> Const r (EpochState era))
-> (UMap -> Const r UMap)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const r UMap)
-> EpochState era -> Const r (EpochState era)
forall era. EraCertState era => Lens' (EpochState era) UMap
Lens' (EpochState era) UMap
epochStateUMapL)
  Maybe Coin -> ImpTestM era (Maybe Coin)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Coin -> ImpTestM era (Maybe Coin))
-> Maybe Coin -> ImpTestM era (Maybe Coin)
forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (RDPair -> CompactForm Coin) -> RDPair -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
rdReward (RDPair -> Coin) -> Maybe RDPair -> Maybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential 'Staking
-> UView (Credential 'Staking) RDPair -> Maybe RDPair
forall k v. k -> UView k v -> Maybe v
UMap.lookup Credential 'Staking
stakingCredential (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
umap)

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

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

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

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

withCborRoundTripFailures :: ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures :: forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures = (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
$ (Bool -> Identity Bool)
-> ImpTestEnv era -> Identity (ImpTestEnv era)
forall era (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> ImpTestEnv era -> f (ImpTestEnv era)
iteCborRoundTripFailuresL ((Bool -> Identity Bool)
 -> ImpTestEnv era -> Identity (ImpTestEnv era))
-> Bool -> ImpTestEnv era -> ImpTestEnv era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False

-- | Compose given function with the configured fixup
withCustomFixup ::
  ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withCustomFixup :: forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f = (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 era -> ImpTestM era (Tx era))
 -> Identity (Tx era -> ImpTestM era (Tx era)))
-> ImpTestEnv era -> Identity (ImpTestEnv era)
forall era (f :: * -> *).
Functor f =>
((Tx era -> ImpTestM era (Tx era))
 -> f (Tx era -> ImpTestM era (Tx era)))
-> ImpTestEnv era -> f (ImpTestEnv era)
iteFixupL (((Tx era -> ImpTestM era (Tx era))
  -> Identity (Tx era -> ImpTestM era (Tx era)))
 -> ImpTestEnv era -> Identity (ImpTestEnv era))
-> ((Tx era -> ImpTestM era (Tx era))
    -> Tx era -> ImpTestM era (Tx era))
-> ImpTestEnv era
-> ImpTestEnv era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
f

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

-- | Performs the action without running the fix-up function on any transactions
withNoFixup :: ImpTestM era a -> ImpTestM era a
withNoFixup :: forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup = (Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup Tx era -> ImpTestM era (Tx 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 era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPreFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPreFixup Tx era -> ImpTestM era (Tx era)
f = ((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup (Tx era -> ImpTestM era (Tx era)
f (Tx era -> ImpTestM era (Tx era))
-> (Tx era -> ImpTestM era (Tx era))
-> Tx era
-> ImpTestM era (Tx 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 era -> ImpTestM era (Tx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPostFixup :: forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup Tx era -> ImpTestM era (Tx era)
f = ((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
((Tx era -> ImpTestM era (Tx era))
 -> Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withCustomFixup ((Tx era -> ImpTestM era (Tx era))
-> (Tx era -> ImpTestM era (Tx era))
-> Tx era
-> ImpTestM era (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpTestM era (Tx era)
f)

expectUTxOContent ::
  (HasCallStack, ToExpr (TxOut era)) =>
  UTxO era ->
  [(TxIn, Maybe (TxOut era) -> Bool)] ->
  ImpTestM era ()
expectUTxOContent :: forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo = ((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
$
    ConstructorName -> ImpM (LedgerSpec era) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ConstructorName -> m ()
expectationFailure (ConstructorName -> ImpM (LedgerSpec era) ())
-> ConstructorName -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      ConstructorName
"UTxO content failed predicate:\n" ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> TxIn -> ConstructorName
forall a. ToExpr a => a -> ConstructorName
ansiExprString TxIn
txIn ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> ConstructorName
" -> " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> Maybe (TxOut era) -> ConstructorName
forall a. ToExpr a => a -> ConstructorName
ansiExprString Maybe (TxOut era)
result

expectRegisteredRewardAddress :: EraCertState era => RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress :: forall era. EraCertState era => RewardAccount -> ImpTestM era ()
expectRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking
cred) = do
  UMap
umap <- SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap)
-> SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap
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))
-> ((UMap -> Const r UMap)
    -> EpochState era -> Const r (EpochState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap)
    -> LedgerState era -> Const r (LedgerState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap)
    -> CertState era -> Const r (CertState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap) -> DState era -> Const r (DState era))
-> (UMap -> Const r UMap)
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const r UMap) -> DState era -> Const r (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL
  Credential 'Staking -> Map (Credential 'Staking) RDPair -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking
cred (UMap -> Map (Credential 'Staking) RDPair
rdPairMap UMap
umap) Bool -> Bool -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True

expectNotRegisteredRewardAddress :: EraCertState era => RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress :: forall era. EraCertState era => RewardAccount -> ImpTestM era ()
expectNotRegisteredRewardAddress (RewardAccount Network
_ Credential 'Staking
cred) = do
  UMap
umap <- SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap)
-> SimpleGetter (NewEpochState era) UMap -> ImpTestM era UMap
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))
-> ((UMap -> Const r UMap)
    -> EpochState era -> Const r (EpochState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap)
    -> LedgerState era -> Const r (LedgerState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap)
    -> CertState era -> Const r (CertState era))
-> (UMap -> Const r UMap)
-> 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))
-> ((UMap -> Const r UMap) -> DState era -> Const r (DState era))
-> (UMap -> Const r UMap)
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const r UMap) -> DState era -> Const r (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL
  Credential 'Staking -> Map (Credential 'Staking) RDPair -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'Staking
cred (UMap -> Map (Credential 'Staking) RDPair
rdPairMap UMap
umap) Bool -> Bool -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
False

expectTreasury :: HasCallStack => Coin -> ImpTestM era ()
expectTreasury :: forall era. HasCallStack => Coin -> ImpTestM era ()
expectTreasury Coin
c =
  ConstructorName
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"Checking treasury amount" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
    Coin
treasuryAmt <- 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
    Coin
c Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
treasuryAmt

-- Ensure no fees reach the treasury since that complicates withdrawal checks
disableTreasuryExpansion :: ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion :: forall era. ShelleyEraImp era => ImpM (LedgerSpec era) ()
disableTreasuryExpansion = (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 = ConstructorName
-> ImpM (LedgerSpec era) (TxOut era)
-> ImpM (LedgerSpec era) (TxOut era)
forall a t. NFData a => ConstructorName -> ImpM t a -> ImpM t a
impAnn ConstructorName
"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 era
utxo <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
  case TxIn -> UTxO era -> Maybe (TxOut era)
forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txIn UTxO era
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 -> ConstructorName -> ImpM (LedgerSpec era) (TxOut era)
forall a. HasCallStack => ConstructorName -> a
error (ConstructorName -> ImpM (LedgerSpec era) (TxOut era))
-> ConstructorName -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ ConstructorName
"Failed to get TxOut for " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> TxIn -> ConstructorName
forall a. Show a => a -> ConstructorName
show TxIn
txIn

produceScript ::
  (ShelleyEraImp era, HasCallStack) =>
  ScriptHash ->
  ImpTestM era TxIn
produceScript :: forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash = do
  let addr :: Addr
addr = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
  let tx :: Tx era
tx =
        TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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)
  ConstructorName -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => ConstructorName -> ImpM t ()
logString (ConstructorName -> ImpM (LedgerSpec era) ())
-> ConstructorName -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConstructorName
"Produced script: " ConstructorName -> ConstructorName -> ConstructorName
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> ConstructorName
forall a. Show a => a -> ConstructorName
show ScriptHash
scriptHash
  Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) (Tx era -> TxIn)
-> ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx

advanceToPointOfNoReturn :: ImpTestM era ()
advanceToPointOfNoReturn :: forall era. ImpTestM era ()
advanceToPointOfNoReturn = do
  SlotNo
impLastTick <- (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
impLastTick
  (EpochNo
_, SlotNo
slotOfNoReturn, EpochNo
_) <- ShelleyBase (EpochNo, SlotNo, EpochNo)
-> ImpTestM era (EpochNo, SlotNo, EpochNo)
forall a era. ShelleyBase a -> ImpTestM era a
runShelleyBase (ShelleyBase (EpochNo, SlotNo, EpochNo)
 -> ImpTestM era (EpochNo, SlotNo, EpochNo))
-> ShelleyBase (EpochNo, SlotNo, EpochNo)
-> ImpTestM era (EpochNo, SlotNo, EpochNo)
forall a b. (a -> b) -> a -> b
$ HasCallStack => SlotNo -> ShelleyBase (EpochNo, SlotNo, EpochNo)
SlotNo -> ShelleyBase (EpochNo, SlotNo, EpochNo)
getTheSlotOfNoReturn SlotNo
impLastTick
  (SlotNo -> Identity SlotNo)
-> ImpTestState era -> Identity (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> ImpTestState era -> f (ImpTestState era)
impLastTickL ((SlotNo -> Identity SlotNo)
 -> ImpTestState era -> Identity (ImpTestState era))
-> SlotNo -> ImpTestM era ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SlotNo
slotOfNoReturn