{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

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

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

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

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.UTxO as Byron (empty)
import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
import Cardano.Crypto.Hash (Hash, HashAlgorithm)
import Cardano.Crypto.Hash.Blake2b (Blake2b_224)
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Address (
  Addr (..),
  BootstrapAddress (..),
  RewardAccount (..),
  bootstrapKeyHash,
 )
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Block (Block)
import Cardano.Ledger.CertState (certDStateL, dsUnifiedL)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..))
import Cardano.Ledger.Keys (
  HasKeyRole (..),
  KeyHash,
  KeyRole (..),
  VerKeyVRF,
  asWitness,
  bootstrapWitKeyHash,
  hashKey,
  makeBootstrapWitness,
  witVKeyHash,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash, extractHash)
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 (..),
  fromNominalDiffTimeMicro,
  mkShelleyGlobals,
 )
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  NewEpochState (..),
  StashedAVVMAddresses,
  asTreasuryL,
  consumed,
  curPParamsEpochStateL,
  epochStateIncrStakeDistrL,
  epochStateUMapL,
  esAccountStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  prevPParamsEpochStateL,
  produced,
  utxosDonationL,
  utxosUtxoL,
 )
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  LedgerEnv (..),
  ShelleyBbodyState,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext)
import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn)
import Cardano.Ledger.Tools (
  calcMinFeeTxNativeScriptWits,
  setMinCoinTxOut,
 )
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UMap as UMap
import Cardano.Ledger.UTxO (
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO (..),
  txinLookup,
 )
import Cardano.Ledger.Val (Val (..))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader (..), asks)
import Control.Monad.State.Strict (MonadState (..), StateT, 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.Class (Default (..))
import Data.Foldable (toList)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.IORef
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
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.Stack (CallStack, SrcLoc (..), getCallStack)
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,
  Pretty (..),
  annotate,
  hcat,
  indent,
  line,
  vsep,
 )
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color)
import System.Random
import qualified System.Random as Random
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
import Test.Cardano.Ledger.Binary.TreeDiff (srcLocToLocation)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation)
import Test.Cardano.Ledger.Core.KeyPair (
  ByronKeyPair (..),
  KeyPair (..),
  mkAddr,
  mkWitnessesVKey,
 )
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext)
import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..))
import Test.Cardano.Slotting.Numeric ()
import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
import Test.Hspec.Core.Spec (
  Example (..),
  Params,
  Result (..),
  paramsQuickCheckArgs,
 )
import qualified Test.Hspec.Core.Spec as H
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen)
import Type.Reflection (Typeable, typeOf)
import UnliftIO (MonadUnliftIO (..))
import UnliftIO.Exception (
  Exception (..),
  SomeException (..),
  catchAny,
  catchAnyDeep,
  evaluateDeep,
  throwIO,
 )

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

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

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

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

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

instance HasSubState (ImpPrepState era) where
  type SubState (ImpPrepState era) = StateGen QCGen
  getSubState :: ImpPrepState era -> SubState (ImpPrepState era)
getSubState = forall s. s -> StateGen s
StateGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ImpPrepState c -> QCGen
impPrepGen
  setSubState :: ImpPrepState era -> SubState (ImpPrepState era) -> ImpPrepState era
setSubState ImpPrepState era
s (StateGen QCGen
g) = ImpPrepState era
s {impPrepGen :: QCGen
impPrepGen = QCGen
g}

