{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Conway.ImpTest (
  module Test.Cardano.Ledger.Babbage.ImpTest,
  ConwayEraImp,
  enactConstitution,
  enactTreasuryWithdrawals,
  submitGovAction,
  submitGovAction_,
  submitGovActions,
  submitProposal,
  submitAndExpireProposalToMakeReward,
  submitProposal_,
  submitProposals,
  submitFailingProposal,
  trySubmitGovAction,
  trySubmitGovActions,
  trySubmitProposal,
  trySubmitProposals,
  mkConstitutionProposal,
  mkProposal,
  mkProposalWithRewardAccount,
  mkTreasuryWithdrawalsGovAction,
  submitTreasuryWithdrawals,
  submitVote,
  submitVote_,
  submitYesVote_,
  submitFailingVote,
  trySubmitVote,
  registerDRep,
  unRegisterDRep,
  updateDRep,
  delegateToDRep,
  setupSingleDRep,
  setupDRepWithoutStake,
  setupPoolWithStake,
  setupPoolWithoutStake,
  conwayModifyPParams,
  getProposals,
  getEnactState,
  getGovActionState,
  lookupGovActionState,
  expectPresentGovActionId,
  expectMissingGovActionId,
  getRatifyEnv,
  calculateDRepAcceptedRatio,
  calculatePoolAcceptedRatio,
  calculateCommitteeAcceptedRatio,
  logAcceptedRatio,
  isDRepAccepted,
  isSpoAccepted,
  isCommitteeAccepted,
  getCommitteeMembers,
  getConstitution,
  registerInitialCommittee,
  logRatificationChecks,
  resignCommitteeColdKey,
  registerCommitteeHotKey,
  registerCommitteeHotKeys,
  logCurPParams,
  electCommittee,
  electBasicCommittee,
  proposalsShowDebug,
  getGovPolicy,
  submitFailingGovAction,
  submitGovActionForest,
  submitGovActionTree,
  getProposalsForest,
  logProposalsForest,
  logProposalsForestDiff,
  getCCExpiry,
  ccShouldBeExpired,
  ccShouldNotBeExpired,
  ccShouldBeResigned,
  ccShouldNotBeResigned,
  getLastEnactedCommittee,
  getLastEnactedConstitution,
  submitParameterChange,
  mkMinFeeUpdateGovAction,
  mkParameterChangeGovAction,
  mkUpdateCommitteeProposal,
  submitUpdateCommittee,
  expectCommitteeMemberPresence,
  expectCommitteeMemberAbsence,
  getLastEnactedParameterChange,
  getLastEnactedHardForkInitiation,
  getConstitutionProposals,
  getParameterChangeProposals,
  expectNumDormantEpochs,
  submitConstitution,
  isDRepExpired,
  expectDRepExpiry,
  expectActualDRepExpiry,
  expectDRepNotRegistered,
  expectCurrentProposals,
  expectNoCurrentProposals,
  expectPulserProposals,
  expectNoPulserProposals,
  minorFollow,
  majorFollow,
  cantFollow,
  getsPParams,
  currentProposalsShouldContain,
  ifBootstrap,
  whenBootstrap,
  whenPostBootstrap,
  submitYesVoteCCs_,
  donateToTreasury,
  expectMembers,
  showConwayTxBalance,
  logConwayTxBalance,
  submitBootstrapAware,
  submitBootstrapAwareFailingVote,
  submitBootstrapAwareFailingProposal,
  submitBootstrapAwareFailingProposal_,
  SubmitFailureExpectation (..),
  FailBoth (..),
  delegateSPORewardAddressToDRep_,
) where

import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
import Cardano.Ledger.Allegra.Scripts (Timelock)
import Cardano.Ledger.Alonzo.Scripts (AlonzoScript)
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  Network (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  addEpochInterval,
  binOpEpochNo,
  inject,
  succVersion,
  textToUrl,
 )
import Cardano.Ledger.CertState (
  CertState,
  CommitteeAuthorization (..),
  certDStateL,
  certPStateL,
  csCommitteeCredsL,
  lookupDepositDState,
  lookupDepositVState,
  psStakePoolParamsL,
  vsActualDRepExpiry,
  vsNumDormantEpochsL,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..))
import Cardano.Ledger.Conway.Rules (
  EnactSignal,
  committeeAccepted,
  committeeAcceptedRatio,
  dRepAccepted,
  dRepAcceptedRatio,
  prevActionAsExpected,
  spoAccepted,
  spoAcceptedRatio,
  validCommitteeTerm,
  withdrawalCanWithdraw,
 )
import Cardano.Ledger.Conway.Tx (AlonzoTx)
import Cardano.Ledger.Conway.TxCert (Delegatee (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..), hashPlutusScript)
import Cardano.Ledger.PoolParams (PoolParams (..), ppRewardAccount)
import qualified Cardano.Ledger.Shelley.HardForks as HardForks (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState (
  IncrementalStake (..),
  asTreasuryL,
  certVStateL,
  consumed,
  curPParamsEpochStateL,
  epochStateGovStateL,
  epochStatePoolParamsL,
  esAccountStateL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEpochStateL,
  nesEsL,
  nesPdL,
  newEpochStateGovStateL,
  produced,
  unifiedL,
  utxosGovStateL,
  utxosStakeDistrL,
  utxosUtxoL,
  vsCommitteeStateL,
  vsDRepsL,
 )
import Cardano.Ledger.TxIn (TxId (..))
import Cardano.Ledger.UMap (dRepMap)
import Cardano.Ledger.UTxO (EraUTxO, UTxO, balance, sumAllValue, txInsFilter)
import Cardano.Ledger.Val (Val (..), (<->))
import Control.Monad (forM)
import Control.Monad.Trans.Fail.String (errorFail)
import Control.State.Transition.Extended (STS (..))
import Data.Bifunctor (bimap)
import Data.Default (Default (..))
import Data.Foldable (Foldable (..))
import Data.Functor.Identity
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Tree
import qualified GHC.Exts as GHC (fromList)
import Lens.Micro
import Prettyprinter (align, hsep, viaShow, vsep)
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.TreeDiff (tableDoc)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkCred)
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (testingCostModel)
import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript)

-- | Modify the PParams in the current state with the given function
conwayModifyPParams ::
  ConwayEraGov era =>
  (PParams era -> PParams era) ->
  ImpTestM era ()
conwayModifyPParams :: forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams PParams era -> PParams era
f = forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES forall a b. (a -> b) -> a -> b
$ \NewEpochState era
nes ->
  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. 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
    forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser
  where
    modifyDRepPulser :: DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser DRepPulsingState era
pulser =
      case forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
pulser of
        (PulsingSnapshot era
snapshot, RatifyState era
ratifyState) ->
          forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snapshot (RatifyState era
ratifyState forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EnactState era) (PParams era)
ensCurPParamsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f)

instance ShelleyEraImp ConwayEra where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (Genesis ConwayEra)
initGenesis = do
    KeyHash 'ColdCommitteeRole
kh1 <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    KeyHash 'ColdCommitteeRole
kh2 <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let
      ccExpiryEpochNo :: EpochNo
ccExpiryEpochNo = EpochNo -> EpochInterval -> EpochNo
addEpochInterval (forall era. Era era => EpochNo
impEraStartEpochNo @ConwayEra) (Word32 -> EpochInterval
EpochInterval Word32
15)
      committee :: Committee ConwayEra