class Crypto c => HasKeyPairs t c | t -> c where
  keyPairsL :: Lens' t (Map (KeyHash 'Witness c) (KeyPair 'Witness c))
  keyPairsByronL :: Lens' t (Map (BootstrapAddress c) ByronKeyPair)

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

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

instance Monad m => HasStatefulGen (StateGenM (ImpPrepState era)) (StateT (ImpPrepState era) m) where
  askStatefulGen :: StateT (ImpPrepState era) m (StateGenM (ImpPrepState era))
askStatefulGen = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall s. StateGenM s
StateGenM

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

impLogL :: Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL :: forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ImpTestState era -> Doc AnsiStyle
impLog (\ImpTestState era
x Doc AnsiStyle
y -> ImpTestState era
x {impLog :: Doc AnsiStyle
impLog = Doc AnsiStyle
y})

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

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

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

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

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

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

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

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

class
  ( EraGov era
  , EraUTxO era
  , EraTxOut era
  , EraPParams era
  , ShelleyEraTxCert era
  , ShelleyEraScript era
  , ToExpr (Tx era)
  , NFData (Tx era)
  , ToExpr (TxBody era)
  , ToExpr (TxOut era)
  , ToExpr (Value era)
  , ToExpr (PParams era)
  , ToExpr (PParamsHKD Identity era)
  , ToExpr (PParamsHKD StrictMaybe era)
  , Show (NewEpochState era)
  , ToExpr (NewEpochState era)
  , ToExpr (GovState era)
  , Eq (StashedAVVMAddresses era)
  , Show (StashedAVVMAddresses era)
  , ToExpr (StashedAVVMAddresses era)
  , NFData (StashedAVVMAddresses era)
  , Default (StashedAVVMAddresses era)
  , -- For BBODY rule
    STS (EraRule "BBODY" era)
  , BaseM (EraRule "BBODY" era) ~ ShelleyBase
  , Environment (EraRule "BBODY" era) ~ BbodyEnv era
  , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
  , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) 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))
  , -- Necessary Crypto
    DSIGN (EraCrypto era) ~ Ed25519DSIGN
  , NFData (VerKeyDSIGN (DSIGN (EraCrypto era)))
  , VRF.VRFAlgorithm (VRF (EraCrypto era))
  , HashAlgorithm (HASH (EraCrypto era))
  , DSIGNAlgorithm (DSIGN (EraCrypto era))
  , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody)
  , ADDRHASH (EraCrypto era) ~ Blake2b_224
  ) =>
  ShelleyEraImp era
  where
  initGenesis ::
    (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen (StateGenM s) m) =>
    m (Genesis era)
  default initGenesis ::
    (Monad m, Genesis era ~ NoGenesis era) =>
    m (Genesis era)
  initGenesis = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall era. NoGenesis era
NoGenesis

  initNewEpochState ::
    (HasKeyPairs s (EraCrypto era), MonadState s m, HasStatefulGen (StateGenM s) m) =>
    m (NewEpochState era)
  default initNewEpochState ::
    ( HasKeyPairs s (EraCrypto era)
    , MonadState s m
    , HasStatefulGen (StateGenM s) m
    , ShelleyEraImp (PreviousEra era)
    , TranslateEra era NewEpochState
    , TranslationError era NewEpochState ~ Void
    , TranslationContext era ~ Genesis era
    , EraCrypto era ~ EraCrypto (PreviousEra era)
    ) =>
    m (NewEpochState era)
  initNewEpochState = forall era s (m :: * -> *).
(MonadState s m, HasKeyPairs s (EraCrypto era),
 HasStatefulGen (StateGenM s) m, ShelleyEraImp era,
 ShelleyEraImp (PreviousEra era), TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era,
 EraCrypto era ~ EraCrypto (PreviousEra era)) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState forall a. a -> a
id

  initImpTestState ::
    ( HasKeyPairs s (EraCrypto era)
    , MonadState s m
    , HasSubState s
    , SubState s ~ StateGen QCGen
    , HasStatefulGen (StateGenM s) m
    ) =>
    m (ImpTestState era)
  initImpTestState = forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (NewEpochState era)
initNewEpochState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era s (m :: * -> *).
(EraGov era, EraTxOut era, DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 ADDRHASH (EraCrypto era) ~ Blake2b_224,
 HasKeyPairs s (EraCrypto era), MonadState s m,
 HasStatefulGen (StateGenM s) m, HasSubState s,
 SubState s ~ StateGen QCGen) =>
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 (EraCrypto era)) ->
    NativeScript era ->
    ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))

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

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

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

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

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

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

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

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

mkTxId :: Crypto c => Int -> TxId c
mkTxId :: forall c. Crypto c => Int -> TxId c
mkTxId Int
idx = forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
idx)

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  , ShelleyEraScript (ShelleyEra c)
  ) =>
  ShelleyEraImp (ShelleyEra c)
  where
  initGenesis :: forall s (m :: * -> *).
(HasKeyPairs s (EraCrypto (ShelleyEra c)), MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Genesis (ShelleyEra c))
initGenesis =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ShelleyGenesis
        { sgSystemStart :: UTCTime
sgSystemStart = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM String
"2017-09-23T21:44:51Z"
        , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
123456 -- Mainnet value: 764824073
        , sgNetworkId :: Network
sgNetworkId = Network
Testnet
        , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Integer
5 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
        , sgSecurityParam :: Word64
sgSecurityParam = Word64
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 c)
sgProtocolParams =
            forall era. EraPParams era => PParams era
emptyPParams
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155_381
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
65536
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
16384
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
500_000_000
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
18
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
150
              forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
3 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1000)
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
              forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
              forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Nonce
NeutralNonce
              forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2_000_000
              forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
340_000_000
        , -- TODO: Add a top level definition and add private keys to ImpState:
          sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs = forall a. Monoid a => a
mempty
        , sgInitialFunds :: ListMap (Addr c) Coin
sgInitialFunds = forall a. Monoid a => a
mempty
        , sgStaking :: ShelleyGenesisStaking c
sgStaking = forall a. Monoid a => a
mempty
        }

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

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

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

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

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

data ImpTestEnv era = ImpTestEnv
  { forall era. ImpTestEnv era -> IORef (ImpTestState era)
iteState :: !(IORef (ImpTestState era))
  , forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup :: Tx era -> ImpTestM era (Tx era)
  , forall era. ImpTestEnv era -> Int
iteQuickCheckSize :: !Int
  , forall era. ImpTestEnv era -> Bool
iteCborRoundTripFailures :: !Bool
  -- ^ Expect failures in CBOR round trip serialization tests for predicate failures
  }

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

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

newtype ImpTestM era a = ImpTestM {forall era a. ImpTestM era a -> ReaderT (ImpTestEnv era) IO a
unImpTestM :: ReaderT (ImpTestEnv era) IO a}
  deriving
    ( forall a b. a -> ImpTestM era b -> ImpTestM era a
forall a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
forall era a b. a -> ImpTestM era b -> ImpTestM era a
forall era a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ImpTestM era b -> ImpTestM era a
$c<$ :: forall era a b. a -> ImpTestM era b -> ImpTestM era a
fmap :: forall a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
$cfmap :: forall era a b. (a -> b) -> ImpTestM era a -> ImpTestM era b
Functor
    , forall era. Functor (ImpTestM era)
forall a. a -> ImpTestM era a
forall era a. a -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall era a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
forall a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
forall era a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
$c<* :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era a
*> :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
$c*> :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
liftA2 :: forall a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
$cliftA2 :: forall era a b c.
(a -> b -> c) -> ImpTestM era a -> ImpTestM era b -> ImpTestM era c
<*> :: forall a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
$c<*> :: forall era a b.
ImpTestM era (a -> b) -> ImpTestM era a -> ImpTestM era b
pure :: forall a. a -> ImpTestM era a
$cpure :: forall era a. a -> ImpTestM era a
Applicative
    , forall era. Applicative (ImpTestM era)
forall a. a -> ImpTestM era a
forall era a. a -> ImpTestM era a
forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
forall era a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ImpTestM era a
$creturn :: forall era a. a -> ImpTestM era a
>> :: forall a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
$c>> :: forall era a b. ImpTestM era a -> ImpTestM era b -> ImpTestM era b
>>= :: forall a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
$c>>= :: forall era a b.
ImpTestM era a -> (a -> ImpTestM era b) -> ImpTestM era b
Monad
    , forall era. Monad (ImpTestM era)
forall a. IO a -> ImpTestM era a
forall era a. IO a -> ImpTestM era a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ImpTestM era a
$cliftIO :: forall era a. IO a -> ImpTestM era a
MonadIO
    , forall era. MonadIO (ImpTestM era)
forall b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
forall era b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
$cwithRunInIO :: forall era b.
((forall a. ImpTestM era a -> IO a) -> IO b) -> ImpTestM era b
MonadUnliftIO
    , MonadReader (ImpTestEnv era)
    )

instance (Testable a, ShelleyEraImp era) => Testable (ImpTestM era a) where
  property :: ImpTestM era a -> Property
property ImpTestM era a
m = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSize ->
    forall prop. Testable prop => IO prop -> Property
ioProperty forall a b. (a -> b) -> a -> b
$ do
      ImpTestState era
impTestState <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasSubState s, SubState s ~ StateGen QCGen,
 HasStatefulGen (StateGenM s) m) =>
m (ImpTestState era)
initImpTestState (forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState @(EraCrypto era) (forall a. a -> Maybe a
Just QCGen
qcGen))
      forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM (forall a. a -> Maybe a
Just Int
qcSize) ImpTestState era
impTestState ImpTestM era a
m

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

instance MonadFail (ImpTestM era) where
  fail :: forall a. String -> ImpTestM era a
fail = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure

instance MonadState (ImpTestState era) (ImpTestM era) where
  get :: ImpTestM era (ImpTestState era)
get = forall era a. ReaderT (ImpTestEnv era) IO a -> ImpTestM era a
ImpTestM forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestEnv era -> IORef (ImpTestState era)
iteState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask
  put :: ImpTestState era -> ImpTestM era ()