committee = forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
Committee [(forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'ColdCommitteeRole
kh1, EpochNo
ccExpiryEpochNo), (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'ColdCommitteeRole
kh2, EpochNo
ccExpiryEpochNo)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
      constitutionAnchor :: Anchor
constitutionAnchor =
        Anchor
          { anchorUrl :: Url
anchorUrl = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
128 Text
"https://cardano-constitution.crypto"
          , anchorDataHash :: SafeHash AnchorData
anchorDataHash = forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (ByteString -> AnchorData
AnchorData ByteString
"Cardano Constitution Content")
          }
      guardrailScriptHash :: ScriptHash
guardrailScriptHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus 'PlutusV3
guardrailScript
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ConwayGenesis
        { cgUpgradePParams :: UpgradeConwayPParams Identity
cgUpgradePParams =
            UpgradeConwayPParams
              { ucppPoolVotingThresholds :: HKD Identity PoolVotingThresholds
ucppPoolVotingThresholds =
                  PoolVotingThresholds
                    { pvtMotionNoConfidence :: UnitInterval
pvtMotionNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtCommitteeNormal :: UnitInterval
pvtCommitteeNormal = Integer
65 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtCommitteeNoConfidence :: UnitInterval
pvtCommitteeNoConfidence = Integer
65 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtHardForkInitiation :: UnitInterval
pvtHardForkInitiation = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , pvtPPSecurityGroup :: UnitInterval
pvtPPSecurityGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    }
              , ucppDRepVotingThresholds :: HKD Identity DRepVotingThresholds
ucppDRepVotingThresholds =
                  DRepVotingThresholds
                    { dvtMotionNoConfidence :: UnitInterval
dvtMotionNoConfidence = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtCommitteeNormal :: UnitInterval
dvtCommitteeNormal = Integer
65 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtCommitteeNoConfidence :: UnitInterval
dvtCommitteeNoConfidence = Integer
65 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtUpdateToConstitution :: UnitInterval
dvtUpdateToConstitution = Integer
65 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtHardForkInitiation :: UnitInterval
dvtHardForkInitiation = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPNetworkGroup :: UnitInterval
dvtPPNetworkGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPEconomicGroup :: UnitInterval
dvtPPEconomicGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPTechnicalGroup :: UnitInterval
dvtPPTechnicalGroup = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtPPGovGroup :: UnitInterval
dvtPPGovGroup = Integer
75 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    , dvtTreasuryWithdrawal :: UnitInterval
dvtTreasuryWithdrawal = Integer
51 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                    }
              , ucppCommitteeMinSize :: HKD Identity Word16
ucppCommitteeMinSize = Word16
1
              , ucppCommitteeMaxTermLength :: HKD Identity EpochInterval
ucppCommitteeMaxTermLength = Word32 -> EpochInterval
EpochInterval Word32
20
              , ucppGovActionLifetime :: HKD Identity EpochInterval
ucppGovActionLifetime = Word32 -> EpochInterval
EpochInterval Word32
30
              , ucppGovActionDeposit :: HKD Identity Coin
ucppGovActionDeposit = Integer -> Coin
Coin Integer
123
              , ucppDRepDeposit :: HKD Identity Coin
ucppDRepDeposit = Integer -> Coin
Coin Integer
70_000_000
              , ucppDRepActivity :: HKD Identity EpochInterval
ucppDRepActivity = Word32 -> EpochInterval
EpochInterval Word32
100
              , ucppMinFeeRefScriptCostPerByte :: HKD Identity NonNegativeInterval
ucppMinFeeRefScriptCostPerByte = Integer
15 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
              , ucppPlutusV3CostModel :: HKD Identity CostModel
ucppPlutusV3CostModel = HasCallStack => Language -> CostModel
testingCostModel Language
PlutusV3
              }
        , cgConstitution :: Constitution ConwayEra
cgConstitution = forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
constitutionAnchor (forall a. a -> StrictMaybe a
SJust ScriptHash
guardrailScriptHash)
        , cgCommittee :: Committee ConwayEra
cgCommittee = Committee ConwayEra
committee
        , cgDelegs :: ListMap (Credential 'Staking) Delegatee
cgDelegs = forall a. Monoid a => a
mempty
        , cgInitialDReps :: ListMap (Credential 'DRepRole) DRepState
cgInitialDReps = forall a. Monoid a => a
mempty
        }

  impSatisfyNativeScript :: Set (KeyHash 'Witness)
-> TxBody ConwayEra
-> NativeScript ConwayEra
-> ImpTestM
     ConwayEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript

  modifyPParams :: (PParams ConwayEra -> PParams ConwayEra) -> ImpTestM ConwayEra ()
modifyPParams = forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams

  fixupTx :: HasCallStack => Tx ConwayEra -> ImpTestM ConwayEra (Tx ConwayEra)
fixupTx = forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx

instance MaryEraImp ConwayEra

instance AlonzoEraImp ConwayEra where
  scriptTestContexts :: Map ScriptHash ScriptTestContext
scriptTestContexts =
    forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1
      forall a. Semigroup a => a -> a -> a
<> forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV2
SPlutusV2
      forall a. Semigroup a => a -> a -> a
<> forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV3
SPlutusV3

class
  ( AlonzoEraImp era
  , ConwayEraGov era
  , ConwayEraTxBody era
  , ConwayEraTxCert era
  , ConwayEraPParams era
  , STS (EraRule "ENACT" era)
  , BaseM (EraRule "ENACT" era) ~ ShelleyBase
  , State (EraRule "ENACT" era) ~ EnactState era
  , Signal (EraRule "ENACT" era) ~ EnactSignal era
  , Environment (EraRule "ENACT" era) ~ ()
  , NativeScript era ~ Timelock era
  , Script era ~ AlonzoScript era
  , GovState era ~ ConwayGovState era
  ) =>
  ConwayEraImp era

instance ConwayEraImp ConwayEra

registerInitialCommittee ::
  (HasCallStack, ConwayEraImp era) =>
  ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee = do
  [Credential 'ColdCommitteeRole]
committeeMembers <- forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
  case [Credential 'ColdCommitteeRole]
committeeMembers of
    Credential 'ColdCommitteeRole
x : [Credential 'ColdCommitteeRole]
xs -> forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole)
-> NonEmpty (Credential 'ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerCommitteeHotKeys (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash) forall a b. (a -> b) -> a -> b
$ Credential 'ColdCommitteeRole
x forall a. a -> [a] -> NonEmpty a
NE.:| [Credential 'ColdCommitteeRole]
xs
    [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"Expected an initial committee"

-- | Submit a transaction that registers a new DRep and return the keyhash
-- belonging to that DRep
registerDRep :: ConwayEraImp era => ImpTestM era (KeyHash 'DRepRole)
registerDRep :: forall era. ConwayEraImp era => ImpTestM era (KeyHash 'DRepRole)
registerDRep = do
  -- Register a DRep
  KeyHash 'DRepRole
khDRep <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  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
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Register DRep" 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.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert
              (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
khDRep)
              (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL)
              forall a. StrictMaybe a
SNothing
          )
  Map (Credential 'DRepRole) DRepState
dreps <- 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
  Map (Credential 'DRepRole) DRepState
dreps forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall k a. Ord k => k -> Map k a -> Bool
Map.member (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
khDRep)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash 'DRepRole
khDRep

-- | Submit a transaction that unregisters a given DRep
unRegisterDRep ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential 'DRepRole ->
  ImpTestM era ()
unRegisterDRep :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'DRepRole -> ImpTestM era ()
unRegisterDRep Credential 'DRepRole
drep = do
  DRepState
drepState <- forall era.
HasCallStack =>
Credential 'DRepRole -> ImpTestM era DRepState
lookupDRepState Credential 'DRepRole
drep
  let refund :: Coin
refund = DRepState -> Coin
drepDeposit DRepState
drepState
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"UnRegister DRep" 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.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential 'DRepRole
drep Coin
refund)

-- | Submit a transaction that updates a given DRep
updateDRep ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential 'DRepRole ->
  ImpTestM era ()
updateDRep :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'DRepRole -> ImpTestM era ()
updateDRep Credential 'DRepRole
drep = do
  StrictMaybe Anchor
mAnchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Update DRep" 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.
ConwayEraTxCert era =>
Credential 'DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert Credential 'DRepRole
drep StrictMaybe Anchor
mAnchor)

-- | In contrast to `setupSingleDRep`, this function does not make a UTxO entry
-- that could count as delegated stake to the DRep
setupDRepWithoutStake ::
  ConwayEraImp era =>
  ImpTestM era (KeyHash 'DRepRole, KeyHash 'Staking)
setupDRepWithoutStake :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole, KeyHash 'Staking)
setupDRepWithoutStake = do
  KeyHash 'DRepRole
drepKH <- forall era. ConwayEraImp era => ImpTestM era (KeyHash 'DRepRole)
registerDRep
  KeyHash 'Staking
delegatorKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  Coin
deposit <- 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) Coin
ppKeyDepositL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to DRep" 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.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert
              (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
delegatorKH)
              (DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
drepKH))
              Coin
deposit
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'DRepRole
drepKH, KeyHash 'Staking
delegatorKH)

-- | Registers a new DRep, registers its stake credentials and delegates the specified amount of ADA to it.
setupSingleDRep ::
  ConwayEraImp era =>
  Integer ->
  ImpTestM era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep :: forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
stake = do
  KeyHash 'DRepRole
drepKH <- forall era. ConwayEraImp era => ImpTestM era (KeyHash 'DRepRole)
registerDRep
  KeyHash 'Staking
delegatorKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  Coin
deposit <- 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) Coin
ppKeyDepositL
  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 (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.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert
                  (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
delegatorKH)
                  Coin
deposit
              ]
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
  KeyPair 'Payment
spendingKP <-
    forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
delegatorKH) (Integer -> Coin
Coin Integer
stake) (Credential 'DRepRole -> DRep
DRepCredential (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
drepKH))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
drepKH, forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
delegatorKH, KeyPair 'Payment
spendingKP)

delegateToDRep ::
  ConwayEraImp era =>
  Credential 'Staking ->
  Coin ->
  DRep ->
  ImpTestM era (KeyPair 'Payment)
delegateToDRep :: forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred Coin
stake DRep
dRep = do
  (KeyHash 'Payment
_, KeyPair 'Payment
spendingKP) <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair
  let addr :: Addr
addr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Payment
spendingKP) (Credential 'Staking -> StakeReference
StakeRefBase Credential 'Staking
cred)
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to DRep" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton
          ( forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
              Addr
addr
              (forall t s. Inject t s => t -> s
inject Coin
stake)
          )
      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.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> TxCert era
DelegTxCert
              Credential 'Staking
cred
              (DRep -> Delegatee
DelegVote DRep
dRep)
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyPair 'Payment
spendingKP

lookupDRepState ::
  HasCallStack =>
  Credential 'DRepRole ->
  ImpTestM era DRepState
lookupDRepState :: forall era.
HasCallStack =>
Credential 'DRepRole -> ImpTestM era DRepState
lookupDRepState Credential 'DRepRole
dRepCred = do
  Map (Credential 'DRepRole) DRepState
drepsState <- 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
dRepCred Map (Credential 'DRepRole) DRepState
drepsState of
    Maybe DRepState
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Expected for DRep " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'DRepRole
dRepCred forall a. [a] -> [a] -> [a]
++ [Char]
" to be present in the CertState"
    Just DRepState
state -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DRepState
state

getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams :: forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams Lens' (PParams era) a
f = 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
. Lens' (PParams era) a
f

-- | Sets up a stake pool with coin delegated to it.
--
-- NOTE: This uses the `RegDepositDelegTxCert` for delegating, so it has to be
-- in Conway. The Shelley version of this function would have to separately
-- register the staking credential and then delegate it.
setupPoolWithStake ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Coin ->
  ImpTestM era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake Coin
delegCoin = do
  KeyHash 'StakePool
khPool <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> ImpTestM era ()
registerPool KeyHash 'StakePool
khPool
  PaymentCredential
credDelegatorPayment <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  Credential 'Staking
credDelegatorStaking <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo
      (Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet PaymentCredential
credDelegatorPayment (Credential 'Staking -> StakeReference
StakeRefBase Credential 'Staking
credDelegatorStaking))
      Coin
delegCoin
  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
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to 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.fromList
          [ forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert
              Credential 'Staking
credDelegatorStaking
              (KeyHash 'StakePool -> Delegatee
DelegStake KeyHash 'StakePool
khPool)
              (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
khPool, PaymentCredential
credDelegatorPayment, Credential 'Staking
credDelegatorStaking)

setupPoolWithoutStake ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  ImpTestM era (KeyHash 'StakePool, Credential 'Staking)
setupPoolWithoutStake :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (KeyHash 'StakePool, Credential 'Staking)
setupPoolWithoutStake = do
  KeyHash 'StakePool
khPool <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> ImpTestM era ()
registerPool KeyHash 'StakePool
khPool
  Credential 'Staking
credDelegatorStaking <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  Coin
deposit <- 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) Coin
ppKeyDepositL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Delegate to 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.fromList
          [ forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert
              Credential 'Staking
credDelegatorStaking
              (KeyHash 'StakePool -> Delegatee
DelegStake KeyHash 'StakePool
khPool)
              Coin
deposit
          ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
khPool, Credential 'Staking
credDelegatorStaking)

-- | Submits a transaction with a Vote for the given governance action as
-- some voter
submitVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Vote ->
  Voter ->
  GovActionId ->
  ImpTestM era TxId
submitVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era TxId
submitVote Vote
vote Voter
voter GovActionId
gaId = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter
-> GovActionId
-> ImpTestM
     era
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
trySubmitVote Vote
vote Voter
voter GovActionId
gaId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m b
expectRightDeep

-- | Submits a transaction that votes "Yes" for the given governance action as
-- some voter
submitYesVote_ ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Voter ->
  GovActionId ->
  ImpTestM era ()
submitYesVote_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ Voter
voter GovActionId
gaId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era TxId
submitVote Vote
VoteYes Voter
voter GovActionId
gaId

submitVote_ ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Vote ->
  Voter ->
  GovActionId ->
  ImpTestM era ()
submitVote_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era ()
submitVote_ Vote
vote Voter
voter GovActionId
gaId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era TxId
submitVote Vote
vote Voter
voter GovActionId
gaId

submitFailingVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  Voter ->
  GovActionId ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter
-> GovActionId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingVote Voter
voter GovActionId
gaId NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure =
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter
-> GovActionId
-> ImpTestM
     era
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
trySubmitVote Vote
VoteYes Voter
voter GovActionId
gaId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

-- | Submits a transaction that votes "Yes" for the given governance action as
-- some voter, and expects an `Either` result.
trySubmitVote ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  Vote ->
  Voter ->
  GovActionId ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
trySubmitVote :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
Vote
-> Voter
-> GovActionId
-> ImpTestM
     era
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
trySubmitVote Vote
vote Voter
voter GovActionId
gaId =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> a
fst forall era. EraTx era => Tx era -> TxId
txIdTx) forall a b. (a -> b) -> a -> b
$
    forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx 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.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
          forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
            ( forall k a. k -> a -> Map k a
Map.singleton
                Voter
voter
                ( forall k a. k -> a -> Map k a
Map.singleton
                    GovActionId
gaId
                    ( VotingProcedure
                        { vProcVote :: Vote
vProcVote = Vote
vote
                        , vProcAnchor :: StrictMaybe Anchor
vProcAnchor = forall a. StrictMaybe a
SNothing
                        }
                    )
                )
            )

submitProposal_ ::
  (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
  ProposalProcedure era ->
  ImpTestM era ()
submitProposal_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal

submitProposal ::
  (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
  ProposalProcedure era ->
  ImpTestM era GovActionId
submitProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal ProposalProcedure era
proposal = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal ProposalProcedure era
proposal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr

submitProposals ::
  (ShelleyEraImp era, ConwayEraGov era, ConwayEraTxBody era, HasCallStack) =>
  NE.NonEmpty (ProposalProcedure era) ->
  ImpTestM era (NE.NonEmpty GovActionId)
submitProposals :: forall era.
(ShelleyEraImp era, ConwayEraGov era, ConwayEraTxBody era,
 HasCallStack) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM era (NonEmpty GovActionId)
submitProposals NonEmpty (ProposalProcedure era)
proposals = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  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
  Tx era
tx <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr
  let txId :: TxId
txId = forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx
      proposalsWithGovActionId :: NonEmpty (GovActionId, ProposalProcedure era)
proposalsWithGovActionId =
        forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Word16
idx ProposalProcedure era
p -> (TxId -> GovActionIx -> GovActionId
GovActionId TxId
txId (Word16 -> GovActionIx
GovActionIx Word16
idx), ProposalProcedure era
p)) (Word16
0 forall a. a -> [a] -> NonEmpty a
NE.:| [Word16
1 ..]) NonEmpty (ProposalProcedure era)
proposals
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (GovActionId, ProposalProcedure era)
proposalsWithGovActionId forall a b. (a -> b) -> a -> b
$ \(GovActionId
govActionId, ProposalProcedure era
proposal) -> do
    GovActionState era
govActionState <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId
    GovActionState era
govActionState
      forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` GovActionState
        { gasId :: GovActionId
gasId = GovActionId
govActionId
        , gasCommitteeVotes :: Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes = forall a. Monoid a => a
mempty
        , gasDRepVotes :: Map (Credential 'DRepRole) Vote
gasDRepVotes = forall a. Monoid a => a
mempty
        , gasStakePoolVotes :: Map (KeyHash 'StakePool) Vote
gasStakePoolVotes = forall a. Monoid a => a
mempty
        , gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure = ProposalProcedure era
proposal
        , gasProposedIn :: EpochNo
gasProposedIn = EpochNo
curEpochNo
        , gasExpiresAfter :: EpochNo
gasExpiresAfter = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL)
        }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId
govActionId

-- | Submits a transaction that proposes the given proposal
trySubmitProposal ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  ProposalProcedure era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal ProposalProcedure era
proposal = do
  Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals (forall (f :: * -> *) a. Applicative f => a -> f a
pure ProposalProcedure era
proposal)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res of
    Right Tx era
tx ->
      forall a b. b -> Either a b
Right
        GovActionId
          { gaidTxId :: TxId
gaidTxId = forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx
          , gaidGovActionIx :: GovActionIx
gaidGovActionIx = Word16 -> GovActionIx
GovActionIx Word16
0
          }
    Left (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
err, Tx era
_) -> forall a b. a -> Either a b
Left NonEmpty (PredicateFailure (EraRule "LEDGER" era))
err

trySubmitProposals ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  NE.NonEmpty (ProposalProcedure era) ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitProposals :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals = do
  forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx 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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall l. IsList l => [Item l] -> l
GHC.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ProposalProcedure era)
proposals)

submitFailingProposal ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  ProposalProcedure era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingProposal ProposalProcedure era
proposal NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure =
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal ProposalProcedure era
proposal forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

-- | Submits a transaction that proposes the given governance action. For proposing
-- multiple actions in the same transaciton use `trySubmitGovActions` instead.
trySubmitGovAction ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  GovAction era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction GovAction era
ga = do
  let mkGovActionId :: Tx era -> GovActionId
mkGovActionId Tx era
tx = TxId -> GovActionIx -> GovActionId
GovActionId (forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx) (Word16 -> GovActionIx
GovActionIx Word16
0)
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. (a, b) -> a
fst forall {era}. EraTx era => Tx era -> GovActionId
mkGovActionId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions (forall (f :: * -> *) a. Applicative f => a -> f a
pure GovAction era
ga)

submitAndExpireProposalToMakeReward ::
  ConwayEraImp era =>
  Credential 'Staking ->
  ImpTestM era ()
submitAndExpireProposalToMakeReward :: forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
stakingC = do
  RewardAccount
rewardAccount <- forall era. Credential 'Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential 'Staking
stakingC
  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
    EpochInterval Word32
lifetime = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL
    deposit :: Coin
deposit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
  GovActionId
gai <-
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal forall a b. (a -> b) -> a -> b
$
      ProposalProcedure
        { pProcDeposit :: Coin
pProcDeposit = Coin
deposit
        , pProcReturnAddr :: RewardAccount
pProcReturnAddr = RewardAccount
rewardAccount
        , pProcGovAction :: GovAction era
pProcGovAction = forall era. GovAction era
InfoAction
        , pProcAnchor :: Anchor
pProcAnchor = forall a. Default a => a
def
        }
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ Natural
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
lifetime
  forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
expectMissingGovActionId GovActionId
gai

-- | Submits a transaction that proposes the given governance action
trySubmitGovActions ::
  (ShelleyEraImp era, ConwayEraTxBody era) =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era))
trySubmitGovActions :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions NonEmpty (GovAction era)
gas = do
  NonEmpty (ProposalProcedure era)
proposals <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal NonEmpty (GovAction era)
gas
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals

mkProposalWithRewardAccount ::
  (ShelleyEraImp era, ConwayEraTxBody era) =>
  GovAction era ->
  RewardAccount ->
  ImpTestM era (ProposalProcedure era)
mkProposalWithRewardAccount :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> RewardAccount -> ImpTestM era (ProposalProcedure era)
mkProposalWithRewardAccount GovAction era
ga RewardAccount
rewardAccount = do
  Coin
deposit <- 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. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
  Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ProposalProcedure
      { pProcDeposit :: Coin
pProcDeposit = Coin
deposit
      , pProcReturnAddr :: RewardAccount
pProcReturnAddr = RewardAccount
rewardAccount
      , pProcGovAction :: GovAction era
pProcGovAction = GovAction era
ga
      , pProcAnchor :: Anchor
pProcAnchor = Anchor
anchor
      }

mkProposal ::
  (ShelleyEraImp era, ConwayEraTxBody era) =>
  GovAction era ->
  ImpTestM era (ProposalProcedure era)
mkProposal :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
ga = do
  RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> RewardAccount -> ImpTestM era (ProposalProcedure era)
mkProposalWithRewardAccount GovAction era
ga RewardAccount
rewardAccount

submitGovAction ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  ImpTestM era GovActionId
submitGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
ga = do
  GovActionId
gaId NE.:| [GovActionId]
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
submitGovActions (forall (f :: * -> *) a. Applicative f => a -> f a
pure GovAction era
ga)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId
gaId

submitGovAction_ ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  ImpTestM era ()
submitGovAction_ :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction

submitGovActions ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM era (NE.NonEmpty GovActionId)
submitGovActions :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
submitGovActions NonEmpty (GovAction era)
gas = do
  Tx era
tx <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitGovActions NonEmpty (GovAction era)
gas forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr
  let txId :: TxId
txId = forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Word16
idx GovAction era
_ -> TxId -> GovActionIx -> GovActionId
GovActionId TxId
txId (Word16 -> GovActionIx
GovActionIx Word16
idx)) (Word16
0 forall a. a -> [a] -> NonEmpty a
NE.:| [Word16
1 ..]) NonEmpty (GovAction era)
gas

mkTreasuryWithdrawalsGovAction ::
  ConwayEraGov era =>
  [(RewardAccount, Coin)] ->
  ImpTestM era (GovAction era)
mkTreasuryWithdrawalsGovAction :: forall era.
ConwayEraGov era =>
[(RewardAccount, Coin)] -> ImpTestM era (GovAction era)
mkTreasuryWithdrawalsGovAction [(RewardAccount, Coin)]
wdrls =
  forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount, Coin)]
wdrls) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy

submitTreasuryWithdrawals ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , ConwayEraGov era
  ) =>
  [(RewardAccount, Coin)] ->
  ImpTestM era GovActionId
submitTreasuryWithdrawals :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount, Coin)]
wdrls =
  forall era.
ConwayEraGov era =>
[(RewardAccount, Coin)] -> ImpTestM era (GovAction era)
mkTreasuryWithdrawalsGovAction [(RewardAccount, Coin)]
wdrls forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction

enactTreasuryWithdrawals ::
  ConwayEraImp era =>
  [(RewardAccount, Coin)] ->
  Credential 'DRepRole ->
  NonEmpty (Credential 'HotCommitteeRole) ->
  ImpTestM era GovActionId
enactTreasuryWithdrawals :: forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)]
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
cms = do
  GovActionId
gaId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep) GovActionId
gaId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
cms GovActionId
gaId
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId
gaId

submitParameterChange ::
  ConwayEraImp era =>
  StrictMaybe GovActionId ->
  PParamsUpdate era ->
  ImpTestM era GovActionId
submitParameterChange :: forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange StrictMaybe GovActionId
parent PParamsUpdate era
ppu =
  forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
mkParameterChangeGovAction StrictMaybe GovActionId
parent PParamsUpdate era
ppu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction

mkParameterChangeGovAction ::
  ConwayEraImp era =>
  StrictMaybe GovActionId ->
  PParamsUpdate era ->
  ImpTestM era (GovAction era)
mkParameterChangeGovAction :: forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
mkParameterChangeGovAction StrictMaybe GovActionId
parent PParamsUpdate era
ppu =
  forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange (forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe GovActionId
parent) PParamsUpdate era
ppu forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy

mkMinFeeUpdateGovAction ::
  ConwayEraImp era =>
  StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction :: forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
p = do
  Integer
minFeeValue <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
30, Integer
1000)
  forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
mkParameterChangeGovAction StrictMaybe GovActionId
p (forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
minFeeValue))

getGovPolicy :: ConwayEraGov era => ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy =
  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)
nesEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (Constitution era) (StrictMaybe ScriptHash)
constitutionScriptL

submitFailingGovAction ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  , HasCallStack
  ) =>
  GovAction era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingGovAction :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingGovAction GovAction era
ga NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure = forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction GovAction era
ga forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b (m :: * -> *).
(HasCallStack, ToExpr a, ToExpr b, Eq a, MonadIO m) =>
Either a b -> a -> m ()
`shouldBeLeftExpr` NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure)

getEnactState :: ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState :: forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState = forall era. ConwayEraGov era => GovState era -> EnactState era
mkEnactState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) (GovState era)
epochStateGovStateL)

getProposals :: ConwayEraGov era => ImpTestM era (Proposals era)
getProposals :: forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL

logProposalsForest :: (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest :: forall era. (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest = do
  Proposals era
proposals <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug Proposals era
proposals Bool
True

getCommitteeMembers ::
  ConwayEraImp era =>
  ImpTestM era (Set.Set (Credential 'ColdCommitteeRole))
getCommitteeMembers :: forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers = do
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee

getLastEnactedCommittee ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getConstitution ::
  ConwayEraImp era =>
  ImpTestM era (Constitution era)
getConstitution :: forall era. ConwayEraImp era => ImpTestM era (Constitution era)
getConstitution = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL

getLastEnactedConstitution ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose era))
getLastEnactedConstitution :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose era))
getLastEnactedConstitution = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getLastEnactedParameterChange ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getLastEnactedHardForkInitiation ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL

getConstitutionProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'ConstitutionPurpose era)
        (PEdges (GovPurposeId 'ConstitutionPurpose era))
    )
getConstitutionProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'ConstitutionPurpose era)
     (PEdges (GovPurposeId 'ConstitutionPurpose era)))
getConstitutionProposals = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL

getParameterChangeProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'PParamUpdatePurpose era)
        (PEdges (GovPurposeId 'PParamUpdatePurpose era))
    )
getParameterChangeProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'PParamUpdatePurpose era)
     (PEdges (GovPurposeId 'PParamUpdatePurpose era)))
getParameterChangeProposals = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL

logProposalsForestDiff ::
  ( Era era
  , ToExpr (PParamsHKD StrictMaybe era)
  , HasCallStack
  ) =>
  Proposals era ->
  Proposals era ->
  ImpTestM era ()
logProposalsForestDiff :: forall era.
(Era era, ToExpr (PParamsHKD StrictMaybe era), HasCallStack) =>
Proposals era -> Proposals era -> ImpTestM era ()
logProposalsForestDiff Proposals era
pf1 Proposals era
pf2 = forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep [Doc AnsiStyle
"Proposals Forest Diff:", forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Proposals era
pf1 Proposals era
pf2]

-- | Looks up the governance action state corresponding to the governance action id
lookupGovActionState ::
  ConwayEraGov era =>
  GovActionId ->
  ImpTestM era (Maybe (GovActionState era))
lookupGovActionState :: forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
aId = forall era.
GovActionId -> Proposals era -> Maybe (GovActionState era)
proposalsLookupId GovActionId
aId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals

-- | Looks up the governance action state corresponding to the governance action id
getGovActionState ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId ->
  ImpTestM era (GovActionState era)
getGovActionState :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId =
  forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Expecting an action state" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
govActionId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (GovActionState era)
Nothing ->
        forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find action state for govActionId: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show GovActionId
govActionId
      Just GovActionState era
govActionState -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionState era
govActionState

expectPresentGovActionId ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId ->
  ImpTestM era ()
expectPresentGovActionId :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
expectPresentGovActionId GovActionId
govActionId = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId

expectMissingGovActionId ::
  (HasCallStack, ConwayEraGov era) =>
  GovActionId ->
  ImpTestM era ()
expectMissingGovActionId :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
expectMissingGovActionId GovActionId
govActionId =
  forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Expecting for gov action state to be missing" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
govActionId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just GovActionState era
_ ->
        forall (m :: * -> *). (HasCallStack, MonadIO m) => [Char] -> m ()
expectationFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Found gov action state for govActionId: " forall a. Semigroup a => a -> a -> a
<> forall a. ToExpr a => a -> [Char]
ansiExprString GovActionId
govActionId
      Maybe (GovActionState era)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Builds a RatifyEnv from the current state
getRatifyEnv :: ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv :: forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv = do
  EpochNo
eNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  IncrementalStake
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) (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) IncrementalStake
utxosStakeDistrL
  PoolDistr
poolDistr <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) PoolDistr
nesPdL
  Map DRep (CompactForm Coin)
drepDistr <- 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.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SimpleGetter (DRepPulsingState era) (Map DRep (CompactForm Coin))
psDRepDistrG
  Map (Credential 'DRepRole) DRepState
drepState <- 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
  CommitteeState era
committeeState <- 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL
  UMap
umap <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) UMap
unifiedL
  Map (KeyHash 'StakePool) PoolParams
poolPs <- 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 (KeyHash 'StakePool) PoolParams)
epochStatePoolParamsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    RatifyEnv
      { reStakePoolDistr :: PoolDistr
reStakePoolDistr = PoolDistr
poolDistr
      , reStakeDistr :: Map (Credential 'Staking) (CompactForm Coin)
reStakeDistr = IncrementalStake -> Map (Credential 'Staking) (CompactForm Coin)
credMap IncrementalStake
stakeDistr
      , reDRepState :: Map (Credential 'DRepRole) DRepState
reDRepState = Map (Credential 'DRepRole) DRepState
drepState
      , reDRepDistr :: Map DRep (CompactForm Coin)
reDRepDistr = Map DRep (CompactForm Coin)
drepDistr
      , reCurrentEpoch :: EpochNo
reCurrentEpoch = EpochNo
eNo forall a. Num a => a -> a -> a
- EpochNo
1
      , reCommitteeState :: CommitteeState era
reCommitteeState = CommitteeState era
committeeState
      , reDelegatees :: Map (Credential 'Staking) DRep
reDelegatees = UMap -> Map (Credential 'Staking) DRep
dRepMap UMap
umap
      , rePoolParams :: Map (KeyHash 'StakePool) PoolParams
rePoolParams = Map (KeyHash 'StakePool) PoolParams
poolPs
      }

ccShouldNotBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole ->
  ImpTestM era ()
ccShouldNotBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeExpired Credential 'ColdCommitteeRole
coldC = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  EpochNo
ccExpiryEpochNo <- forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole
coldC
  EpochNo
curEpochNo forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` (forall a. Ord a => a -> a -> Bool
<= EpochNo
ccExpiryEpochNo)

ccShouldBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole ->
  ImpTestM era ()
ccShouldBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldBeExpired Credential 'ColdCommitteeRole
coldC = do
  EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  EpochNo
ccExpiryEpochNo <- forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole
coldC
  EpochNo
curEpochNo forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` (forall a. Ord a => a -> a -> Bool
> EpochNo
ccExpiryEpochNo)

getCCExpiry ::
  (HasCallStack, ConwayEraGov era) =>
  Credential 'ColdCommitteeRole ->
  ImpTestM era EpochNo
getCCExpiry :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era EpochNo
getCCExpiry Credential 'ColdCommitteeRole
coldC = do
  StrictMaybe (Committee era)
committee <- 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) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  case StrictMaybe (Committee era)
committee of
    StrictMaybe (Committee era)
SNothing -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure [Char]
"There is no committee"
    SJust Committee {Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers :: Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers :: forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers} ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldC Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers of
        Maybe EpochNo
Nothing -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Committee not found for cold credential: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole
coldC
        Just EpochNo
epochNo -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochNo
epochNo

-- | Test the resignation status for a CC cold key to be resigned
ccShouldBeResigned ::
  HasCallStack => Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned :: forall era.
HasCallStack =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole
coldK = do
  Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeeCreds <-
    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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (CommitteeState era)
  (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL
  CommitteeAuthorization -> Maybe (Credential 'HotCommitteeRole)
authHk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldK Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeeCreds forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just forall a. Maybe a
Nothing

-- | Test the resignation status for a CC cold key to not be resigned
ccShouldNotBeResigned ::
  HasCallStack => Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned :: forall era.
HasCallStack =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole
coldK = do
  Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeeCreds <-
    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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (CommitteeState era)
  (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL
  (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldK Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeeCreds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CommitteeAuthorization -> Maybe (Credential 'HotCommitteeRole)
authHk) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall a. Maybe a -> Bool
isJust

authHk :: CommitteeAuthorization -> Maybe (Credential 'HotCommitteeRole)
authHk :: CommitteeAuthorization -> Maybe (Credential 'HotCommitteeRole)
authHk (CommitteeHotCredential Credential 'HotCommitteeRole
hk) = forall a. a -> Maybe a
Just Credential 'HotCommitteeRole
hk
authHk CommitteeAuthorization
_ = forall a. Maybe a
Nothing

-- | Calculates the ratio of DReps that have voted for the governance action
calculateDRepAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era) =>
  GovActionId ->
  ImpTestM era Rational
calculateDRepAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era Rational
calculateDRepAcceptedRatio GovActionId
gaId = do
  RatifyEnv era
ratEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState era
gas <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
RatifyEnv era
-> Map (Credential 'DRepRole) Vote -> GovAction era -> Rational
dRepAcceptedRatio @era
      RatifyEnv era
ratEnv
      (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (Map (Credential 'DRepRole) Vote)
gasDRepVotesL)
      (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)

-- | Calculates the ratio of Committee members that have voted for the governance
-- action
calculateCommitteeAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era) =>
  GovActionId ->
  ImpTestM era Rational
calculateCommitteeAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era Rational
calculateCommitteeAcceptedRatio GovActionId
gaId = do
  EpochNo
eNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  RatifyEnv {CommitteeState era
reCommitteeState :: CommitteeState era
reCommitteeState :: forall era. RatifyEnv era -> CommitteeState era
reCommitteeState} <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState {Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes :: Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes :: forall era.
GovActionState era -> Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes} <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  StrictMaybe (Committee era)
committee <- 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) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  let
    members :: Map (Credential 'ColdCommitteeRole) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers @era) StrictMaybe (Committee era)
committee
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> Map (Credential 'HotCommitteeRole) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio
      Map (Credential 'ColdCommitteeRole) EpochNo
members
      Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes
      CommitteeState era
reCommitteeState
      EpochNo
eNo

calculatePoolAcceptedRatio ::
  ConwayEraGov era => GovActionId -> ImpTestM era Rational
calculatePoolAcceptedRatio :: forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era Rational
calculatePoolAcceptedRatio GovActionId
gaId = do
  RatifyEnv era
ratEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  GovActionState era
gas <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
ratEnv GovActionState era
gas ProtVer
pv

-- | Logs the ratios of accepted votes per category
logAcceptedRatio ::
  (HasCallStack, ConwayEraGov era) => GovActionId -> ImpTestM era ()
logAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
logAcceptedRatio GovActionId
aId = do
  Rational
dRepRatio <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era Rational
calculateDRepAcceptedRatio GovActionId
aId
  Rational
committeeRatio <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era Rational
calculateCommitteeAcceptedRatio GovActionId
aId
  Rational
spoRatio <- forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era Rational
calculatePoolAcceptedRatio GovActionId
aId
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
    Maybe (Doc AnsiStyle) -> [([Char], Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc
      (forall a. a -> Maybe a
Just Doc AnsiStyle
"ACCEPTED RATIOS")
      [ ([Char]
"DRep accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
dRepRatio)
      , ([Char]
"Committee accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
committeeRatio)
      , ([Char]
"SPO accepted ratio:", forall a ann. Show a => a -> Doc ann
viaShow Rational
spoRatio)
      ]

getRatifyEnvAndState :: ConwayEraGov era => ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState :: forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState = do
  RatifyEnv era
ratifyEnv <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  EnactState era
enactState <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
  let ratifyState :: RatifyState era
ratifyState =
        RatifyState
          { rsEnactState :: EnactState era
rsEnactState = EnactState era
enactState
          , rsEnacted :: Seq (GovActionState era)
rsEnacted = forall a. Monoid a => a
mempty
          , rsExpired :: Set GovActionId
rsExpired = forall a. Monoid a => a
mempty
          , rsDelayed :: Bool
rsDelayed = Bool
False
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState)

-- | Checks whether the governance action has enough DRep votes to be accepted in the next
-- epoch. (Note that no other checks except DRep votes are used)
isDRepAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId ->
  ImpTestM era Bool
isDRepAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId -> ImpTestM era Bool
isDRepAccepted GovActionId
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

isSpoAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId ->
  ImpTestM era Bool
isSpoAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId -> ImpTestM era Bool
isSpoAccepted GovActionId
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

isCommitteeAccepted ::
  (HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
  GovActionId ->
  ImpTestM era Bool
isCommitteeAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era) =>
GovActionId -> ImpTestM era Bool
isCommitteeAccepted GovActionId
gaId = do
  (RatifyEnv era
ratifyEnv, RatifyState era
ratifyState) <- forall era.
ConwayEraGov era =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  GovActionState era
action <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
ratifyEnv RatifyState era
ratifyState GovActionState era
action

-- | Logs the results of each check required to make the governance action pass
logRatificationChecks ::
  (ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
  GovActionId ->
  ImpTestM era ()
logRatificationChecks :: forall era.
(ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
GovActionId -> ImpTestM era ()
logRatificationChecks GovActionId
gaId = do
  gas :: GovActionState era
gas@GovActionState {Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes :: Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes :: forall era.
GovActionState era -> Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes, Map (Credential 'DRepRole) Vote
gasDRepVotes :: Map (Credential 'DRepRole) Vote
gasDRepVotes :: forall era. GovActionState era -> Map (Credential 'DRepRole) Vote
gasDRepVotes} <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
gaId
  let govAction :: GovAction era
govAction = forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
  ens :: EnactState era
ens@EnactState {Map (Credential 'Staking) Coin
PParams era
StrictMaybe (Committee era)
Coin
GovRelation StrictMaybe era
Constitution era
ensCommittee :: forall era. EnactState era -> StrictMaybe (Committee era)
ensConstitution :: forall era. EnactState era -> Constitution era
ensCurPParams :: forall era. EnactState era -> PParams era
ensPrevPParams :: forall era. EnactState era -> PParams era
ensTreasury :: forall era. EnactState era -> Coin
ensWithdrawals :: forall era. EnactState era -> Map (Credential 'Staking) Coin
ensPrevGovActionIds :: forall era. EnactState era -> GovRelation StrictMaybe era
ensPrevGovActionIds :: GovRelation StrictMaybe era
ensWithdrawals :: Map (Credential 'Staking) Coin
ensTreasury :: Coin
ensPrevPParams :: PParams era
ensCurPParams :: PParams era
ensConstitution :: Constitution era
ensCommittee :: StrictMaybe (Committee era)
..} <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
  StrictMaybe (Committee era)
committee <- 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) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  ratEnv :: RatifyEnv era
ratEnv@RatifyEnv {EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch} <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv
  let ratSt :: RatifyState era
ratSt = forall era.
EnactState era
-> Seq (GovActionState era)
-> Set GovActionId
-> Bool
-> RatifyState era
RatifyState EnactState era
ens forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Bool
False
  Coin
curTreasury <- 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
  EpochNo
currentEpoch <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  let
    members :: Map (Credential 'ColdCommitteeRole) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
    committeeState :: CommitteeState era
committeeState = forall era. RatifyEnv era -> CommitteeState era
reCommitteeState RatifyEnv era
ratEnv
  PParams era
curPParams <- 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) (GovState era)
epochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
    Maybe (Doc AnsiStyle) -> [([Char], Doc AnsiStyle)] -> Doc AnsiStyle
tableDoc
      (forall a. a -> Maybe a
Just Doc AnsiStyle
"RATIFICATION CHECKS")
      [ ([Char]
"prevActionAsExpected:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
GovActionState era -> GovRelation StrictMaybe era -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe era
ensPrevGovActionIds)
      , ([Char]
"validCommitteeTerm:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
GovAction era -> PParams era -> EpochNo -> Bool
validCommitteeTerm GovAction era
govAction PParams era
curPParams EpochNo
currentEpoch)
      , ([Char]
"notDelayed:", Doc AnsiStyle
"??")
      , ([Char]
"withdrawalCanWithdraw:", forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era. GovAction era -> Coin -> Bool
withdrawalCanWithdraw GovAction era
govAction Coin
curTreasury)
      ,
        ( [Char]
"committeeAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> Map (Credential 'HotCommitteeRole) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio Map (Credential 'ColdCommitteeRole) EpochNo
members Map (Credential 'HotCommitteeRole) Vote
gasCommitteeVotes CommitteeState era
committeeState EpochNo
currentEpoch
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
EpochNo
-> RatifyState era
-> CommitteeState era
-> GovAction era
-> StrictMaybe UnitInterval
votingCommitteeThreshold EpochNo
reCurrentEpoch RatifyState era
ratSt CommitteeState era
committeeState (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ,
        ( [Char]
"spoAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
ratEnv GovActionState era
gas ProtVer
pv
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingStakePoolThreshold RatifyState era
ratSt (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ,
        ( [Char]
"dRepAccepted:"
        , forall ann. [Doc ann] -> Doc ann
hsep
            [ forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
ratEnv RatifyState era
ratSt GovActionState era
gas
            , Doc AnsiStyle
"["
            , Doc AnsiStyle
"To Pass:"
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
RatifyEnv era
-> Map (Credential 'DRepRole) Vote -> GovAction era -> Rational
dRepAcceptedRatio RatifyEnv era
ratEnv Map (Credential 'DRepRole) Vote
gasDRepVotes (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
">="
            , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingDRepThreshold RatifyState era
ratSt (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas)
            , Doc AnsiStyle
"]"
            ]
        )
      ]

-- | Submits a transaction that registers a hot key for the given cold key.
-- Returns the hot key hash.
registerCommitteeHotKey ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Credential 'ColdCommitteeRole ->
  ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
coldKey = do
  Credential 'HotCommitteeRole
hotKey NE.:| [] <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole)
-> NonEmpty (Credential 'ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerCommitteeHotKeys (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'ColdCommitteeRole
coldKey
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'HotCommitteeRole
hotKey

registerCommitteeHotKeys ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  -- | Hot Credential generator
  ImpTestM era (Credential 'HotCommitteeRole) ->
  NonEmpty (Credential 'ColdCommitteeRole) ->
  ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerCommitteeHotKeys :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential 'HotCommitteeRole)
-> NonEmpty (Credential 'ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerCommitteeHotKeys ImpTestM era (Credential 'HotCommitteeRole)
genHotCred NonEmpty (Credential 'ColdCommitteeRole)
coldKeys = do
  NonEmpty
  (Credential 'ColdCommitteeRole, Credential 'HotCommitteeRole)
keys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Credential 'ColdCommitteeRole)
coldKeys (\Credential 'ColdCommitteeRole
coldKey -> (,) Credential 'ColdCommitteeRole
coldKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpTestM era (Credential 'HotCommitteeRole)
genHotCred)
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Registering Committee Hot keys" 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 a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty
  (Credential 'ColdCommitteeRole, Credential 'HotCommitteeRole)
keys))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd NonEmpty
  (Credential 'ColdCommitteeRole, Credential 'HotCommitteeRole)
keys

-- | Submits a transaction that resigns the cold key. Prior to resignation if there was
-- hot credential authorization for this committee member it will be returned.
resignCommitteeColdKey ::
  (ShelleyEraImp era, ConwayEraTxCert era) =>
  Credential 'ColdCommitteeRole ->
  StrictMaybe Anchor ->
  ImpTestM era (Maybe (Credential 'HotCommitteeRole))
resignCommitteeColdKey :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> StrictMaybe Anchor
-> ImpTestM era (Maybe (Credential 'HotCommitteeRole))
resignCommitteeColdKey Credential 'ColdCommitteeRole
coldKey StrictMaybe Anchor
anchor = do
  Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeAuthorizations <-
    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) (VState era)
certVStateL
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (CommitteeState era)
  (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL
  forall era.
(HasCallStack, ShelleyEraImp era) =>
[Char] -> Tx era -> ImpTestM era ()
submitTxAnn_ [Char]
"Resigning Committee Cold key" 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.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert Credential 'ColdCommitteeRole
coldKey StrictMaybe Anchor
anchor)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    CommitteeHotCredential Credential 'HotCommitteeRole
hotCred <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole
coldKey Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
committeAuthorizations
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential 'HotCommitteeRole
hotCred

electCommittee ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  StrictMaybe (GovPurposeId 'CommitteePurpose era) ->
  Credential 'DRepRole ->
  Set.Set (Credential 'ColdCommitteeRole) ->
  Map.Map (Credential 'ColdCommitteeRole) EpochNo ->
  ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Credential 'DRepRole
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
prevGovId Credential 'DRepRole
drep Set (Credential 'ColdCommitteeRole)
toRemove Map (Credential 'ColdCommitteeRole) EpochNo
toAdd = forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Electing committee" forall a b. (a -> b) -> a -> b
$ do
  let
    committeeAction :: GovAction era
committeeAction =
      forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
        StrictMaybe (GovPurposeId 'CommitteePurpose era)
prevGovId
        Set (Credential 'ColdCommitteeRole)
toRemove
        Map (Credential 'ColdCommitteeRole) EpochNo
toAdd
        (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
  GovActionId
gaidCommitteeProp <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
committeeAction
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drep) GovActionId
gaidCommitteeProp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
gaidCommitteeProp)

electBasicCommittee ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  ImpTestM
    era
    ( Credential 'DRepRole
    , Credential 'HotCommitteeRole
    , GovPurposeId 'CommitteePurpose era
    )
electBasicCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential 'DRepRole, Credential 'HotCommitteeRole,
   GovPurposeId 'CommitteePurpose era)
electBasicCommittee = do
  forall t. HasCallStack => [Char] -> ImpM t ()
logString [Char]
"Setting up a DRep"
  (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
  (KeyHash 'StakePool
spoC, PaymentCredential
_, Credential 'Staking
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000

  forall t. HasCallStack => [Char] -> ImpM t ()
logString [Char]
"Registering committee member"
  Credential 'ColdCommitteeRole
coldCommitteeC <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  EpochNo
startEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  let
    committeeAction :: GovAction era
committeeAction =
      forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
        forall a. StrictMaybe a
SNothing
        forall a. Monoid a => a
mempty
        (forall k a. k -> a -> Map k a
Map.singleton Credential 'ColdCommitteeRole
coldCommitteeC (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)))
        (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
  (GovActionId
gaidCommitteeProp NE.:| [GovActionId]
_) <-
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
submitGovActions
      [ GovAction era
committeeAction
      , forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee forall a. StrictMaybe a
SNothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10)
      ]
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drep) GovActionId
gaidCommitteeProp
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
gaidCommitteeProp
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  Set (Credential 'ColdCommitteeRole)
committeeMembers <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
  forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"The committee should be enacted" forall a b. (a -> b) -> a -> b
$
    Set (Credential 'ColdCommitteeRole)
committeeMembers forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall a. Ord a => a -> Set a -> Bool
Set.member Credential 'ColdCommitteeRole
coldCommitteeC
  Credential 'HotCommitteeRole
hotCommitteeC <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
coldCommitteeC
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential 'DRepRole
drep, Credential 'HotCommitteeRole
hotCommitteeC, forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
gaidCommitteeProp)

logCurPParams ::
  ( EraGov era
  , ToExpr (PParamsHKD Identity era)
  , HasCallStack
  ) =>
  ImpTestM era ()
logCurPParams :: forall era.
(EraGov era, ToExpr (PParamsHKD Identity era), HasCallStack) =>
ImpTestM era ()
logCurPParams = 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
  forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc forall a b. (a -> b) -> a -> b
$
    forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc AnsiStyle
""
      , Doc AnsiStyle
"----- Current PParams -----"
      , forall a. ToExpr a => a -> Doc AnsiStyle
ansiExpr PParams era
pp
      , Doc AnsiStyle
"---------------------------"
      , Doc AnsiStyle
""
      ]

proposalsShowDebug :: Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug :: forall era. Era era => Proposals era -> Bool -> Doc AnsiStyle
proposalsShowDebug Proposals era
ps Bool
showRoots =
  forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
    [ Doc AnsiStyle
""
    , Doc AnsiStyle
"----- Proposals -----"
    , Doc AnsiStyle
"Size"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era. Proposals era -> Int
proposalsSize Proposals era
ps
    , Doc AnsiStyle
"OMap"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ forall era. Proposals era -> StrictSeq GovActionId
proposalsIds Proposals era
ps
    , Doc AnsiStyle
""
    , Doc AnsiStyle
"Roots"
    , Doc AnsiStyle
"> PParamUpdate"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL
    , Doc AnsiStyle
"> HardFork"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL
    , Doc AnsiStyle
"> Committee"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL
    , Doc AnsiStyle
"> Constitution"
    , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL
    ]
      forall a. Semigroup a => a -> a -> a
<> ( if Bool
showRoots
            then
              [ Doc AnsiStyle
"Hierarchy"
              , Doc AnsiStyle
">> PParamUpdate"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> HardFork"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> Committee"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              , Doc AnsiStyle
">> Constitution"
              , forall a ann. Show a => a -> Doc ann
viaShow forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              ]
            else forall a. Monoid a => a
mempty
         )
      forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle
"----- Proposals End -----"]

getProposalsForest ::
  ConwayEraGov era =>
  ImpTestM era (Forest (StrictMaybe GovActionId))
getProposalsForest :: forall era.
ConwayEraGov era =>
ImpTestM era (Forest (StrictMaybe GovActionId))
getProposalsForest = do
  Proposals era
ps <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe GovActionId
mkRoot forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Forest (StrictMaybe GovActionId)
mkForest forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'PParamUpdatePurpose era))
grPParamUpdateL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe GovActionId
mkRoot forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Forest (StrictMaybe GovActionId)
mkForest forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'HardForkPurpose era))
grHardForkL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe GovActionId
mkRoot forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Forest (StrictMaybe GovActionId)
mkForest forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL Proposals era
ps
    , forall a. a -> [Tree a] -> Tree a
Node (forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe GovActionId
mkRoot forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL Proposals era
ps) forall a b. (a -> b) -> a -> b
$ forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Forest (StrictMaybe GovActionId)
mkForest forall (f :: * -> *) era.
Lens'
  (GovRelation f era) (f (GovPurposeId 'ConstitutionPurpose era))
grConstitutionL Proposals era
ps
    ]
  where
    mkRoot ::
      Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era)) ->
      Proposals era ->
      StrictMaybe GovActionId
    mkRoot :: forall era (p :: GovActionPurpose).
Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
-> Proposals era -> StrictMaybe GovActionId
mkRoot Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
rootL Proposals era
ps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId
unGovPurposeId forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era))
rootL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL
    mkForest ::
      (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
      Proposals era ->
      Forest (StrictMaybe GovActionId)
    mkForest :: forall era (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Forest (StrictMaybe GovActionId)
mkForest forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL Proposals era
ps =
      let h :: Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
h = Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
          s :: [GovActionId]
s = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall era. Proposals era -> StrictSeq GovActionId
proposalsIds Proposals era
ps
          getOrderedChildren :: Set (GovPurposeId p era) -> [GovActionId]
getOrderedChildren Set (GovPurposeId p era)
cs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.member` forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId
unGovPurposeId Set (GovPurposeId p era)
cs) [GovActionId]
s
          go :: GovActionId -> (StrictMaybe GovActionId, [GovActionId])
go GovActionId
c = (forall a. a -> StrictMaybe a
SJust GovActionId
c, Set (GovPurposeId p era) -> [GovActionId]
getOrderedChildren forall a b. (a -> b) -> a -> b
$ Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
h forall k a. Ord k => Map k a -> k -> a
Map.! forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
c forall s a. s -> Getting a s a -> a
^. forall a. Lens' (PEdges a) (Set a)
peChildrenL)
       in forall b a. (b -> (a, [b])) -> [b] -> [Tree a]
unfoldForest GovActionId -> (StrictMaybe GovActionId, [GovActionId])
go (Set (GovPurposeId p era) -> [GovActionId]
getOrderedChildren forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
forestL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL)

submitGovActionTree ::
  (StrictMaybe GovActionId -> ImpTestM era GovActionId) ->
  StrictMaybe GovActionId ->
  Tree () ->
  ImpTestM era (Tree GovActionId)
submitGovActionTree :: forall era.
(StrictMaybe GovActionId -> ImpTestM era GovActionId)
-> StrictMaybe GovActionId
-> Tree ()
-> ImpTestM era (Tree GovActionId)
submitGovActionTree StrictMaybe GovActionId -> ImpTestM era GovActionId
submitAction StrictMaybe GovActionId
p Tree ()
tree =
  forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM Tree (StrictMaybe GovActionId)
-> ImpM
     (LedgerSpec era) (GovActionId, Forest (StrictMaybe GovActionId))
go forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const StrictMaybe GovActionId
p) Tree ()
tree
  where
    go :: Tree (StrictMaybe GovActionId)
-> ImpM
     (LedgerSpec era) (GovActionId, Forest (StrictMaybe GovActionId))
go (Node StrictMaybe GovActionId
parent Forest (StrictMaybe GovActionId)
children) = do
      GovActionId
n <- StrictMaybe GovActionId -> ImpTestM era GovActionId
submitAction StrictMaybe GovActionId
parent
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovActionId
n, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node StrictMaybe GovActionId
_child Forest (StrictMaybe GovActionId)
subtree) -> forall a. a -> [Tree a] -> Tree a
Node (forall a. a -> StrictMaybe a
SJust GovActionId
n) Forest (StrictMaybe GovActionId)
subtree) Forest (StrictMaybe GovActionId)
children)

submitGovActionForest ::
  (StrictMaybe GovActionId -> ImpTestM era GovActionId) ->
  StrictMaybe GovActionId ->
  Forest () ->
  ImpTestM era (Forest GovActionId)
submitGovActionForest :: forall era.
(StrictMaybe GovActionId -> ImpTestM era GovActionId)
-> StrictMaybe GovActionId
-> Forest ()
-> ImpTestM era (Forest GovActionId)
submitGovActionForest StrictMaybe GovActionId -> ImpTestM era GovActionId
submitAction StrictMaybe GovActionId
p Forest ()
forest =
  forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM Tree (StrictMaybe GovActionId)
-> ImpM
     (LedgerSpec era) (GovActionId, Forest (StrictMaybe GovActionId))
go forall a b. (a -> b) -> a -> b
$ 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 -> b
$ forall a b. a -> b -> a
const StrictMaybe GovActionId
p) Forest ()
forest
  where
    go :: Tree (StrictMaybe GovActionId)
-> ImpM
     (LedgerSpec era) (GovActionId, Forest (StrictMaybe GovActionId))
go (Node StrictMaybe GovActionId
parent Forest (StrictMaybe GovActionId)
children) = do
      GovActionId
n <- StrictMaybe GovActionId -> ImpTestM era GovActionId
submitAction StrictMaybe GovActionId
parent
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovActionId
n, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node StrictMaybe GovActionId
_child Forest (StrictMaybe GovActionId)
subtree) -> forall a. a -> [Tree a] -> Tree a
Node (forall a. a -> StrictMaybe a
SJust GovActionId
n) Forest (StrictMaybe GovActionId)
subtree) Forest (StrictMaybe GovActionId)
children)