put ImpTestState era
x = forall era a. ReaderT (ImpTestEnv era) IO a -> ImpTestM era a
ImpTestM forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IORef a -> a -> IO ()
writeIORef ImpTestState era
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestEnv era -> IORef (ImpTestState era)
iteState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask

instance (ShelleyEraImp era, Testable prop) => Example (ImpTestM era prop) where
  type Arg (ImpTestM era prop) = ImpTestState era

  evaluateExample :: ImpTestM era prop
-> Params
-> (ActionWith (Arg (ImpTestM era prop)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpTestM era prop
impTest =
    forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> ImpTestM era prop
impTest)

instance (ShelleyEraImp era, Arbitrary a, Show a, Testable prop) => Example (a -> ImpTestM era prop) where
  type Arg (a -> ImpTestM era prop) = ImpTestState era

  evaluateExample :: (a -> ImpTestM era prop)
-> Params
-> (ActionWith (Arg (a -> ImpTestM era prop)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> ImpTestM era prop
impTest Params
params ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook ProgressCallback
progressCallback =
    let runImpTestExample :: ImpTestState era -> Property
runImpTestExample ImpTestState era
s = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ \a
x -> do
          let args :: Args
args = Params -> Args
paramsQuickCheckArgs Params
params
          (Maybe (QCGen, Int)
r, prop
testable, Doc AnsiStyle
logs) <- forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM (forall era.
Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen Params
params ImpTestState era
s) forall a b. (a -> b) -> a -> b
$ do
            prop
t <- a -> ImpTestM era prop
impTest a
x
            Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
            StateGen QCGen
qcGen <- forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (g, g)
split
            Doc AnsiStyle
logs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall era. ImpTestState era -> Doc AnsiStyle
impLog
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (QCGen
qcGen, Int
qcSize), prop
t, Doc AnsiStyle
logs)
          let params' :: Params
params' = Params
params {paramsQuickCheckArgs :: Args
paramsQuickCheckArgs = Args
args {replay :: Maybe (QCGen, Int)
replay = Maybe (QCGen, Int)
r, chatty :: Bool
chatty = Bool
False}}
          Result
res <-
            forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample
              (forall prop. Testable prop => String -> prop -> Property
counterexample (Doc AnsiStyle -> String
ansiDocToString Doc AnsiStyle
logs) prop
testable)
              Params
params'
              (\ActionWith (Arg Property)
f -> ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook (\Arg (a -> ImpTestM era prop)
_st -> ActionWith (Arg Property)
f ()))
              ProgressCallback
progressCallback
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Result -> ResultStatus
resultStatus Result
res
     in forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpTestState era -> Property
runImpTestExample Params
params ActionWith (Arg (a -> ImpTestM era prop)) -> IO ()
hook ProgressCallback
progressCallback

instance MonadGen (ImpTestM era) where
  liftGen :: forall a. Gen a -> ImpTestM era a
liftGen (MkGen QCGen -> Int -> a
f) = do
    Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
    StateGen QCGen
qcGen <- forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM forall g. RandomGen g => g -> (g, g)
split
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ QCGen -> Int -> a
f QCGen
qcGen Int
qcSize
  variant :: forall n a. Integral n => n -> ImpTestM era a -> ImpTestM era a
variant n
n ImpTestM era a
action = do
    forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (\(StateGen QCGen
qcGen) -> ((), forall s. s -> StateGen s
StateGen (forall a. Splittable a => Integer -> a -> a
integerVariant (forall a. Integral a => a -> Integer
toInteger n
n) QCGen
qcGen)))
    ImpTestM era a
action
  sized :: forall a. (Int -> ImpTestM era a) -> ImpTestM era a
sized Int -> ImpTestM era a
f = do
    Int
qcSize <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Int
iteQuickCheckSize
    Int -> ImpTestM era a
f Int
qcSize
  resize :: forall a. Int -> ImpTestM era a -> ImpTestM era a
resize Int
n = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ImpTestEnv era
env -> ImpTestEnv era
env {iteQuickCheckSize :: Int
iteQuickCheckSize = Int
n})
  choose :: forall a. Random a => (a, a) -> ImpTestM era a
choose (a, a)
r = forall s (m :: * -> *) a.
(HasSubState s, MonadState s m) =>
(SubState s -> (a, SubState s)) -> m a
subStateM (forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (a, a)
r)

instance HasStatefulGen (StateGenM (ImpTestState era)) (ImpTestM era) where
  askStatefulGen :: ImpTestM era (StateGenM (ImpTestState era))
askStatefulGen = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall s. StateGenM s
StateGenM

instance HasSubState (ImpTestState era) where
  type SubState (ImpTestState era) = StateGen QCGen
  getSubState :: ImpTestState era -> SubState (ImpTestState era)
getSubState = forall s. s -> StateGen s
StateGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ImpTestState era -> QCGen
impGen
  setSubState :: ImpTestState era -> SubState (ImpTestState era) -> ImpTestState era
setSubState ImpTestState era
s (StateGen QCGen
g) = ImpTestState era
s {impGen :: QCGen
impGen = QCGen
g}

-- | Override the QuickCheck generator using a fixed seed.
impSetSeed :: Int -> ImpTestM era ()
impSetSeed :: forall era. Int -> ImpTestM era ()
impSetSeed Int
seed = forall s (m :: * -> *).
(HasSubState s, MonadState s m) =>
SubState s -> m ()
setSubStateM forall a b. (a -> b) -> a -> b
$ forall s. s -> StateGen s
StateGen forall a b. (a -> b) -> a -> b
$ Int -> QCGen
mkQCGen Int
seed

applyParamsQCGen :: Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen :: forall era.
Params -> ImpTestState era -> (Maybe Int, ImpTestState era)
applyParamsQCGen Params
params ImpTestState era
impTestState =
  case Args -> Maybe (QCGen, Int)
replay (Params -> Args
paramsQuickCheckArgs Params
params) of
    Maybe (QCGen, Int)
Nothing -> (forall a. Maybe a
Nothing, ImpTestState era
impTestState)
    Just (QCGen
qcGen, Int
qcSize) -> (forall a. a -> Maybe a
Just Int
qcSize, forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impTestState QCGen
qcGen)

-- | Instead of reqplacing the current QC generator in the state, we use the current and
-- the supplied to make the new generator
mixinCurrentGen :: ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen :: forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impTestState QCGen
qcGen =
  ImpTestState era
impTestState {impGen :: QCGen
impGen = forall a. Splittable a => Integer -> a -> a
integerVariant (forall a b. (a, b) -> a
fst (forall a g. (Random a, RandomGen g) => g -> (a, g)
Random.random (forall era. ImpTestState era -> QCGen
impGen ImpTestState era
impTestState))) QCGen
qcGen}

evalImpTestGenM :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO b)
evalImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO b)
evalImpTestGenM ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState

evalImpTestM ::
  ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b
evalImpTestM Maybe Int
qc ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qc ImpTestState era
impState

execImpTestGenM ::
  ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era))
execImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era))
execImpTestGenM ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState

emptyImpPrepState :: Maybe QCGen -> ImpPrepState c
emptyImpPrepState :: forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState Maybe QCGen
mQCGen =
  ImpPrepState
    { impPrepKeyPairs :: Map (KeyHash 'Witness c) (KeyPair 'Witness c)
impPrepKeyPairs = forall a. Monoid a => a
mempty
    , impPrepByronKeyPairs :: Map (BootstrapAddress c) ByronKeyPair
impPrepByronKeyPairs = forall a. Monoid a => a
mempty
    , impPrepGen :: QCGen
impPrepGen = forall a. a -> Maybe a -> a
fromMaybe (Int -> QCGen
mkQCGen Int
2024) Maybe QCGen
mQCGen
    }

execImpTestM ::
  ShelleyEraImp era =>
  Maybe Int ->
  ImpTestState era ->
  ImpTestM era b ->
  IO (ImpTestState era)
execImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (ImpTestState era)
execImpTestM Maybe Int
qcSize ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qcSize ImpTestState era
impState

runImpTestGenM_ :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO ())
runImpTestGenM_ :: forall era b.
ShelleyEraImp era =>
ImpTestState era -> ImpTestM era b -> Gen (IO ())
runImpTestGenM_ ImpTestState era
impState = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState

runImpTestM_ ::
  ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO ()
runImpTestM_ :: forall era b.
ShelleyEraImp era =>
Maybe Int -> ImpTestState era -> ImpTestM era b -> IO ()
runImpTestM_ Maybe Int
qcSize ImpTestState era
impState = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
qcSize ImpTestState era
impState

runImpTestGenM ::
  ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM :: forall era b.
ShelleyEraImp era =>
ImpTestState era
-> ImpTestM era b -> Gen (IO (b, ImpTestState era))
runImpTestGenM ImpTestState era
impState ImpTestM era b
m =
  forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSz -> forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM (forall a. a -> Maybe a
Just Int
qcSz) (forall era. ImpTestState era -> QCGen -> ImpTestState era
mixinCurrentGen ImpTestState era
impState QCGen
qcGen) ImpTestM era b
m