enactConstitution ::
  forall era.
  ( ConwayEraImp era
  , HasCallStack
  ) =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
  Constitution era ->
  Credential 'DRepRole ->
  NonEmpty (Credential 'HotCommitteeRole) ->
  ImpTestM era GovActionId
enactConstitution :: forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId Constitution era
constitution Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers = forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Enacting constitution" forall a b. (a -> b) -> a -> b
$ do
  let action :: GovAction era
action = forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era -> GovAction era
NewConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId Constitution era
constitution
  GovActionId
govId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep) GovActionId
govId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers GovActionId
govId
  forall era.
(ConwayEraGov era, ConwayEraPParams era, HasCallStack) =>
GovActionId -> ImpTestM era ()
logRatificationChecks GovActionId
govId
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  Constitution era
enactedConstitution <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL
  Constitution era
enactedConstitution forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovActionId
govId

expectNumDormantEpochs :: HasCallStack => EpochNo -> ImpTestM era ()
expectNumDormantEpochs :: forall era. HasCallStack => EpochNo -> ImpTestM era ()
expectNumDormantEpochs EpochNo
expected = do
  EpochNo
nd <-
    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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL
  EpochNo
nd forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` EpochNo
expected

mkConstitutionProposal ::
  ConwayEraImp era =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
  ImpTestM era (ProposalProcedure era, Constitution era)
mkConstitutionProposal :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (ProposalProcedure era, Constitution era)
mkConstitutionProposal StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId = do
  Constitution era
constitution <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  (,Constitution era
constitution) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal (forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era -> GovAction era
NewConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId Constitution era
constitution)

submitConstitution ::
  forall era.
  ConwayEraImp era =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose era) ->
  ImpTestM era GovActionId
submitConstitution :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era GovActionId
submitConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId = do
  (ProposalProcedure era
proposal, Constitution era
_) <- forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (ProposalProcedure era, Constitution era)
mkConstitutionProposal StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
prevGovId
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal ProposalProcedure era
proposal

expectDRepNotRegistered ::
  HasCallStack =>
  Credential 'DRepRole ->
  ImpTestM era ()
expectDRepNotRegistered :: forall era. HasCallStack => Credential 'DRepRole -> ImpTestM era ()
expectDRepNotRegistered Credential 'DRepRole
drep = do
  Map (Credential 'DRepRole) DRepState
dsMap <- 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 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL)
  forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
drep Map (Credential 'DRepRole) DRepState
dsMap forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. Maybe a
Nothing

isDRepExpired ::
  HasCallStack =>
  Credential 'DRepRole ->
  ImpTestM era Bool
isDRepExpired :: forall era.
HasCallStack =>
Credential 'DRepRole -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole
drep = do
  VState era
vState <- 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) (VState era)
certVStateL
  EpochNo
currentEpoch <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
drep forall a b. (a -> b) -> a -> b
$ VState era
vState forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL of
    Maybe DRepState
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]
"DRep not found", forall a. Show a => a -> [Char]
show Credential 'DRepRole
drep]
    Just DRepState
drep' ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo forall a. Num a => a -> a -> a
(+) (VState era
vState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL) (DRepState
drep' forall s a. s -> Getting a s a -> a
^. Lens' DRepState EpochNo
drepExpiryL)
          forall a. Ord a => a -> a -> Bool
< EpochNo
currentEpoch

expectDRepExpiry ::
  HasCallStack =>
  Credential 'DRepRole ->
  EpochNo ->
  ImpTestM era ()
expectDRepExpiry :: forall era.
HasCallStack =>
Credential 'DRepRole -> EpochNo -> ImpTestM era ()
expectDRepExpiry Credential 'DRepRole
drep EpochNo
expected = do
  Map (Credential 'DRepRole) DRepState
dsMap <- 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) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
  let ds :: DRepState
ds = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
drep Map (Credential 'DRepRole) DRepState
dsMap
  DRepState -> EpochNo
drepExpiry DRepState
ds forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` EpochNo
expected