runImpTestM ::
  ShelleyEraImp era =>
  Maybe Int ->
  ImpTestState era ->
  ImpTestM era b ->
  IO (b, ImpTestState era)
runImpTestM :: forall era b.
ShelleyEraImp era =>
Maybe Int
-> ImpTestState era -> ImpTestM era b -> IO (b, ImpTestState era)
runImpTestM Maybe Int
mQCSize ImpTestState era
impState ImpTestM era b
action = do
  let qcSize :: Int
qcSize = forall a. a -> Maybe a -> a
fromMaybe Int
30 Maybe Int
mQCSize
  IORef (ImpTestState era)
ioRef <- forall a. a -> IO (IORef a)
newIORef ImpTestState era
impState
  let
    env :: ImpTestEnv era
env =
      ImpTestEnv
        { iteState :: IORef (ImpTestState era)
iteState = IORef (ImpTestState era)
ioRef
        , iteFixup :: Tx era -> ImpTestM era (Tx era)
iteFixup = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx
        , iteQuickCheckSize :: Int
iteQuickCheckSize = Int
qcSize
        , iteCborRoundTripFailures :: Bool
iteCborRoundTripFailures = Bool
True
        }
  b
res <-
    -- 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
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall era a. ImpTestM era a -> ReaderT (ImpTestEnv era) IO a
unImpTestM (forall era. (HasCallStack, ShelleyEraImp era) => ImpTestM era ()
passTick forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ImpTestM era b
action)) ImpTestEnv era
env forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
exc -> do
      Doc AnsiStyle
logs <- forall era. ImpTestState era -> Doc AnsiStyle
impLog forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (ImpTestState era)
ioRef
      let [Doc ann]
x <?> :: [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe a
my = case Maybe a
my of
            Maybe a
Nothing -> [Doc ann]
x
            Just a
y -> [Doc ann]
x forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty a
y]
          uncaughtException :: [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header e
excThrown =
            String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$
              Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$
                forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
                  [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ String
"Uncaught Exception: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException e
excThrown]
          fromHUnitFailure :: [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header (HUnitFailure Maybe SrcLoc
mSrcLoc FailureReason
failReason) =
            case FailureReason
failReason of
              Reason String
msg ->
                Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) forall a b. (a -> b) -> a -> b
$
                  String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$
                    Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$
                      forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
                        [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
              ExpectedButGot Maybe String
mMsg String
expected String
got ->
                Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) forall a b. (a -> b) -> a -> b
$
                  Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mMsg))) String
expected String
got
          adjustFailureReason :: [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header = \case
            H.Failure Maybe Location
mLoc FailureReason
failureReason ->
              Maybe Location -> FailureReason -> ResultStatus
H.Failure Maybe Location
mLoc forall a b. (a -> b) -> a -> b
$
                case FailureReason
failureReason of
                  FailureReason
H.NoReason ->
                    String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
"NoReason"]
                  H.Reason String
msg ->
                    String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
                  H.ColorizedReason String
msg ->
                    String -> FailureReason
H.ColorizedReason forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty String
msg]
                  H.ExpectedButGot Maybe String
mPreface String
expected String
actual ->
                    Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mPreface))) String
expected String
actual
                  H.Error Maybe String
mInfo SomeException
excThrown -> forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException ([Doc AnsiStyle]
header forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mInfo) SomeException
excThrown
            ResultStatus
result -> ResultStatus
result
          newExc :: ResultStatus
newExc
            | Just HUnitFailure
hUnitExc <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle
logs] HUnitFailure
hUnitExc
            | Just ResultStatus
hspecFailure <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle
logs] ResultStatus
hspecFailure
            | Just (ImpException [Doc AnsiStyle]
ann SomeException
excThrown) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc =
                let annLen :: Int
annLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc AnsiStyle]
ann
                    header :: [Doc AnsiStyle]
header =
                      Doc AnsiStyle
logs
                        forall a. a -> [a] -> [a]
: [ let prefix :: Doc AnsiStyle
prefix
                                  | Int
annLen forall a. Ord a => a -> a -> Bool
<= Int
1 = Doc AnsiStyle
"╺╸"
                                  | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = Doc AnsiStyle
"┏╸"
                                  | Int
n forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
annLen = forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗━╸"
                                  | Bool
otherwise = forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗┳╸"
                             in forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
prefix forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) Doc AnsiStyle
a
                          | (Int
n, Doc AnsiStyle
a) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Doc AnsiStyle]
ann
                          ]
                        forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle
""]
                 in case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
                      Just HUnitFailure
hUnitExc -> [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header HUnitFailure
hUnitExc
                      Maybe HUnitFailure
Nothing ->
                        case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
                          Just ResultStatus
hspecFailure -> [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header ResultStatus
hspecFailure
                          Maybe ResultStatus
Nothing -> Maybe Location -> FailureReason -> ResultStatus
H.Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header SomeException
excThrown
            | Bool
otherwise = Maybe Location -> FailureReason -> ResultStatus
H.Failure forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle
logs] SomeException
exc
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ResultStatus
newExc
  ImpTestState era
endState <- forall a. IORef a -> IO a
readIORef IORef (ImpTestState era)
ioRef
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
res, ImpTestState era
endState)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Stores extra information about the failure of the unit test
data ImpException = ImpException
  { ImpException -> [Doc AnsiStyle]
ieAnnotation :: [Doc AnsiStyle]
  -- ^ Description of the IO action that caused the failure
  , ImpException -> SomeException
ieThrownException :: SomeException
  -- ^ Exception that caused the test to fail
  }
  deriving (Int -> ImpException -> ShowS
[ImpException] -> ShowS
ImpException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImpException] -> ShowS
$cshowList :: [ImpException] -> ShowS
show :: ImpException -> String
$cshow :: ImpException -> String
showsPrec :: Int -> ImpException -> ShowS
$cshowsPrec :: Int -> ImpException -> ShowS
Show)

instance Exception ImpException where
  displayException :: ImpException -> String
displayException = Doc AnsiStyle -> String
ansiDocToString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpException -> Doc AnsiStyle
prettyImpException

prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException (ImpException [Doc AnsiStyle]
ann SomeException
e) =
  forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
    forall a. Monoid a => [a] -> a
mconcat
      [ [Doc AnsiStyle
"Annotations:"]
      , forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall ann. Int -> Doc ann -> Doc ann
indent [Int
0, Int
2 ..] [Doc AnsiStyle]
ann
      , [Doc AnsiStyle
"Failed with Exception:", forall ann. Int -> Doc ann -> Doc ann
indent Int
4 forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall e. Exception e => e -> String
displayException SomeException
e)]
      ]

-- | Annotation for when failure happens. All the logging done within annotation will be
-- discarded if there no failures within the annotation.
impAnn :: NFData a => String -> ImpTestM era a -> ImpTestM era a
impAnn :: forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
msg = forall a era.
NFData a =>
Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc (forall a ann. Pretty a => a -> Doc ann
pretty String
msg)

impAnnDoc :: NFData a => Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc :: forall a era.
NFData a =>
Doc AnsiStyle -> ImpTestM era a -> ImpTestM era a
impAnnDoc Doc AnsiStyle
msg ImpTestM era a
m = do
  Doc AnsiStyle
logs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL
  a
res <- forall a (m :: * -> *).
(NFData a, MonadUnliftIO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep ImpTestM era a
m forall a b. (a -> b) -> a -> b
$ \SomeException
exc ->
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
      case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
        Just (ImpException [Doc AnsiStyle]
ann SomeException
origExc) -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException (Doc AnsiStyle
msg forall a. a -> [a] -> [a]
: [Doc AnsiStyle]
ann) SomeException
origExc
        Maybe ImpException
Nothing -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException [Doc AnsiStyle
msg] SomeException
exc
  forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Doc AnsiStyle
logs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Adds a source location and Doc to the log, which are only shown if the test fails
logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack :: forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack CallStack
callStack Doc AnsiStyle
entry = forall era. Lens' (ImpTestState era) (Doc AnsiStyle)
impLogL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
stack forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc AnsiStyle
entry forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line)
  where
    prettySrcLoc' :: SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc {Int
String
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} =
      forall ann. [Doc ann] -> Doc ann
hcat
        [ forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
c) Doc AnsiStyle
d
        | (Color
c, Doc AnsiStyle
d) <-
            [ (Color
Yellow, Doc AnsiStyle
"[")
            , (Color
Blue, forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocModule)
            , (Color
Yellow, Doc AnsiStyle
":")
            , (Color
Magenta, forall a ann. Pretty a => a -> Doc ann
pretty Int
srcLocStartLine)
            , (Color
Yellow, Doc AnsiStyle
"]")
            ]
        ]
    prefix :: Int -> Doc ann