expectActualDRepExpiry ::
  HasCallStack =>
  Credential 'DRepRole ->
  EpochNo ->
  ImpTestM era ()
expectActualDRepExpiry :: forall era.
HasCallStack =>
Credential 'DRepRole -> EpochNo -> ImpTestM era ()
expectActualDRepExpiry Credential 'DRepRole
drep EpochNo
expected = do
  VState era
vState <- 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) (VState era)
certVStateL
  let actualDRepExpiry :: EpochNo
actualDRepExpiry = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall era. Credential 'DRepRole -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential 'DRepRole
drep VState era
vState
  EpochNo
actualDRepExpiry forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` EpochNo
expected

currentProposalsShouldContain ::
  ( HasCallStack
  , ConwayEraGov era
  ) =>
  GovActionId ->
  ImpTestM era ()
currentProposalsShouldContain :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
currentProposalsShouldContain GovActionId
gai =
  forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
[a] -> [a] -> m ()
shouldContain [GovActionId
gai] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

expectCurrentProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectCurrentProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectCurrentProposals = do
  StrictSeq GovActionId
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected proposals in current gov state" (Bool -> Bool
not (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq GovActionId
props))

expectNoCurrentProposals :: (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals :: forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals = do
  Proposals era
proposals <- forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  case forall era. Proposals era -> StrictSeq (GovActionState era)
proposalsActions Proposals era
proposals of
    StrictSeq (GovActionState era)
Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    StrictSeq (GovActionState era)
xs -> forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"Expected no active proposals, but got:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. ToExpr a => a -> Expr
toExpr StrictSeq (GovActionState era)
xs)

expectPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectPulserProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectPulserProposals = do
  StrictSeq GovActionId
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
lastEpochProposals
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected proposals in the pulser" (Bool -> Bool
not (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq GovActionId
props))

expectNoPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals = do
  StrictSeq GovActionId
props <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
lastEpochProposals
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool [Char]
"Expected no proposals in the pulser" (forall a. StrictSeq a -> Bool
SSeq.null StrictSeq GovActionId
props)

currentProposalIds ::
  ConwayEraGov era => ImpTestM era (SSeq.StrictSeq GovActionId)
currentProposalIds :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds = forall era. Proposals era -> StrictSeq GovActionId
proposalsIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL)

lastEpochProposals ::
  forall era.
  ConwayEraGov era =>
  ImpTestM era (SSeq.StrictSeq GovActionId)
lastEpochProposals :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
lastEpochProposals =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. GovActionState era -> GovActionId
gasId @era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingSnapshot era -> StrictSeq (GovActionState era)
psProposals
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
          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) (GovState era)
utxosGovStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL
      )

pulsingStateSnapshotL :: Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL :: forall era. Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall {era}. DRepPulsingState era -> PulsingSnapshot era
getter forall {era}.
DRepPulsingState era -> PulsingSnapshot era -> DRepPulsingState era
setter
  where
    getter :: DRepPulsingState era -> PulsingSnapshot era
getter (DRComplete PulsingSnapshot era
x RatifyState era
_) = PulsingSnapshot era
x
    getter DRepPulsingState era
state = forall a b. (a, b) -> a
fst (forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
state)
    setter :: DRepPulsingState era -> PulsingSnapshot era -> DRepPulsingState era
setter (DRComplete PulsingSnapshot era
_ RatifyState era
y) PulsingSnapshot era
snap = forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap RatifyState era
y
    setter DRepPulsingState era
state PulsingSnapshot era
snap = forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
state

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

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

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

whenBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap :: forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap ImpTestM era ()
a = do
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
HardForks.bootstrapPhase ProtVer
pv) ImpTestM era ()
a

whenPostBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap :: forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ImpTestM era ()
a = do
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtVer -> Bool
HardForks.bootstrapPhase ProtVer
pv) ImpTestM era ()
a

ifBootstrap :: EraGov era => ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap :: forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap ImpTestM era a
inBootstrap ImpTestM era a
outOfBootstrap = do
  ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  if ProtVer -> Bool
HardForks.bootstrapPhase ProtVer
pv then ImpTestM era a
inBootstrap else ImpTestM era a
outOfBootstrap

submitYesVoteCCs_ ::
  forall era f.
  (ConwayEraImp era, Foldable f) =>
  f (Credential 'HotCommitteeRole) ->
  GovActionId ->
  ImpTestM era ()
submitYesVoteCCs_ :: forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ f (Credential 'HotCommitteeRole)
committeeMembers GovActionId
govId =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Credential 'HotCommitteeRole
c -> forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
c) GovActionId
govId) f (Credential 'HotCommitteeRole)
committeeMembers

mkUpdateCommitteeProposal ::
  ConwayEraImp era =>
  -- | Set the parent. When Nothing is supplied latest parent will be used.
  Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era)) ->
  -- | CC members to remove
  Set.Set (Credential 'ColdCommitteeRole) ->
  -- | CC members to add
  [(Credential 'ColdCommitteeRole, EpochInterval)] ->
  UnitInterval ->
  ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal :: forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent Set (Credential 'ColdCommitteeRole)
ccsToRemove [(Credential 'ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold = do
  NewEpochState era
nes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a. a -> a
id
  let
    curEpochNo :: EpochNo
curEpochNo = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
    rootCommittee :: PRoot (GovPurposeId 'CommitteePurpose era)
rootCommittee = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (ConwayGovState era) (Proposals era)
cgsProposalsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) era.
Lens' (GovRelation f era) (f (GovPurposeId 'CommitteePurpose era))
grCommitteeL
    parent :: StrictMaybe (GovPurposeId 'CommitteePurpose era)
parent = forall a. a -> Maybe a -> a
fromMaybe (forall a. PRoot a -> StrictMaybe a
prRoot PRoot (GovPurposeId 'CommitteePurpose era)
rootCommittee) Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent
    newCommitteMembers :: Map (Credential 'ColdCommitteeRole) EpochNo
newCommitteMembers =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Credential 'ColdCommitteeRole
cc, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
lifetime) | (Credential 'ColdCommitteeRole
cc, EpochInterval
lifetime) <- [(Credential 'ColdCommitteeRole, EpochInterval)]
ccsToAdd]
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
parent Set (Credential 'ColdCommitteeRole)
ccsToRemove Map (Credential 'ColdCommitteeRole) EpochNo
newCommitteMembers UnitInterval
threshold

submitUpdateCommittee ::
  ConwayEraImp era =>
  -- | Set the parent. When Nothing is supplied latest parent will be used.
  Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era)) ->
  -- | CC members to remove
  Set.Set (Credential 'ColdCommitteeRole) ->
  -- | CC members to add
  [(Credential 'ColdCommitteeRole, EpochInterval)] ->
  UnitInterval ->
  ImpTestM era GovActionId
submitUpdateCommittee :: forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
submitUpdateCommittee Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent Set (Credential 'ColdCommitteeRole)
ccsToRemove [(Credential 'ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold =
  forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
mParent Set (Credential 'ColdCommitteeRole)
ccsToRemove [(Credential 'ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal

expectCommitteeMemberPresence ::
  (HasCallStack, ConwayEraGov era) => Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole
cc = do
  SJust Committee era
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool ([Char]
"Expected Committee Member: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole
cc forall a. [a] -> [a] -> [a]
++ [Char]
" to be present in the committee") forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential 'ColdCommitteeRole
cc (Committee era
committee forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (Committee era) (Map (Credential 'ColdCommitteeRole) EpochNo)
committeeMembersL)

expectCommitteeMemberAbsence ::
  (HasCallStack, ConwayEraGov era) => Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberAbsence :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole
cc = do
  SJust Committee era
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
[Char] -> Bool -> m ()
assertBool ([Char]
"Expected Committee Member: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'ColdCommitteeRole
cc forall a. [a] -> [a] -> [a]
++ [Char]
" to be absent from the committee") forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'ColdCommitteeRole
cc (Committee era
committee forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (Committee era) (Map (Credential 'ColdCommitteeRole) EpochNo)
committeeMembersL)

donateToTreasury :: ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury :: forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury Coin
amount =
  forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn ([Char]
"Donation to treasury in the amount of: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Coin
amount) forall a b. (a -> b) -> a -> b
$ do
    Coin
treasuryStart <- 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
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ 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. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
amount)
    Coin
treasuryEndEpoch0 <- 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
    -- Actual donation happens on the epoch boundary
    Coin
treasuryStart forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
treasuryEndEpoch0
    forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    Coin
treasuryEndEpoch1 <- 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
treasuryEndEpoch1 forall t. Val t => t -> t -> t
<-> Coin
treasuryStart forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
amount

expectMembers ::
  (HasCallStack, ConwayEraGov era) =>
  Set.Set (Credential 'ColdCommitteeRole) -> ImpTestM era ()
expectMembers :: forall era.
(HasCallStack, ConwayEraGov era) =>
Set (Credential 'ColdCommitteeRole) -> ImpTestM era ()
expectMembers Set (Credential 'ColdCommitteeRole)
expKhs = do
  StrictMaybe (Committee era)
committee <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  let members :: Set (Credential 'ColdCommitteeRole)
members = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
  forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"Expecting committee members" forall a b. (a -> b) -> a -> b
$ Set (Credential 'ColdCommitteeRole)
members forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Set (Credential 'ColdCommitteeRole)
expKhs

showConwayTxBalance ::
  ( EraUTxO era
  , ConwayEraTxBody era
  , Tx era ~ AlonzoTx era
  ) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  AlonzoTx era ->
  String
showConwayTxBalance :: forall era.
(EraUTxO era, ConwayEraTxBody era, Tx era ~ AlonzoTx era) =>
PParams era -> CertState era -> UTxO era -> AlonzoTx era -> [Char]
showConwayTxBalance PParams era
pp CertState era
certState UTxO era
utxo AlonzoTx era
tx =
  [[Char]] -> [Char]
unlines
    [ [Char]
"Consumed:"
    , [Char]
"\tInputs:     \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall t. Val t => t -> Coin
coin Value era
inputs)
    , [Char]
"\tRefunds:    \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Coin
refunds
    , [Char]
"\tWithdrawals \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Coin
withdrawals
    , [Char]
"\tTotal:      \t" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody)
    , [Char]
""
    , [Char]
"Produced:"
    , [Char]
"\tOutputs:   \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL))
    , [Char]
"\tDonations: \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL)
    , [Char]
"\tDeposits:  \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall era.
EraTxBody era =>
PParams era -> (KeyHash 'StakePool -> Bool) -> TxBody era -> Coin
getTotalDepositsTxBody PParams era
pp KeyHash 'StakePool -> Bool
isRegPoolId TxBody era
txBody)
    , [Char]
"\tFees:      \t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL)
    , [Char]
"\tTotal:     \t" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Val t => t -> Coin
coin forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState TxBody era
txBody)
    ]
  where
    txBody :: TxBody era
txBody = AlonzoTx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    inputs :: Value era
inputs = forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
    refunds :: Coin
refunds =
      forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody
        PParams era
pp
        (forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState forall a b. (a -> b) -> a -> b
$ CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (DState era)
certDStateL)
        (forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState forall a b. (a -> b) -> a -> b
$ CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (VState era)
certVStateL)
        TxBody era
txBody
    isRegPoolId :: KeyHash 'StakePool -> Bool
isRegPoolId = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (PState era)
certPStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (PState era) (Map (KeyHash 'StakePool) PoolParams)
psStakePoolParamsL))
    withdrawals :: Coin
withdrawals = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL

logConwayTxBalance ::
  ( EraUTxO era
  , EraGov era
  , ConwayEraTxBody era
  , Tx era ~ AlonzoTx era
  ) =>
  AlonzoTx era ->
  ImpTestM era ()
logConwayTxBalance :: forall era.
(EraUTxO era, EraGov era, ConwayEraTxBody era,
 Tx era ~ AlonzoTx era) =>
AlonzoTx era -> ImpTestM era ()
logConwayTxBalance AlonzoTx era
tx = do
  PParams era
pp <- forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams forall a. a -> a
id
  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
  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
  forall t. HasCallStack => [Char] -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ConwayEraTxBody era, Tx era ~ AlonzoTx era) =>
PParams era -> CertState era -> UTxO era -> AlonzoTx era -> [Char]
showConwayTxBalance PParams era
pp CertState era
certState UTxO era
utxo AlonzoTx era
tx

submitBootstrapAwareFailingVote ::
  ConwayEraImp era =>
  Vote ->
  Voter ->
  GovActionId ->
  SubmitFailureExpectation era ->
  ImpTestM era ()
submitBootstrapAwareFailingVote :: forall era.
ConwayEraImp era =>
Vote
-> Voter
-> GovActionId
-> SubmitFailureExpectation era
-> ImpTestM era ()
submitBootstrapAwareFailingVote Vote
vote Voter
voter GovActionId
gaId =
  forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
    (forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era ()
submitVote_ Vote
vote Voter
voter GovActionId
gaId)
    (forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter
-> GovActionId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingVote Voter
voter GovActionId
gaId)

submitBootstrapAwareFailingProposal ::
  ConwayEraImp era =>
  ProposalProcedure era ->
  SubmitFailureExpectation era ->
  ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal :: forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal =
  forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
    (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal ProposalProcedure era
proposal)
    ((forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingProposal ProposalProcedure era
proposal)

submitBootstrapAwareFailingProposal_ ::
  ConwayEraImp era =>
  ProposalProcedure era ->
  SubmitFailureExpectation era ->
  ImpTestM era ()
submitBootstrapAwareFailingProposal_ :: forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era ()
submitBootstrapAwareFailingProposal_ ProposalProcedure era
p = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
p

data SubmitFailureExpectation era
  = FailBootstrap (NE.NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  | FailPostBootstrap (NE.NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  | FailBootstrapAndPostBootstrap (FailBoth era)

data FailBoth era = FailBoth
  { forall era.
FailBoth era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
bootstrapFailures :: NE.NonEmpty (PredicateFailure (EraRule "LEDGER" era))
  , forall era.
FailBoth era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
postBootstrapFailures :: NE.NonEmpty (PredicateFailure (EraRule "LEDGER" era))
  }

submitBootstrapAware ::
  EraGov era =>
  ImpTestM era a ->
  (NE.NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era a) ->
  SubmitFailureExpectation era ->
  ImpTestM era a
submitBootstrapAware :: forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware ImpTestM era a
action NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era a
failAction =
  \case
    FailBootstrap NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures ->
      forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era a
failAction NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures)
        ImpTestM era a
action
    FailPostBootstrap NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures ->
      forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap
        ImpTestM era a
action
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era a
failAction NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures)
    FailBootstrapAndPostBootstrap (FailBoth NonEmpty (PredicateFailure (EraRule "LEDGER" era))
bFailures NonEmpty (PredicateFailure (EraRule "LEDGER" era))
pBFailures) ->
      forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era a
failAction NonEmpty (PredicateFailure (EraRule "LEDGER" era))
bFailures)
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era a
failAction NonEmpty (PredicateFailure (EraRule "LEDGER" era))
pBFailures)

delegateSPORewardAddressToDRep_ ::
  ConwayEraImp era =>
  KeyHash 'StakePool ->
  Coin ->
  DRep ->
  ImpTestM era ()
delegateSPORewardAddressToDRep_ :: forall era.
ConwayEraImp era =>
KeyHash 'StakePool -> Coin -> DRep -> ImpTestM era ()
delegateSPORewardAddressToDRep_ KeyHash 'StakePool
kh Coin
stake DRep
drep = do
  PoolParams
pp <- forall era. ConwayEraGov era => ImpTestM era (RatifyEnv era)
getRatifyEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
kh forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. RatifyEnv era -> Map (KeyHash 'StakePool) PoolParams
rePoolParams
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep
      (RewardAccount -> Credential 'Staking
raCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> RewardAccount
ppRewardAccount forall a b. (a -> b) -> a -> b
$ PoolParams
pp)
      Coin
stake
      DRep
drep