prefix Int
n = if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 then Doc ann
"" else forall ann. Int -> Doc ann -> Doc ann
indent (Int
n forall a. Num a => a -> a -> a
- Int
1) Doc ann
"└"
    stack :: Doc AnsiStyle
stack = forall ann. [Doc ann] -> Doc ann
vsep [forall {ann}. Int -> Doc ann
prefix Int
n forall a. Semigroup a => a -> a -> a
<> SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc
loc | (Int
n, (String
_, SrcLoc
loc)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0, Int
2 ..] (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
callStack)]

-- | Adds a Doc to the log, which is only shown if the test fails
logDoc :: HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc :: forall era. HasCallStack => Doc AnsiStyle -> ImpTestM era ()
logDoc = forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack HasCallStack
?callStack

-- | Adds a String to the log, which is only shown if the test fails
logString :: HasCallStack => String -> ImpTestM era ()
logString :: forall era. HasCallStack => String -> ImpTestM era ()
logString = forall era. CallStack -> Doc AnsiStyle -> ImpTestM era ()
logWithCallStack HasCallStack
?callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

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

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

withImpState ::
  ShelleyEraImp era =>
  SpecWith (ImpTestState era) ->
  Spec
withImpState :: forall era.
ShelleyEraImp era =>
SpecWith (ImpTestState era) -> Spec
withImpState = forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era)
-> SpecWith (ImpTestState era) -> Spec
withImpStateModified forall a. a -> a
id

withImpStateModified ::
  forall era.
  ShelleyEraImp era =>
  (ImpTestState era -> ImpTestState era) ->
  SpecWith (ImpTestState era) ->
  Spec
withImpStateModified :: forall era.
ShelleyEraImp era =>
(ImpTestState era -> ImpTestState era)
-> SpecWith (ImpTestState era) -> Spec
withImpStateModified ImpTestState era -> ImpTestState era
f =
  forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll (ImpTestState era -> ImpTestState era
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall era s (m :: * -> *).
(ShelleyEraImp era, HasKeyPairs s (EraCrypto era), MonadState s m,
 HasSubState s, SubState s ~ StateGen QCGen,
 HasStatefulGen (StateGenM s) m) =>
m (ImpTestState era)
initImpTestState (forall c. Maybe QCGen -> ImpPrepState c
emptyImpPrepState @(EraCrypto era) forall a. Maybe a
Nothing))

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

freshKeyHashVRF ::
  Era era =>
  ImpTestM era (Hash (HASH (EraCrypto era)) (VerKeyVRF (EraCrypto era)))
freshKeyHashVRF :: forall era.
Era era =>
ImpTestM
  era (Hash (HASH (EraCrypto era)) (VerKeyVRF (EraCrypto era)))
freshKeyHashVRF = forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary

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

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

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

-- | Generate a random `KeyPair` and add it to the known keys in the Imp state
freshKeyPair ::
  (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
  m (KeyHash r c, KeyPair r c)
freshKeyPair :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair = do
  KeyPair r c
keyPair <- forall g (m :: * -> *) a. (HasStatefulGen g m, Uniform a) => m a
uniformM
  KeyHash r c
keyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m) =>
KeyPair r c -> m (KeyHash r c)
addKeyPair KeyPair r c
keyPair
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash r c
keyHash, KeyPair r c
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 c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (Addr c)
freshKeyAddr_ :: forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_ = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, Addr c)
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 c, MonadState s m, HasStatefulGen (StateGenM s) m) =>
  m (KeyHash r c, Addr c)
freshKeyAddr :: forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, Addr c)
freshKeyAddr = do
  KeyHash 'Payment c
keyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash 'Payment c
keyHash, forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Payment c
keyHash) forall c. StakeReference c
StakeRefNull)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lookupReward :: HasCallStack => Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward :: forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
stakingCredential = do
  UMap (EraCrypto era)
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (UMap (EraCrypto era))
epochStateUMapL)
  case forall k c v. k -> UView c k v -> Maybe v
UMap.lookup Credential 'Staking (EraCrypto era)
stakingCredential (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
umap) of
    Maybe RDPair
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        String
"Staking Credential is not found in the state: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
stakingCredential
          forall a. Semigroup a => a -> a -> a
<> String
"\nMake sure you have the reward account registered with `registerRewardAccount` "
          forall a. Semigroup a => a -> a -> a
<> String
"or by some other means."
    Just RDPair
rd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact (RDPair -> CompactForm Coin
rdReward RDPair
rd)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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