{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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,
  conwayModifyImpInitProtVer,
  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,
  submitCommitteeElection,
  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,
  currentProposalsShouldContain,
  ifBootstrap,
  whenBootstrap,
  whenPostBootstrap,
  submitYesVoteCCs_,
  donateToTreasury,
  expectMembers,
  showConwayTxBalance,
  logConwayTxBalance,
  submitBootstrapAware,
  submitBootstrapAwareFailingVote,
  submitBootstrapAwareFailingProposal,
  submitBootstrapAwareFailingProposal_,
  SubmitFailureExpectation (..),
  FailBoth (..),
  delegateSPORewardAddressToDRep_,
  getCommittee,
  conwayDelegStakeTxCert,
) where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  ProtVer (..),
  ShelleyBase,
  StrictMaybe (..),
  UnitInterval,
  Version,
  addEpochInterval,
  binOpEpochNo,
  inject,
  textToUrl,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway (ConwayEra, hardforkConwayBootstrapPhase)
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 (
  ConwayBbodyPredFailure,
  ConwayCertPredFailure (..),
  ConwayCertsPredFailure (..),
  ConwayDelegPredFailure (..),
  ConwayEpochEvent,
  ConwayGovCertPredFailure,
  ConwayGovPredFailure,
  ConwayHardForkEvent,
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure,
  ConwayUtxosPredFailure,
  ConwayUtxowPredFailure,
  EnactSignal,
  committeeAccepted,
  committeeAcceptedRatio,
  dRepAccepted,
  dRepAcceptedRatio,
  prevActionAsExpected,
  spoAccepted,
  spoAcceptedRatio,
  validCommitteeTerm,
  withdrawalCanWithdraw,
 )
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Conway.TxCert (Delegatee (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.LedgerState (
  curPParamsEpochStateL,
  epochStateGovStateL,
  epochStateStakePoolsL,
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEpochStateL,
  nesEsL,
  nesPdL,
  newEpochStateGovStateL,
  produced,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Rules (
  ShelleyDelegPredFailure,
 )
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.TxIn (TxId (..))
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 qualified Data.Text as T
import Data.Tree
import Data.Typeable (Typeable)
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.Era
import Test.Cardano.Ledger.Conway.TreeDiff (tableDoc)
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)
import Test.ImpSpec

-- | 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 = (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \NewEpochState era
nes ->
  NewEpochState era
nes
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PParams era -> Identity (PParams era))
    -> EpochState era -> Identity (EpochState era))
-> (PParams era -> Identity (PParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (PParams era -> PParams era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams era -> PParams era
f
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Identity (GovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((DRepPulsingState era -> Identity (DRepPulsingState era))
    -> GovState era -> Identity (GovState era))
-> (DRepPulsingState era -> Identity (DRepPulsingState era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Identity (DRepPulsingState era))
-> GovState era -> Identity (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL ((DRepPulsingState era -> Identity (DRepPulsingState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (DRepPulsingState era -> DRepPulsingState era)
-> NewEpochState era
-> NewEpochState era
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 DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
pulser of
        (PulsingSnapshot era
snapshot, RatifyState era
ratifyState) ->
          PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snapshot (RatifyState era
ratifyState RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (EnactState era -> Identity (EnactState era))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Identity (EnactState era))
 -> RatifyState era -> Identity (RatifyState era))
-> ((PParams era -> Identity (PParams era))
    -> EnactState era -> Identity (EnactState era))
-> (PParams era -> Identity (PParams era))
-> RatifyState era
-> Identity (RatifyState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> EnactState era -> f (EnactState era)
ensCurPParamsL ((PParams era -> Identity (PParams era))
 -> RatifyState era -> Identity (RatifyState era))
-> (PParams era -> PParams era)
-> RatifyState era
-> RatifyState era
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
    kh1 <- m (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    kh2 <- freshKeyHash
    let
      ccExpiryEpochNo = EpochNo -> EpochInterval -> EpochNo
addEpochInterval (forall era. Era era => EpochNo
impEraStartEpochNo @ConwayEra) (Word32 -> EpochInterval
EpochInterval Word32
15)
      committee = Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee ConwayEra
forall era.
Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
Committee [(KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash ColdCommitteeRole
kh1, EpochNo
ccExpiryEpochNo), (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash ColdCommitteeRole
kh2, EpochNo
ccExpiryEpochNo)] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
      constitutionAnchor =
        Anchor
          { anchorUrl :: Url
anchorUrl = Fail Url -> Url
forall a. HasCallStack => Fail a -> a
errorFail (Fail Url -> Url) -> Fail Url -> Url
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Fail Url
forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
128 Text
"https://cardano-constitution.crypto"
          , anchorDataHash :: SafeHash AnchorData
anchorDataHash = AnchorData -> SafeHash AnchorData
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (ByteString -> AnchorData
AnchorData ByteString
"Cardano Constitution Content")
          }
      guardrailScriptHash = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus 'PlutusV3
guardrailScript
    pure
      ConwayGenesis
        { cgUpgradePParams =
            UpgradeConwayPParams
              { ucppPoolVotingThresholds =
                  PoolVotingThresholds
                    { pvtMotionNoConfidence = 51 %! 100
                    , pvtCommitteeNormal = 65 %! 100
                    , pvtCommitteeNoConfidence = 65 %! 100
                    , pvtHardForkInitiation = 51 %! 100
                    , pvtPPSecurityGroup = 51 %! 100
                    }
              , ucppDRepVotingThresholds =
                  DRepVotingThresholds
                    { dvtMotionNoConfidence = 51 %! 100
                    , dvtCommitteeNormal = 65 %! 100
                    , dvtCommitteeNoConfidence = 65 %! 100
                    , dvtUpdateToConstitution = 65 %! 100
                    , dvtHardForkInitiation = 51 %! 100
                    , dvtPPNetworkGroup = 51 %! 100
                    , dvtPPEconomicGroup = 51 %! 100
                    , dvtPPTechnicalGroup = 51 %! 100
                    , dvtPPGovGroup = 75 %! 100
                    , dvtTreasuryWithdrawal = 51 %! 100
                    }
              , ucppCommitteeMinSize = 1
              , ucppCommitteeMaxTermLength = EpochInterval 20
              , ucppGovActionLifetime = EpochInterval 30
              , ucppGovActionDeposit = Coin 123
              , ucppDRepDeposit = Coin 70_000_000
              , ucppDRepActivity = EpochInterval 100
              , ucppMinFeeRefScriptCostPerByte = 15 %! 1
              , ucppPlutusV3CostModel = testingCostModel PlutusV3
              }
        , cgConstitution = Constitution constitutionAnchor (SJust guardrailScriptHash)
        , cgCommittee = committee
        , cgDelegs = mempty
        , cgInitialDReps = mempty
        }

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

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

  fixupTx :: HasCallStack =>
Tx TopTx ConwayEra -> ImpTestM ConwayEra (Tx TopTx ConwayEra)
fixupTx = Tx TopTx ConwayEra -> ImpTestM ConwayEra (Tx TopTx ConwayEra)
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
babbageFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx ConwayEra -> ImpTestM ConwayEra ()
expectTxSuccess = Tx TopTx ConwayEra -> ImpTestM ConwayEra ()
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era ()
impBabbageExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp ConwayEra =>
Version
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
-> SpecWith (ImpInit (LedgerSpec ConwayEra))
forall era.
ConwayEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
conwayModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM ConwayEra (TxCert ConwayEra)
genRegTxCert = Credential Staking -> ImpTestM ConwayEra (TxCert ConwayEra)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ShelleyEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
conwayGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM ConwayEra (TxCert ConwayEra)
genUnRegTxCert = Credential Staking -> ImpTestM ConwayEra (TxCert ConwayEra)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ShelleyEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
conwayGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert ConwayEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
conwayDelegStakeTxCert

conwayModifyImpInitProtVer ::
  forall era.
  ConwayEraImp era =>
  Version ->
  SpecWith (ImpInit (LedgerSpec era)) ->
  SpecWith (ImpInit (LedgerSpec era))
conwayModifyImpInitProtVer :: forall era.
ConwayEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
conwayModifyImpInitProtVer Version
ver =
  (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit ((ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpInit (LedgerSpec era) -> ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \ImpInit (LedgerSpec era)
impInit ->
    ImpInit (LedgerSpec era)
impInit
      { impInitState =
          impInitState impInit
            & impNESL . nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer ver 0
            & impNESL . nesEsL %~ (\EpochState era
es -> PulsingSnapshot era
-> RatifyState era -> EpochState era -> EpochState era
forall era.
ConwayEraGov era =>
PulsingSnapshot era
-> RatifyState era -> EpochState era -> EpochState era
setCompleteDRepPulsingState PulsingSnapshot era
forall a. Default a => a
def (EpochState era -> RatifyState era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ConwayEraGov era) =>
EpochState era -> RatifyState era
ratifyState EpochState era
es) EpochState era
es)
      }
  where
    ratifyState :: EpochState era -> RatifyState era
ratifyState EpochState era
es = RatifyState era
forall a. Default a => a
def RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (EnactState era -> Identity (EnactState era))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Identity (EnactState era))
 -> RatifyState era -> Identity (RatifyState era))
-> EnactState era -> RatifyState era -> RatifyState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovState era -> EnactState era
forall era. ConwayEraGov era => GovState era -> EnactState era
mkEnactState (EpochState era
es EpochState era
-> Getting (GovState era) (EpochState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. Getting (GovState era) (EpochState era) (GovState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL)

instance MaryEraImp ConwayEra

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

instance BabbageEraImp ConwayEra

class
  ( BabbageEraImp era
  , ConwayEraTest 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) ~ ()
  , NFData (Event (EraRule "ENACT" era))
  , ToExpr (Event (EraRule "ENACT" era))
  , Typeable (Event (EraRule "ENACT" era))
  , Eq (Event (EraRule "ENACT" era))
  , GovState era ~ ConwayGovState era
  , InjectRuleFailure "LEDGER" ConwayUtxowPredFailure era
  , InjectRuleFailure "LEDGER" ConwayUtxosPredFailure era
  , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
  , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
  , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
  , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
  , InjectRuleEvent "TICK" ConwayHardForkEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent 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
  committeeMembers <- Set (Credential ColdCommitteeRole)
-> [Credential ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential ColdCommitteeRole)
 -> [Credential ColdCommitteeRole])
-> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) [Credential ColdCommitteeRole]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
  case committeeMembers of
    Credential ColdCommitteeRole
x : [Credential ColdCommitteeRole]
xs -> ImpTestM era (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerCommitteeHotKeys (KeyHash HotCommitteeRole -> Credential HotCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash HotCommitteeRole -> Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
-> ImpTestM era (Credential HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash) (NonEmpty (Credential ColdCommitteeRole)
 -> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole)))
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
forall a b. (a -> b) -> a -> b
$ Credential ColdCommitteeRole
x Credential ColdCommitteeRole
-> [Credential ColdCommitteeRole]
-> NonEmpty (Credential ColdCommitteeRole)
forall a. a -> [a] -> NonEmpty a
NE.:| [Credential ColdCommitteeRole]
xs
    [] -> String
-> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
forall a. HasCallStack => String -> a
error String
"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
  khDRep <- ImpM (LedgerSpec era) (KeyHash DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  submitTxAnn_ "Register DRep" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton
          ( RegDRepTxCert
              (KeyHashObj khDRep)
              (pp ^. ppDRepDepositL)
              SNothing
          )
  dreps <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL
  dreps `shouldSatisfy` Map.member (KeyHashObj khDRep)
  pure khDRep

-- | Submit a transaction that unregisters a given DRep
unRegisterDRep ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  , ConwayEraCertState era
  ) =>
  Credential DRepRole ->
  ImpTestM era ()
unRegisterDRep :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ConwayEraCertState era) =>
Credential DRepRole -> ImpTestM era ()
unRegisterDRep Credential DRepRole
drep = do
  drepState <- Credential DRepRole -> ImpTestM era DRepState
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> ImpTestM era DRepState
getDRepState Credential DRepRole
drep
  let refund = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ DRepState -> CompactForm Coin
drepDeposit DRepState
drepState
  submitTxAnn_ "UnRegister DRep" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton (UnRegDRepTxCert drep refund)

conwayGenUnRegTxCert ::
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  , ShelleyEraTxCert era
  ) =>
  Credential Staking ->
  ImpTestM era (TxCert era)
conwayGenUnRegTxCert :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ShelleyEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
conwayGenUnRegTxCert Credential Staking
stakingCredential = do
  accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL)
  case lookupAccountState stakingCredential accounts of
    Maybe (AccountState era)
Nothing -> TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era -> ImpM (LedgerSpec era) (TxCert era))
-> TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a b. (a -> b) -> a -> b
$ Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
UnRegTxCert Credential Staking
stakingCredential
    Just AccountState era
accountState ->
      [TxCert era] -> ImpM (LedgerSpec era) (TxCert era)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements
        [ Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
UnRegTxCert Credential Staking
stakingCredential
        , Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
stakingCredential (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL))
        ]

conwayGenRegTxCert ::
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  , ShelleyEraTxCert era
  ) =>
  Credential Staking ->
  ImpTestM era (TxCert era)
conwayGenRegTxCert :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ShelleyEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
conwayGenRegTxCert Credential Staking
stakingCredential =
  [ImpM (LedgerSpec era) (TxCert era)]
-> ImpM (LedgerSpec era) (TxCert era)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
oneof
    [ TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era -> ImpM (LedgerSpec era) (TxCert era))
-> TxCert era -> ImpM (LedgerSpec era) (TxCert era)
forall a b. (a -> b) -> a -> b
$ Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
RegTxCert Credential Staking
stakingCredential
    , Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
stakingCredential
        (Coin -> TxCert era)
-> ImpM (LedgerSpec era) Coin -> ImpM (LedgerSpec era) (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
    ]

conwayDelegStakeTxCert ::
  ConwayEraTxCert era =>
  Credential Staking ->
  KeyHash StakePool ->
  TxCert era
conwayDelegStakeTxCert :: forall era.
ConwayEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
conwayDelegStakeTxCert Credential Staking
cred KeyHash StakePool
pool = Credential Staking -> Delegatee -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Delegatee -> TxCert era
DelegTxCert Credential Staking
cred (KeyHash StakePool -> Delegatee
DelegStake KeyHash StakePool
pool)

-- | 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
  mAnchor <- ImpM (LedgerSpec era) (StrictMaybe Anchor)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  submitTxAnn_ "Update DRep" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton (UpdateDRepTxCert drep 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
  drepKH <- ImpTestM era (KeyHash DRepRole)
forall era. ConwayEraImp era => ImpTestM era (KeyHash DRepRole)
registerDRep
  delegatorKH <- freshKeyHash
  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
  submitTxAnn_ "Delegate to DRep" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList
          [ RegDepositDelegTxCert
              (KeyHashObj delegatorKH)
              (DelegVote (DRepCredential $ KeyHashObj drepKH))
              deposit
          ]
  pure (drepKH, 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 = String
-> ImpM
     (LedgerSpec era)
     (Credential DRepRole, Credential Staking, KeyPair Payment)
-> ImpM
     (LedgerSpec era)
     (Credential DRepRole, Credential Staking, KeyPair Payment)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Set up a single DRep" (ImpM
   (LedgerSpec era)
   (Credential DRepRole, Credential Staking, KeyPair Payment)
 -> ImpM
      (LedgerSpec era)
      (Credential DRepRole, Credential Staking, KeyPair Payment))
-> ImpM
     (LedgerSpec era)
     (Credential DRepRole, Credential Staking, KeyPair Payment)
-> ImpM
     (LedgerSpec era)
     (Credential DRepRole, Credential Staking, KeyPair Payment)
forall a b. (a -> b) -> a -> b
$ do
  drepKH <- ImpTestM era (KeyHash DRepRole)
forall era. ConwayEraImp era => ImpTestM era (KeyHash DRepRole)
registerDRep
  delegatorKH <- freshKeyHash
  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
  let tx =
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
            ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
delegatorKH) Coin
deposit]
  submitTx_ tx
  spendingKP <-
    delegateToDRep (KeyHashObj delegatorKH) (Coin stake) (DRepCredential (KeyHashObj drepKH))
  pure (KeyHashObj drepKH, KeyHashObj delegatorKH, 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
  (_, spendingKP) <- ImpM (LedgerSpec era) (KeyHash Payment, KeyPair Payment)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, KeyPair r)
freshKeyPair

  submitTxAnn_ "Delegate to DRep" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . outputsTxBodyL
        .~ SSeq.singleton (mkBasicTxOut (mkAddr spendingKP cred) (inject stake))
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList [DelegTxCert cred (DelegVote dRep)]
  pure spendingKP

getDRepState ::
  (HasCallStack, ConwayEraCertState era) =>
  Credential DRepRole ->
  ImpTestM era DRepState
getDRepState :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> ImpTestM era DRepState
getDRepState Credential DRepRole
dRepCred = do
  drepsState <- SimpleGetter
  (NewEpochState era) (Map (Credential DRepRole) DRepState)
-> ImpTestM era (Map (Credential DRepRole) DRepState)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era) (Map (Credential DRepRole) DRepState)
 -> ImpTestM era (Map (Credential DRepRole) DRepState))
-> SimpleGetter
     (NewEpochState era) (Map (Credential DRepRole) DRepState)
-> ImpTestM era (Map (Credential DRepRole) DRepState)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> VState era -> Const r (VState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential DRepRole) DRepState
 -> Const r (Map (Credential DRepRole) DRepState))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential DRepRole) DRepState
 -> f (Map (Credential DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
  case Map.lookup dRepCred drepsState of
    Maybe DRepState
Nothing -> String -> ImpM (LedgerSpec era) DRepState
forall a. HasCallStack => String -> a
error (String -> ImpM (LedgerSpec era) DRepState)
-> String -> ImpM (LedgerSpec era) DRepState
forall a b. (a -> b) -> a -> b
$ String
"Expected for DRep " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Credential DRepRole -> String
forall a. Show a => a -> String
show Credential DRepRole
dRepCred String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be present in the CertState"
    Just DRepState
state -> DRepState -> ImpM (LedgerSpec era) DRepState
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DRepState
state

-- | 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 ::
  ConwayEraImp era =>
  Coin ->
  ImpTestM era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake :: forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake Coin
delegCoin = String
-> ImpM
     (LedgerSpec era)
     (KeyHash StakePool, Credential Payment, Credential Staking)
-> ImpM
     (LedgerSpec era)
     (KeyHash StakePool, Credential Payment, Credential Staking)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Set up pool with stake" (ImpM
   (LedgerSpec era)
   (KeyHash StakePool, Credential Payment, Credential Staking)
 -> ImpM
      (LedgerSpec era)
      (KeyHash StakePool, Credential Payment, Credential Staking))
-> ImpM
     (LedgerSpec era)
     (KeyHash StakePool, Credential Payment, Credential Staking)
-> ImpM
     (LedgerSpec era)
     (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ do
  khPool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  registerPool khPool
  credDelegatorPayment <- KeyHashObj <$> freshKeyHash
  credDelegatorStaking <- KeyHashObj <$> freshKeyHash
  sendCoinTo_ (mkAddr credDelegatorPayment credDelegatorStaking) delegCoin
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  submitTxAnn_ "Delegate to stake pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList
          [ RegDepositDelegTxCert
              credDelegatorStaking
              (DelegStake khPool)
              (pp ^. ppKeyDepositL)
          ]
  pure (khPool, credDelegatorPayment, credDelegatorStaking)

setupPoolWithoutStake ::
  ConwayEraImp era =>
  ImpTestM era (KeyHash StakePool, Credential Staking)
setupPoolWithoutStake :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential Staking)
setupPoolWithoutStake = do
  khPool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  registerPool khPool
  credDelegatorStaking <- KeyHashObj <$> freshKeyHash
  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
  submitTxAnn_ "Delegate to stake pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList
          [ RegDepositDelegTxCert
              credDelegatorStaking
              (DelegStake khPool)
              deposit
          ]
  pure (khPool, 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 = Vote
-> Voter
-> GovActionId
-> ImpTestM
     era
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
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 ImpM
  (LedgerSpec era)
  (Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId)
-> (Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId
    -> ImpM (LedgerSpec era) TxId)
-> ImpM (LedgerSpec era) TxId
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId
-> ImpM (LedgerSpec era) TxId
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 = ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Vote -> Voter -> GovActionId -> ImpM (LedgerSpec era) TxId
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 = ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxId -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Vote -> Voter -> GovActionId -> ImpM (LedgerSpec era) TxId
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 =
  Vote
-> Voter
-> GovActionId
-> ImpTestM
     era
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
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 ImpM
  (LedgerSpec era)
  (Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId)
-> (Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId
    -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
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 =
  String
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (String
"Submitting vote (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Vote -> String
forall a. Show a => a -> String
show Vote
vote String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")") (ImpM
   (LedgerSpec era)
   (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
 -> ImpM
      (LedgerSpec era)
      (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId))
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
forall a b. (a -> b) -> a -> b
$
    (Either
   (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
   (Tx TopTx era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
        (Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
forall a b.
(a -> b) -> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
 -> NonEmpty (EraRuleFailure "LEDGER" era))
-> (Tx TopTx era -> TxId)
-> Either
     (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
     (Tx TopTx era)
-> Either (NonEmpty (EraRuleFailure "LEDGER" era)) TxId
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a b. (a, b) -> a
fst Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx) (ImpM
   (LedgerSpec era)
   (Either
      (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
      (Tx TopTx era))
 -> ImpM
      (LedgerSpec era)
      (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId))
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
        (Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
forall a b. (a -> b) -> a -> b
$
      Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitTx (Tx TopTx era
 -> ImpTestM
      era
      (Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
         (Tx TopTx era)))
-> Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((VotingProcedures era -> Identity (VotingProcedures era))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (VotingProcedures era -> Identity (VotingProcedures era))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
            ((VotingProcedures era -> Identity (VotingProcedures era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> VotingProcedures era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
              ( Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
                  Voter
voter
                  ( GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton
                      GovActionId
gaId
                      ( VotingProcedure
                          { vProcVote :: Vote
vProcVote = Vote
vote
                          , vProcAnchor :: StrictMaybe Anchor
vProcAnchor = StrictMaybe Anchor
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_ = ImpM (LedgerSpec era) GovActionId -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) GovActionId -> ImpM (LedgerSpec era) ())
-> (ProposalProcedure era -> ImpM (LedgerSpec era) GovActionId)
-> ProposalProcedure era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProposalProcedure era -> ImpM (LedgerSpec era) GovActionId
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 = ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal ProposalProcedure era
proposal ImpM
  (LedgerSpec era)
  (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId)
-> (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
    -> ImpM (LedgerSpec era) GovActionId)
-> ImpM (LedgerSpec era) GovActionId
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
-> ImpM (LedgerSpec era) GovActionId
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
  curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  tx <- trySubmitProposals proposals >>= expectRightExpr
  let txId = Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx TopTx era
tx
      proposalsWithGovActionId =
        (Word16
 -> ProposalProcedure era -> (GovActionId, ProposalProcedure era))
-> NonEmpty Word16
-> NonEmpty (ProposalProcedure era)
-> NonEmpty (GovActionId, ProposalProcedure era)
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 Word16 -> [Word16] -> NonEmpty Word16
forall a. a -> [a] -> NonEmpty a
NE.:| [Word16
Item [Word16]
1 ..]) NonEmpty (ProposalProcedure era)
proposals
  forM proposalsWithGovActionId $ \(GovActionId
govActionId, ProposalProcedure era
proposal) -> do
    govActionState <- GovActionId -> ImpTestM era (GovActionState era)
forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId
    govActionState
      `shouldBeExpr` GovActionState
        { gasId = govActionId
        , gasCommitteeVotes = mempty
        , gasDRepVotes = mempty
        , gasStakePoolVotes = mempty
        , gasProposalProcedure = proposal
        , gasProposedIn = curEpochNo
        , gasExpiresAfter = addEpochInterval curEpochNo (pp ^. ppGovActionLifetimeL)
        }
    pure 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
  res <- NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitProposals (ProposalProcedure era -> NonEmpty (ProposalProcedure era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProposalProcedure era
proposal)
  pure $ case res of
    Right Tx TopTx era
tx ->
      GovActionId
-> Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
forall a b. b -> Either a b
Right
        GovActionId
          { gaidTxId :: TxId
gaidTxId = Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx TopTx era
tx
          , gaidGovActionIx :: GovActionIx
gaidGovActionIx = Word16 -> GovActionIx
GovActionIx Word16
0
          }
    Left (NonEmpty (EraRuleFailure "LEDGER" era)
err, Tx TopTx era
_) -> NonEmpty (EraRuleFailure "LEDGER" era)
-> Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
forall a b. a -> Either a b
Left NonEmpty (EraRuleFailure "LEDGER" era)
err

trySubmitProposals ::
  ( ShelleyEraImp era
  , ConwayEraTxBody era
  ) =>
  NE.NonEmpty (ProposalProcedure era) ->
  ImpTestM
    era
    (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era))
trySubmitProposals :: forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
NonEmpty (ProposalProcedure era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitProposals NonEmpty (ProposalProcedure era)
proposals = do
  Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitTx (Tx TopTx era
 -> ImpTestM
      era
      (Either
         (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
         (Tx TopTx era)))
-> Tx TopTx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
    TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
      Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))]
-> OSet (ProposalProcedure era)
forall l. IsList l => [Item l] -> l
GHC.fromList (NonEmpty (ProposalProcedure era) -> [ProposalProcedure era]
forall a. NonEmpty a -> [a]
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 =
  ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
ProposalProcedure era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitProposal ProposalProcedure era
proposal ImpM
  (LedgerSpec era)
  (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId)
-> (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
    -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
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 ::
  ConwayEraImp era =>
  GovAction era ->
  ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction :: forall era.
ConwayEraImp era =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction GovAction era
ga = do
  let mkGovActionId :: Tx l era -> GovActionId
mkGovActionId Tx l era
tx = TxId -> GovActionIx -> GovActionId
GovActionId (Tx l era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx l era
tx) (Word16 -> GovActionIx
GovActionIx Word16
0)
  ((NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
 -> NonEmpty (EraRuleFailure "LEDGER" era))
-> (Tx TopTx era -> GovActionId)
-> Either
     (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
     (Tx TopTx era)
-> Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a b. (a, b) -> a
fst Tx TopTx era -> GovActionId
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
Tx l era -> GovActionId
mkGovActionId (Either
   (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
   (Tx TopTx era)
 -> Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId)
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
        (Tx TopTx era))
-> ImpM
     (LedgerSpec era)
     (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
ConwayEraImp era =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitGovActions (GovAction era -> NonEmpty (GovAction era)
forall a. a -> NonEmpty a
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 <- Credential Staking -> ImpTestM era RewardAccount
forall era. Credential Staking -> ImpTestM era RewardAccount
getRewardAccountFor Credential Staking
stakingC
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  let
    EpochInterval lifetime = pp ^. ppGovActionLifetimeL
    deposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
  gai <-
    submitProposal $
      ProposalProcedure
        { pProcDeposit = deposit
        , pProcReturnAddr = rewardAccount
        , pProcGovAction = InfoAction
        , pProcAnchor = def
        }
  passNEpochs $ 2 + fromIntegral lifetime
  expectMissingGovActionId gai

-- | Submits a transaction that proposes the given governance action
trySubmitGovActions ::
  ConwayEraImp era =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM
    era
    (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era) (Tx TopTx era))
trySubmitGovActions :: forall era.
ConwayEraImp era =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitGovActions NonEmpty (GovAction era)
gas = do
  proposals <- (GovAction era -> ImpM (LedgerSpec era) (ProposalProcedure era))
-> NonEmpty (GovAction era)
-> ImpM (LedgerSpec era) (NonEmpty (ProposalProcedure era))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse GovAction era -> ImpM (LedgerSpec era) (ProposalProcedure era)
forall era.
ConwayEraImp era =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal NonEmpty (GovAction era)
gas
  trySubmitProposals 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
  deposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
  anchor <- arbitrary
  pure
    ProposalProcedure
      { pProcDeposit = deposit
      , pProcReturnAddr = rewardAccount
      , pProcGovAction = ga
      , pProcAnchor = anchor
      }

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

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

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

submitGovActions ::
  forall era.
  ( ConwayEraImp era
  , HasCallStack
  ) =>
  NE.NonEmpty (GovAction era) ->
  ImpTestM era (NE.NonEmpty GovActionId)
submitGovActions :: forall era.
(ConwayEraImp era, HasCallStack) =>
NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
submitGovActions NonEmpty (GovAction era)
gas = do
  tx <- NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
forall era.
ConwayEraImp era =>
NonEmpty (GovAction era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx TopTx era)
        (Tx TopTx era))
trySubmitGovActions NonEmpty (GovAction era)
gas ImpM
  (LedgerSpec era)
  (Either
     (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
     (Tx TopTx era))
-> (Either
      (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
      (Tx TopTx era)
    -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either
  (NonEmpty (EraRuleFailure "LEDGER" era), Tx TopTx era)
  (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a (m :: * -> *) b.
(HasCallStack, ToExpr a, MonadIO m) =>
Either a b -> m b
expectRightExpr
  let txId = Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx TopTx era
tx
  pure $ NE.zipWith (\Word16
idx GovAction era
_ -> TxId -> GovActionIx -> GovActionId
GovActionId TxId
txId (Word16 -> GovActionIx
GovActionIx Word16
idx)) (0 NE.:| [1 ..]) 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 =
  Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals ([(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount, Coin)]
wdrls) (StrictMaybe ScriptHash -> GovAction era)
-> ImpM (LedgerSpec era) (StrictMaybe ScriptHash)
-> ImpM (LedgerSpec era) (GovAction era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (StrictMaybe ScriptHash)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy

submitTreasuryWithdrawals ::
  ConwayEraImp era =>
  [(RewardAccount, Coin)] ->
  ImpTestM era GovActionId
submitTreasuryWithdrawals :: forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount, Coin)]
wdrls =
  [(RewardAccount, Coin)] -> ImpTestM era (GovAction era)
forall era.
ConwayEraGov era =>
[(RewardAccount, Coin)] -> ImpTestM era (GovAction era)
mkTreasuryWithdrawalsGovAction [(RewardAccount, Coin)]
wdrls ImpTestM era (GovAction era)
-> (GovAction era -> ImpM (LedgerSpec era) GovActionId)
-> ImpM (LedgerSpec era) GovActionId
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GovAction era -> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp 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
  gaId <- [(RewardAccount, Coin)] -> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals
  submitYesVote_ (DRepVoter dRep) gaId
  submitYesVoteCCs_ cms gaId
  passNEpochs 2
  pure 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 =
  StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
mkParameterChangeGovAction StrictMaybe GovActionId
parent PParamsUpdate era
ppu ImpTestM era (GovAction era)
-> (GovAction era -> ImpM (LedgerSpec era) GovActionId)
-> ImpM (LedgerSpec era) GovActionId
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GovAction era -> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp 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 =
  StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange (GovActionId -> GovPurposeId 'PParamUpdatePurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId (GovActionId -> GovPurposeId 'PParamUpdatePurpose)
-> StrictMaybe GovActionId
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe GovActionId
parent) PParamsUpdate era
ppu (StrictMaybe ScriptHash -> GovAction era)
-> ImpM (LedgerSpec era) (StrictMaybe ScriptHash)
-> ImpM (LedgerSpec era) (GovAction era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (StrictMaybe ScriptHash)
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
  minFeeValue <- (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
30, Integer
1000)
  mkParameterChangeGovAction p (def & ppuMinFeeAL .~ SJust (Coin minFeeValue))

getGovPolicy :: ConwayEraGov era => ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy =
  SimpleGetter (NewEpochState era) (StrictMaybe ScriptHash)
-> ImpTestM era (StrictMaybe ScriptHash)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe ScriptHash)
 -> ImpTestM era (StrictMaybe ScriptHash))
-> SimpleGetter (NewEpochState era) (StrictMaybe ScriptHash)
-> ImpTestM era (StrictMaybe ScriptHash)
forall a b. (a -> b) -> a -> b
$
    (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEpochStateL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
    -> EpochState era -> Const r (EpochState era))
-> (StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL ((GovState era -> Const r (GovState era))
 -> EpochState era -> Const r (EpochState era))
-> ((StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constitution era -> Const r (Constitution era))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
Lens' (GovState era) (Constitution era)
constitutionGovStateL ((Constitution era -> Const r (Constitution era))
 -> GovState era -> Const r (GovState era))
-> ((StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
    -> Constitution era -> Const r (Constitution era))
-> (StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
-> GovState era
-> Const r (GovState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptHash -> Const r (StrictMaybe ScriptHash))
-> Constitution era -> Const r (Constitution era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe ScriptHash -> f (StrictMaybe ScriptHash))
-> Constitution era -> f (Constitution era)
constitutionScriptL

submitFailingGovAction ::
  forall era.
  ( ConwayEraImp era
  , HasCallStack
  ) =>
  GovAction era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingGovAction :: forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingGovAction GovAction era
ga NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailure = GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
forall era.
ConwayEraImp era =>
GovAction era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId)
trySubmitGovAction GovAction era
ga ImpM
  (LedgerSpec era)
  (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId)
-> (Either (NonEmpty (EraRuleFailure "LEDGER" era)) GovActionId
    -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) GovActionId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
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 = GovState era -> EnactState era
forall era. ConwayEraGov era => GovState era -> EnactState era
mkEnactState (GovState era -> EnactState era)
-> ImpM (LedgerSpec era) (GovState era)
-> ImpM (LedgerSpec era) (EnactState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (GovState era)
-> ImpM (LedgerSpec era) (GovState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((GovState era -> Const r (GovState era))
    -> EpochState era -> Const r (EpochState era))
-> (GovState era -> Const r (GovState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL)

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

logProposalsForest :: (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest :: forall era. (ConwayEraGov era, HasCallStack) => ImpTestM era ()
logProposalsForest = do
  proposals <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  logDoc $ proposalsShowDebug proposals True

getCommitteeMembers ::
  ConwayEraImp era =>
  ImpTestM era (Set.Set (Credential ColdCommitteeRole))
getCommitteeMembers :: forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers = do
  committee <- SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
(ConwayGovState era -> Const r (ConwayGovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((ConwayGovState era -> Const r (ConwayGovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> ConwayGovState era -> Const r (ConwayGovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
(StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  pure $ Map.keysSet $ foldMap' committeeMembers committee

getLastEnactedCommittee ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose))
getLastEnactedCommittee :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose))
getLastEnactedCommittee = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pRootsL . grCommitteeL . prRootL

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

getLastEnactedConstitution ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose))
getLastEnactedConstitution :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose))
getLastEnactedConstitution = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pRootsL . grConstitutionL . prRootL

getLastEnactedParameterChange ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose))
getLastEnactedParameterChange :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose))
getLastEnactedParameterChange = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pRootsL . grPParamUpdateL . prRootL

getLastEnactedHardForkInitiation ::
  ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose))
getLastEnactedHardForkInitiation :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose))
getLastEnactedHardForkInitiation = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pRootsL . grHardForkL . prRootL

getConstitutionProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'ConstitutionPurpose)
        (PEdges (GovPurposeId 'ConstitutionPurpose))
    )
getConstitutionProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'ConstitutionPurpose)
     (PEdges (GovPurposeId 'ConstitutionPurpose)))
getConstitutionProposals = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pGraphL . grConstitutionL . pGraphNodesL

getParameterChangeProposals ::
  ConwayEraGov era =>
  ImpTestM
    era
    ( Map.Map
        (GovPurposeId 'PParamUpdatePurpose)
        (PEdges (GovPurposeId 'PParamUpdatePurpose))
    )
getParameterChangeProposals :: forall era.
ConwayEraGov era =>
ImpTestM
  era
  (Map
     (GovPurposeId 'PParamUpdatePurpose)
     (PEdges (GovPurposeId 'PParamUpdatePurpose)))
getParameterChangeProposals = do
  ps <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  pure $ ps ^. pGraphL . grPParamUpdateL . 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 = Doc AnsiStyle -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc (Doc AnsiStyle -> ImpM (LedgerSpec era) ())
-> Doc AnsiStyle -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep [Item [Doc AnsiStyle]
Doc AnsiStyle
"Proposals Forest Diff:", Proposals era -> Proposals era -> Doc AnsiStyle
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 = GovActionId -> Proposals era -> Maybe (GovActionState era)
forall era.
GovActionId -> Proposals era -> Maybe (GovActionState era)
proposalsLookupId GovActionId
aId (Proposals era -> Maybe (GovActionState era))
-> ImpM (LedgerSpec era) (Proposals era)
-> ImpM (LedgerSpec era) (Maybe (GovActionState era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (Proposals era)
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 =
  String
-> ImpM (LedgerSpec era) (GovActionState era)
-> ImpM (LedgerSpec era) (GovActionState era)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting an action state" (ImpM (LedgerSpec era) (GovActionState era)
 -> ImpM (LedgerSpec era) (GovActionState era))
-> ImpM (LedgerSpec era) (GovActionState era)
-> ImpM (LedgerSpec era) (GovActionState era)
forall a b. (a -> b) -> a -> b
$ do
    GovActionId -> ImpTestM era (Maybe (GovActionState era))
forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
govActionId ImpTestM era (Maybe (GovActionState era))
-> (Maybe (GovActionState era)
    -> ImpM (LedgerSpec era) (GovActionState era))
-> ImpM (LedgerSpec era) (GovActionState era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (GovActionState era)
Nothing ->
        String -> ImpM (LedgerSpec era) (GovActionState era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) (GovActionState era))
-> String -> ImpM (LedgerSpec era) (GovActionState era)
forall a b. (a -> b) -> a -> b
$ String
"Could not find action state for govActionId: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GovActionId -> String
forall a. Show a => a -> String
show GovActionId
govActionId
      Just GovActionState era
govActionState -> GovActionState era -> ImpM (LedgerSpec era) (GovActionState era)
forall a. a -> ImpM (LedgerSpec era) a
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 = ImpM (LedgerSpec era) (GovActionState era)
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (GovActionState era)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (GovActionState era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ GovActionId -> ImpM (LedgerSpec era) (GovActionState era)
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 =
  String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Expecting for gov action state to be missing" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
    GovActionId -> ImpTestM era (Maybe (GovActionState era))
forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
govActionId ImpTestM era (Maybe (GovActionState era))
-> (Maybe (GovActionState era) -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just GovActionState era
_ ->
        String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Found gov action state for govActionId: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GovActionId -> String
forall a. ToExpr a => a -> String
ansiExprString GovActionId
govActionId
      Maybe (GovActionState era)
Nothing -> () -> ImpM (LedgerSpec era) ()
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Builds a RatifyEnv from the current state
getRatifyEnv :: (ConwayEraGov era, ConwayEraCertState era) => ImpTestM era (RatifyEnv era)
getRatifyEnv :: forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era)
getRatifyEnv = do
  eNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
  instantStake <- getsNES instantStakeG
  poolDistr <- getsNES nesPdL
  drepDistr <- getsNES $ nesEsL . epochStateDRepPulsingStateL . psDRepDistrG
  drepState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL
  committeeState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL
  accounts <- getsNES (nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL)
  poolPs <- getsNES $ nesEsL . epochStateStakePoolsL
  pure
    RatifyEnv
      { reStakePoolDistr = poolDistr
      , reInstantStake = instantStake
      , reDRepState = drepState
      , reDRepDistr = drepDistr
      , reCurrentEpoch = eNo - 1
      , reCommitteeState = committeeState
      , reAccounts = accounts
      , reStakePools = poolPs
      }

ccShouldNotBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential ColdCommitteeRole ->
  ImpTestM era ()
ccShouldNotBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeExpired Credential ColdCommitteeRole
coldC = do
  curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
  ccExpiryEpochNo <- getCCExpiry coldC
  curEpochNo `shouldSatisfy` (<= ccExpiryEpochNo)

ccShouldBeExpired ::
  (HasCallStack, ConwayEraGov era) =>
  Credential ColdCommitteeRole ->
  ImpTestM era ()
ccShouldBeExpired :: forall era.
(HasCallStack, ConwayEraGov era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldBeExpired Credential ColdCommitteeRole
coldC = do
  curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
  ccExpiryEpochNo <- getCCExpiry coldC
  curEpochNo `shouldSatisfy` (> 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
  committee <- SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> EpochState era -> Const r (EpochState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL ((GovState era -> Const r (GovState era))
 -> EpochState era -> Const r (EpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  case committee of
    StrictMaybe (Committee era)
SNothing -> String -> ImpM (LedgerSpec era) EpochNo
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"There is no committee"
    SJust Committee {Map (Credential ColdCommitteeRole) EpochNo
committeeMembers :: forall era.
Committee era -> Map (Credential ColdCommitteeRole) EpochNo
committeeMembers :: Map (Credential ColdCommitteeRole) EpochNo
committeeMembers} ->
      case Credential ColdCommitteeRole
-> Map (Credential ColdCommitteeRole) EpochNo -> Maybe EpochNo
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 -> String -> ImpM (LedgerSpec era) EpochNo
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) EpochNo)
-> String -> ImpM (LedgerSpec era) EpochNo
forall a b. (a -> b) -> a -> b
$ String
"Committee not found for cold credential: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Credential ColdCommitteeRole -> String
forall a. Show a => a -> String
show Credential ColdCommitteeRole
coldC
        Just EpochNo
epochNo -> EpochNo -> ImpM (LedgerSpec era) EpochNo
forall a. a -> ImpM (LedgerSpec era) a
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, ConwayEraCertState era) => Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned Credential ColdCommitteeRole
coldK = do
  committeeCreds <-
    SimpleGetter
  (NewEpochState era)
  (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era)
   (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
 -> ImpTestM
      era (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> SimpleGetter
     (NewEpochState era)
     (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> VState era -> Const r (VState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitteeState era -> Const r (CommitteeState era))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(CommitteeState era -> f (CommitteeState era))
-> VState era -> f (VState era)
vsCommitteeStateL ((CommitteeState era -> Const r (CommitteeState era))
 -> VState era -> Const r (VState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CommitteeState era -> Const r (CommitteeState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> VState era
-> Const r (VState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> Const
      r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> Const r (CommitteeState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> f (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> f (CommitteeState era)
csCommitteeCredsL
  authHk <$> Map.lookup coldK committeeCreds `shouldBe` Just Nothing

-- | Test the resignation status for a CC cold key to not be resigned
ccShouldNotBeResigned ::
  (HasCallStack, ConwayEraCertState era) => Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned Credential ColdCommitteeRole
coldK = do
  committeeCreds <-
    SimpleGetter
  (NewEpochState era)
  (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era)
   (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
 -> ImpTestM
      era (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> SimpleGetter
     (NewEpochState era)
     (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> VState era -> Const r (VState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitteeState era -> Const r (CommitteeState era))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(CommitteeState era -> f (CommitteeState era))
-> VState era -> f (VState era)
vsCommitteeStateL ((CommitteeState era -> Const r (CommitteeState era))
 -> VState era -> Const r (VState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CommitteeState era -> Const r (CommitteeState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> VState era
-> Const r (VState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> Const
      r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> Const r (CommitteeState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> f (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> f (CommitteeState era)
csCommitteeCredsL
  (Map.lookup coldK committeeCreds >>= authHk) `shouldSatisfy` isJust

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

-- | Calculates the ratio of DReps that have voted for the governance action
calculateDRepAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era, ConwayEraCertState era) =>
  GovActionId ->
  ImpTestM era Rational
calculateDRepAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraCertState era) =>
GovActionId -> ImpTestM era Rational
calculateDRepAcceptedRatio GovActionId
gaId = do
  ratEnv <- ImpTestM era (RatifyEnv era)
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era)
getRatifyEnv
  gas <- getGovActionState gaId
  pure $
    dRepAcceptedRatio @era
      ratEnv
      (gas ^. gasDRepVotesL)
      (gasAction gas)

-- | Calculates the ratio of Committee members that have voted for the governance
-- action
calculateCommitteeAcceptedRatio ::
  forall era.
  (HasCallStack, ConwayEraGov era, ConwayEraCertState era) =>
  GovActionId ->
  ImpTestM era Rational
calculateCommitteeAcceptedRatio :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraCertState era) =>
GovActionId -> ImpTestM era Rational
calculateCommitteeAcceptedRatio GovActionId
gaId = do
  eNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
  RatifyEnv {reCommitteeState} <- getRatifyEnv
  GovActionState {gasCommitteeVotes} <- getGovActionState gaId
  committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL
  let
    members = (Committee era -> Map (Credential ColdCommitteeRole) EpochNo)
-> StrictMaybe (Committee era)
-> Map (Credential ColdCommitteeRole) EpochNo
forall m a. Monoid m => (a -> m) -> StrictMaybe a -> m
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
  pure $
    committeeAcceptedRatio
      members
      gasCommitteeVotes
      reCommitteeState
      eNo

calculatePoolAcceptedRatio ::
  (ConwayEraGov era, ConwayEraCertState era) => GovActionId -> ImpTestM era Rational
calculatePoolAcceptedRatio :: forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
GovActionId -> ImpTestM era Rational
calculatePoolAcceptedRatio GovActionId
gaId = do
  ratEnv <- ImpTestM era (RatifyEnv era)
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era)
getRatifyEnv
  gas <- getGovActionState gaId
  pv <- getProtVer
  pure $ spoAcceptedRatio ratEnv gas pv

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

getRatifyEnvAndState ::
  (ConwayEraGov era, ConwayEraCertState era) => ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState :: forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState = do
  ratifyEnv <- ImpTestM era (RatifyEnv era)
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era)
getRatifyEnv
  enactState <- getEnactState
  let ratifyState =
        RatifyState
          { rsEnactState :: EnactState era
rsEnactState = EnactState era
enactState
          , rsEnacted :: Seq (GovActionState era)
rsEnacted = Seq (GovActionState era)
forall a. Monoid a => a
mempty
          , rsExpired :: Set GovActionId
rsExpired = Set GovActionId
forall a. Monoid a => a
mempty
          , rsDelayed :: Bool
rsDelayed = Bool
False
          }
  pure (ratifyEnv, 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, ConwayEraCertState era) =>
  GovActionId ->
  ImpTestM era Bool
isDRepAccepted :: forall era.
(HasCallStack, ConwayEraGov era, ConwayEraPParams era,
 ConwayEraCertState era) =>
GovActionId -> ImpTestM era Bool
isDRepAccepted GovActionId
gaId = do
  (ratifyEnv, ratifyState) <- ImpTestM era (RatifyEnv era, RatifyState era)
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era, RatifyState era)
getRatifyEnvAndState
  action <- getGovActionState gaId
  pure $ dRepAccepted ratifyEnv ratifyState action

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

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

-- | Logs the results of each check required to make the governance action pass
logRatificationChecks ::
  (ConwayEraGov era, ConwayEraPParams era, HasCallStack, ConwayEraCertState era) =>
  GovActionId ->
  ImpTestM era ()
logRatificationChecks :: forall era.
(ConwayEraGov era, ConwayEraPParams era, HasCallStack,
 ConwayEraCertState era) =>
GovActionId -> ImpTestM era ()
logRatificationChecks GovActionId
gaId = do
  mbyGas <- GovActionId -> ImpTestM era (Maybe (GovActionState era))
forall era.
ConwayEraGov era =>
GovActionId -> ImpTestM era (Maybe (GovActionState era))
lookupGovActionState GovActionId
gaId
  case mbyGas of
    Maybe (GovActionState era)
Nothing -> Text -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => Text -> ImpM t ()
logText (Text -> ImpM (LedgerSpec era) ())
-> Text -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Text
"Goveranance action not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (GovActionId -> String
forall a. Show a => a -> String
show GovActionId
gaId)
    Just gas :: GovActionState era
gas@GovActionState {Map (Credential HotCommitteeRole) Vote
gasCommitteeVotes :: forall era.
GovActionState era -> Map (Credential HotCommitteeRole) Vote
gasCommitteeVotes :: Map (Credential HotCommitteeRole) Vote
gasCommitteeVotes, Map (Credential DRepRole) Vote
gasDRepVotes :: forall era. GovActionState era -> Map (Credential DRepRole) Vote
gasDRepVotes :: Map (Credential DRepRole) Vote
gasDRepVotes} -> do
      let govAction :: GovAction era
govAction = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      ens@EnactState {..} <- ImpTestM era (EnactState era)
forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
      committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL
      ratEnv@RatifyEnv {reCurrentEpoch} <- getRatifyEnv
      let ratSt = EnactState era
-> Seq (GovActionState era)
-> Set GovActionId
-> Bool
-> RatifyState era
forall era.
EnactState era
-> Seq (GovActionState era)
-> Set GovActionId
-> Bool
-> RatifyState era
RatifyState EnactState era
ens Seq (GovActionState era)
forall a. Monoid a => a
mempty Set GovActionId
forall a. Monoid a => a
mempty Bool
False
      curTreasury <- getsNES treasuryL
      currentEpoch <- getsNES nesELL
      pv <- getProtVer
      let
        members = (Committee era -> Map (Credential ColdCommitteeRole) EpochNo)
-> StrictMaybe (Committee era)
-> Map (Credential ColdCommitteeRole) EpochNo
forall m a. Monoid m => (a -> m) -> StrictMaybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Committee era -> Map (Credential ColdCommitteeRole) EpochNo
forall era.
Committee era -> Map (Credential ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
        committeeState = RatifyEnv era -> CommitteeState era
forall era. RatifyEnv era -> CommitteeState era
reCommitteeState RatifyEnv era
ratEnv
      curPParams <- getsNES $ nesEsL . epochStateGovStateL . curPParamsGovStateL
      logDoc $
        tableDoc
          (Just "RATIFICATION CHECKS")
          [ ("prevActionAsExpected:", viaShow $ prevActionAsExpected gas ensPrevGovActionIds)
          , ("validCommitteeTerm:", viaShow $ validCommitteeTerm govAction curPParams currentEpoch)
          , ("notDelayed:", "??")
          , ("withdrawalCanWithdraw:", viaShow $ withdrawalCanWithdraw govAction curTreasury)
          ,
            ( "committeeAccepted:"
            , hsep
                [ viaShow $ committeeAccepted ratEnv ratSt gas
                , "["
                , "To Pass:"
                , viaShow $ committeeAcceptedRatio members gasCommitteeVotes committeeState currentEpoch
                , ">="
                , viaShow $ votingCommitteeThreshold reCurrentEpoch ratSt committeeState (gasAction gas)
                , "]"
                ]
            )
          ,
            ( "spoAccepted:"
            , hsep
                [ viaShow $ spoAccepted ratEnv ratSt gas
                , "["
                , "To Pass:"
                , viaShow $ spoAcceptedRatio ratEnv gas pv
                , ">="
                , viaShow $ votingStakePoolThreshold ratSt (gasAction gas)
                , "]"
                ]
            )
          ,
            ( "dRepAccepted:"
            , hsep
                [ viaShow $ dRepAccepted ratEnv ratSt gas
                , "["
                , "To Pass:"
                , viaShow $ dRepAcceptedRatio ratEnv gasDRepVotes (gasAction gas)
                , ">="
                , viaShow $ votingDRepThreshold ratSt (gasAction gas)
                , "]"
                ]
            )
          ]

-- | 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 = String
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Register committee hot key" (ImpM (LedgerSpec era) (Credential HotCommitteeRole)
 -> ImpM (LedgerSpec era) (Credential HotCommitteeRole))
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
forall a b. (a -> b) -> a -> b
$ do
  hotKey NE.:| [] <- ImpM (LedgerSpec era) (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerCommitteeHotKeys (KeyHash HotCommitteeRole -> Credential HotCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash HotCommitteeRole -> Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash) (NonEmpty (Credential ColdCommitteeRole)
 -> ImpTestM era (NonEmpty (Credential HotCommitteeRole)))
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall a b. (a -> b) -> a -> b
$ Credential ColdCommitteeRole
-> NonEmpty (Credential ColdCommitteeRole)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential ColdCommitteeRole
coldKey
  pure 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
  keys <- NonEmpty (Credential ColdCommitteeRole)
-> (Credential ColdCommitteeRole
    -> ImpM
         (LedgerSpec era)
         (Credential ColdCommitteeRole, Credential HotCommitteeRole))
-> ImpM
     (LedgerSpec era)
     (NonEmpty
        (Credential ColdCommitteeRole, Credential HotCommitteeRole))
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 (Credential HotCommitteeRole
 -> (Credential ColdCommitteeRole, Credential HotCommitteeRole))
-> ImpTestM era (Credential HotCommitteeRole)
-> ImpM
     (LedgerSpec era)
     (Credential ColdCommitteeRole, Credential HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpTestM era (Credential HotCommitteeRole)
genHotCred)
  submitTxAnn_ "Registering Committee Hot keys" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.fromList (map (uncurry AuthCommitteeHotKeyTxCert) (toList keys))
  pure $ fmap snd 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, ConwayEraCertState era) =>
  Credential ColdCommitteeRole ->
  StrictMaybe Anchor ->
  ImpTestM era (Maybe (Credential HotCommitteeRole))
resignCommitteeColdKey :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ConwayEraCertState era) =>
Credential ColdCommitteeRole
-> StrictMaybe Anchor
-> ImpTestM era (Maybe (Credential HotCommitteeRole))
resignCommitteeColdKey Credential ColdCommitteeRole
coldKey StrictMaybe Anchor
anchor = do
  committeAuthorizations <-
    SimpleGetter
  (NewEpochState era)
  (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era)
   (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
 -> ImpTestM
      era (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> SimpleGetter
     (NewEpochState era)
     (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
-> ImpTestM
     era (Map (Credential ColdCommitteeRole) CommitteeAuthorization)
forall a b. (a -> b) -> a -> b
$
      (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL
        ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL
        ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
        ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL
        ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> VState era -> Const r (VState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitteeState era -> Const r (CommitteeState era))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(CommitteeState era -> f (CommitteeState era))
-> VState era -> f (VState era)
vsCommitteeStateL
        ((CommitteeState era -> Const r (CommitteeState era))
 -> VState era -> Const r (VState era))
-> ((Map (Credential ColdCommitteeRole) CommitteeAuthorization
     -> Const
          r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
    -> CommitteeState era -> Const r (CommitteeState era))
-> (Map (Credential ColdCommitteeRole) CommitteeAuthorization
    -> Const
         r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> VState era
-> Const r (VState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> Const
      r (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> Const r (CommitteeState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> f (Map (Credential ColdCommitteeRole) CommitteeAuthorization))
-> CommitteeState era -> f (CommitteeState era)
csCommitteeCredsL
  submitTxAnn_ "Resigning Committee Cold key" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton (ResignCommitteeColdTxCert coldKey anchor)
  pure $ do
    CommitteeHotCredential hotCred <- Map.lookup coldKey committeAuthorizations
    pure hotCred

submitCommitteeElection ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  StrictMaybe (GovPurposeId 'CommitteePurpose) ->
  Credential DRepRole ->
  Set.Set (Credential ColdCommitteeRole) ->
  Map.Map (Credential ColdCommitteeRole) EpochNo ->
  ImpTestM era (GovPurposeId 'CommitteePurpose)
submitCommitteeElection :: forall era.
(HasCallStack, ConwayEraImp era) =>
StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Credential DRepRole
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose)
submitCommitteeElection StrictMaybe (GovPurposeId 'CommitteePurpose)
prevGovId Credential DRepRole
drep Set (Credential ColdCommitteeRole)
toRemove Map (Credential ColdCommitteeRole) EpochNo
toAdd = String
-> ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose)
-> ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose)
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Electing committee" (ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose)
 -> ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose))
-> ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose)
-> ImpM (LedgerSpec era) (GovPurposeId 'CommitteePurpose)
forall a b. (a -> b) -> a -> b
$ do
  let
    committeeAction :: GovAction era
committeeAction =
      StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
        StrictMaybe (GovPurposeId 'CommitteePurpose)
prevGovId
        Set (Credential ColdCommitteeRole)
toRemove
        Map (Credential ColdCommitteeRole) EpochNo
toAdd
        (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
  gaidCommitteeProp <- GovAction era -> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
committeeAction
  submitYesVote_ (DRepVoter drep) gaidCommitteeProp
  pure (GovPurposeId gaidCommitteeProp)

electBasicCommittee ::
  forall era.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  ImpTestM
    era
    ( Credential DRepRole
    , Credential HotCommitteeRole
    , GovPurposeId 'CommitteePurpose
    )
electBasicCommittee :: forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee = do
  (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
  logString $ "Registered DRep: " <> showExpr drep

  (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
  logString $ "Registered SPO: " <> showExpr spoC

  impAnn "Registering committee member" $ do
    coldCommitteeC <- KeyHashObj <$> freshKeyHash
    startEpochNo <- getsNES nesELL
    let
      committeeAction =
        StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
          StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. StrictMaybe a
SNothing
          Set (Credential ColdCommitteeRole)
forall a. Monoid a => a
mempty
          (Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
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 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
    (gaidCommitteeProp NE.:| _) <-
      impAnn "Submitting UpdateCommittee action" $
        submitGovActions
          [ committeeAction
          , UpdateCommittee SNothing mempty mempty (1 %! 10)
          ]
    submitYesVote_ (DRepVoter drep) gaidCommitteeProp
    submitYesVote_ (StakePoolVoter spoC) gaidCommitteeProp
    passNEpochs 2
    committeeMembers <- getCommitteeMembers
    impAnn "The committee should be enacted" $
      committeeMembers `shouldSatisfy` Set.member coldCommitteeC
    hotCommitteeC <- registerCommitteeHotKey coldCommitteeC
    pure (drep, hotCommitteeC, GovPurposeId 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
  pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  logDoc $
    vsep
      [ ""
      , "----- Current PParams -----"
      , ansiExpr pp
      , "---------------------------"
      , ""
      ]

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

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

enactConstitution ::
  forall era.
  ( ConwayEraImp era
  , HasCallStack
  ) =>
  StrictMaybe (GovPurposeId 'ConstitutionPurpose) ->
  Constitution era ->
  Credential DRepRole ->
  NonEmpty (Credential HotCommitteeRole) ->
  ImpTestM era GovActionId
enactConstitution :: forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential DRepRole
-> NonEmpty (Credential HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
prevGovId Constitution era
constitution Credential DRepRole
dRep NonEmpty (Credential HotCommitteeRole)
committeeMembers = String
-> ImpM (LedgerSpec era) GovActionId
-> ImpM (LedgerSpec era) GovActionId
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Enacting constitution" (ImpM (LedgerSpec era) GovActionId
 -> ImpM (LedgerSpec era) GovActionId)
-> ImpM (LedgerSpec era) GovActionId
-> ImpM (LedgerSpec era) GovActionId
forall a b. (a -> b) -> a -> b
$ do
  let action :: GovAction era
action = StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era -> GovAction era
NewConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
prevGovId Constitution era
constitution
  govId <- GovAction era -> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
  submitYesVote_ (DRepVoter dRep) govId
  submitYesVoteCCs_ committeeMembers govId
  logRatificationChecks govId
  passNEpochs 2
  enactedConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
  enactedConstitution `shouldBe` constitution
  pure govId

expectNumDormantEpochs :: (HasCallStack, ConwayEraCertState era) => EpochNo -> ImpTestM era ()
expectNumDormantEpochs :: forall era.
(HasCallStack, ConwayEraCertState era) =>
EpochNo -> ImpTestM era ()
expectNumDormantEpochs EpochNo
expected = do
  nd <-
    SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo)
-> SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall a b. (a -> b) -> a -> b
$
      (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((EpochNo -> Const r EpochNo)
    -> EpochState era -> Const r (EpochState era))
-> (EpochNo -> Const r EpochNo)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((EpochNo -> Const r EpochNo)
    -> LedgerState era -> Const r (LedgerState era))
-> (EpochNo -> Const r EpochNo)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((EpochNo -> Const r EpochNo)
    -> CertState era -> Const r (CertState era))
-> (EpochNo -> Const r EpochNo)
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((EpochNo -> Const r EpochNo)
    -> VState era -> Const r (VState era))
-> (EpochNo -> Const r EpochNo)
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpochNo -> Const r EpochNo) -> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL
  nd `shouldBeExpr` expected

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

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

expectDRepNotRegistered ::
  (HasCallStack, ConwayEraCertState era) =>
  Credential DRepRole ->
  ImpTestM era ()
expectDRepNotRegistered :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> ImpTestM era ()
expectDRepNotRegistered Credential DRepRole
drep = do
  dsMap <- SimpleGetter
  (NewEpochState era) (Map (Credential DRepRole) DRepState)
-> ImpTestM era (Map (Credential DRepRole) DRepState)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> VState era -> Const r (VState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential DRepRole) DRepState
 -> Const r (Map (Credential DRepRole) DRepState))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential DRepRole) DRepState
 -> f (Map (Credential DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL)
  Map.lookup drep dsMap `shouldBe` Nothing

isDRepExpired ::
  (HasCallStack, ConwayEraCertState era) =>
  Credential DRepRole ->
  ImpTestM era Bool
isDRepExpired :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> ImpTestM era Bool
isDRepExpired Credential DRepRole
drep = do
  vState <- SimpleGetter (NewEpochState era) (VState era)
-> ImpTestM era (VState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (VState era)
 -> ImpTestM era (VState era))
-> SimpleGetter (NewEpochState era) (VState era)
-> ImpTestM era (VState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((VState era -> Const r (VState era))
    -> EpochState era -> Const r (EpochState era))
-> (VState era -> Const r (VState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((VState era -> Const r (VState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (VState era -> Const r (VState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((VState era -> Const r (VState era))
    -> CertState era -> Const r (CertState era))
-> (VState era -> Const r (VState era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL
  currentEpoch <- getsNES nesELL
  case Map.lookup drep $ vState ^. vsDRepsL of
    Maybe DRepState
Nothing -> String -> ImpM (LedgerSpec era) Bool
forall a. HasCallStack => String -> a
error (String -> ImpM (LedgerSpec era) Bool)
-> String -> ImpM (LedgerSpec era) Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
Item [String]
"DRep not found", Credential DRepRole -> String
forall a. Show a => a -> String
show Credential DRepRole
drep]
    Just DRepState
drep' ->
      Bool -> ImpM (LedgerSpec era) Bool
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ImpM (LedgerSpec era) Bool)
-> Bool -> ImpM (LedgerSpec era) Bool
forall a b. (a -> b) -> a -> b
$
        (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) (VState era
vState VState era -> Getting EpochNo (VState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (VState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL) (DRepState
drep' DRepState -> Getting EpochNo DRepState EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo DRepState EpochNo
Lens' DRepState EpochNo
drepExpiryL)
          EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
< EpochNo
currentEpoch

expectDRepExpiry ::
  (HasCallStack, ConwayEraCertState era) =>
  Credential DRepRole ->
  EpochNo ->
  ImpTestM era ()
expectDRepExpiry :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> EpochNo -> ImpTestM era ()
expectDRepExpiry Credential DRepRole
drep EpochNo
expected = do
  dsMap <- SimpleGetter
  (NewEpochState era) (Map (Credential DRepRole) DRepState)
-> ImpTestM era (Map (Credential DRepRole) DRepState)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era) (Map (Credential DRepRole) DRepState)
 -> ImpTestM era (Map (Credential DRepRole) DRepState))
-> SimpleGetter
     (NewEpochState era) (Map (Credential DRepRole) DRepState)
-> ImpTestM era (Map (Credential DRepRole) DRepState)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> EpochState era -> Const r (EpochState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> CertState era -> Const r (CertState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const r (VState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (Credential DRepRole) DRepState
     -> Const r (Map (Credential DRepRole) DRepState))
    -> VState era -> Const r (VState era))
-> (Map (Credential DRepRole) DRepState
    -> Const r (Map (Credential DRepRole) DRepState))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential DRepRole) DRepState
 -> Const r (Map (Credential DRepRole) DRepState))
-> VState era -> Const r (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential DRepRole) DRepState
 -> f (Map (Credential DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
  let ds = Maybe DRepState -> DRepState
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DRepState -> DRepState) -> Maybe DRepState -> DRepState
forall a b. (a -> b) -> a -> b
$ Credential DRepRole
-> Map (Credential DRepRole) DRepState -> Maybe DRepState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential DRepRole
drep Map (Credential DRepRole) DRepState
dsMap
  drepExpiry ds `shouldBe` expected

expectActualDRepExpiry ::
  (HasCallStack, ConwayEraCertState era) =>
  Credential DRepRole ->
  EpochNo ->
  ImpTestM era ()
expectActualDRepExpiry :: forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential DRepRole -> EpochNo -> ImpTestM era ()
expectActualDRepExpiry Credential DRepRole
drep EpochNo
expected = do
  vState <- SimpleGetter (NewEpochState era) (VState era)
-> ImpTestM era (VState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (VState era)
 -> ImpTestM era (VState era))
-> SimpleGetter (NewEpochState era) (VState era)
-> ImpTestM era (VState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((VState era -> Const r (VState era))
    -> EpochState era -> Const r (EpochState era))
-> (VState era -> Const r (VState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((VState era -> Const r (VState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (VState era -> Const r (VState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((VState era -> Const r (VState era))
    -> CertState era -> Const r (CertState era))
-> (VState era -> Const r (VState era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const r (VState era))
-> CertState era -> Const r (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL
  let actualDRepExpiry = Maybe EpochNo -> EpochNo
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe EpochNo -> EpochNo) -> Maybe EpochNo -> EpochNo
forall a b. (a -> b) -> a -> b
$ Credential DRepRole -> VState era -> Maybe EpochNo
forall era. Credential DRepRole -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential DRepRole
drep VState era
vState
  actualDRepExpiry `shouldBe` expected

currentProposalsShouldContain ::
  ( HasCallStack
  , ConwayEraGov era
  ) =>
  GovActionId ->
  ImpTestM era ()
currentProposalsShouldContain :: forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era ()
currentProposalsShouldContain GovActionId
gai =
  ImpTestM era (StrictSeq GovActionId)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds ImpTestM era (StrictSeq GovActionId)
-> (StrictSeq GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([GovActionId] -> [GovActionId] -> ImpM (LedgerSpec era) ())
-> [GovActionId] -> [GovActionId] -> ImpM (LedgerSpec era) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [GovActionId] -> [GovActionId] -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
[a] -> [a] -> m ()
shouldContain [Item [GovActionId]
GovActionId
gai] ([GovActionId] -> ImpM (LedgerSpec era) ())
-> (StrictSeq GovActionId -> [GovActionId])
-> StrictSeq GovActionId
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq GovActionId -> [GovActionId]
forall a. StrictSeq a -> [a]
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
  props <- ImpTestM era (StrictSeq GovActionId)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds
  assertBool "Expected proposals in current gov state" (not (SSeq.null props))

expectNoCurrentProposals :: (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals :: forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals = do
  proposals <- ImpTestM era (Proposals era)
forall era. ConwayEraGov era => ImpTestM era (Proposals era)
getProposals
  case proposalsActions proposals of
    StrictSeq (GovActionState era)
Empty -> () -> ImpM (LedgerSpec era) ()
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    StrictSeq (GovActionState era)
xs -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Expected no active proposals, but got:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Expr -> String
forall a. Show a => a -> String
show (StrictSeq (GovActionState era) -> Expr
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
  props <- ImpTestM era (StrictSeq GovActionId)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
lastEpochProposals
  assertBool "Expected proposals in the pulser" (not (SSeq.null props))

expectNoPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals :: forall era. (HasCallStack, ConwayEraGov era) => ImpTestM era ()
expectNoPulserProposals = do
  props <- ImpTestM era (StrictSeq GovActionId)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
lastEpochProposals
  assertBool "Expected no proposals in the pulser" (SSeq.null props)

currentProposalIds ::
  ConwayEraGov era => ImpTestM era (SSeq.StrictSeq GovActionId)
currentProposalIds :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictSeq GovActionId)
currentProposalIds = Proposals era -> StrictSeq GovActionId
forall era. Proposals era -> StrictSeq GovActionId
proposalsIds (Proposals era -> StrictSeq GovActionId)
-> ImpM (LedgerSpec era) (Proposals era)
-> ImpM (LedgerSpec era) (StrictSeq GovActionId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (Proposals era)
-> ImpM (LedgerSpec era) (Proposals era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Const r (GovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Proposals era -> Const r (Proposals era))
    -> GovState era -> Const r (GovState era))
-> (Proposals era -> Const r (Proposals era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proposals era -> Const r (Proposals era))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals 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 =
  (GovActionState era -> GovActionId)
-> StrictSeq (GovActionState era) -> StrictSeq GovActionId
forall a b. (a -> b) -> StrictSeq a -> StrictSeq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. GovActionState era -> GovActionId
gasId @era) (StrictSeq (GovActionState era) -> StrictSeq GovActionId)
-> (PulsingSnapshot era -> StrictSeq (GovActionState era))
-> PulsingSnapshot era
-> StrictSeq GovActionId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingSnapshot era -> StrictSeq (GovActionState era)
forall era. PulsingSnapshot era -> StrictSeq (GovActionState era)
psProposals
    (PulsingSnapshot era -> StrictSeq GovActionId)
-> ImpM (LedgerSpec era) (PulsingSnapshot era)
-> ImpM (LedgerSpec era) (StrictSeq GovActionId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (PulsingSnapshot era)
-> ImpM (LedgerSpec era) (PulsingSnapshot era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES
      ( (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL
          ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PulsingSnapshot era -> Const r (PulsingSnapshot era))
    -> EpochState era -> Const r (EpochState era))
-> (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL
          ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((PulsingSnapshot era -> Const r (PulsingSnapshot era))
    -> LedgerState era -> Const r (LedgerState era))
-> (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const r (UTxOState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL
          ((UTxOState era -> Const r (UTxOState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((PulsingSnapshot era -> Const r (PulsingSnapshot era))
    -> UTxOState era -> Const r (UTxOState era))
-> (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL
          ((GovState era -> Const r (GovState era))
 -> UTxOState era -> Const r (UTxOState era))
-> ((PulsingSnapshot era -> Const r (PulsingSnapshot era))
    -> GovState era -> Const r (GovState era))
-> (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> UTxOState era
-> Const r (UTxOState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL
          ((DRepPulsingState era -> Const r (DRepPulsingState era))
 -> GovState era -> Const r (GovState era))
-> ((PulsingSnapshot era -> Const r (PulsingSnapshot era))
    -> DRepPulsingState era -> Const r (DRepPulsingState era))
-> (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> GovState era
-> Const r (GovState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PulsingSnapshot era -> Const r (PulsingSnapshot era))
-> DRepPulsingState era -> Const r (DRepPulsingState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
Lens' (DRepPulsingState era) (PulsingSnapshot era)
Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL
      )

pulsingStateSnapshotL ::
  (EraStake era, ConwayEraAccounts era) =>
  Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL :: forall era.
(EraStake era, ConwayEraAccounts era) =>
Lens' (DRepPulsingState era) (PulsingSnapshot era)
pulsingStateSnapshotL = (DRepPulsingState era -> PulsingSnapshot era)
-> (DRepPulsingState era
    -> PulsingSnapshot era -> DRepPulsingState era)
-> Lens
     (DRepPulsingState era)
     (DRepPulsingState era)
     (PulsingSnapshot era)
     (PulsingSnapshot era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DRepPulsingState era -> PulsingSnapshot era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> PulsingSnapshot era
getter DRepPulsingState era -> PulsingSnapshot era -> DRepPulsingState era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraStake era, ConwayEraAccounts 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 = (PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era
forall a b. (a, b) -> a
fst (DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts 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 = PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap RatifyState era
y
    setter DRepPulsingState era
state PulsingSnapshot era
snap = PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snap (RatifyState era -> DRepPulsingState era)
-> RatifyState era -> DRepPulsingState era
forall a b. (a -> b) -> a -> b
$ (PulsingSnapshot era, RatifyState era) -> RatifyState era
forall a b. (a, b) -> b
snd ((PulsingSnapshot era, RatifyState era) -> RatifyState era)
-> (PulsingSnapshot era, RatifyState era) -> RatifyState era
forall a b. (a -> b) -> a -> b
$ DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
state

whenBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap :: forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap = forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersion @9

whenPostBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap :: forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap = forall (v :: Natural) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @10

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
  pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  if hardforkConwayBootstrapPhase pv then inBootstrap else 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 =
  (Credential HotCommitteeRole -> ImpM (LedgerSpec era) ())
-> f (Credential HotCommitteeRole) -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Credential HotCommitteeRole
c -> Voter -> GovActionId -> ImpM (LedgerSpec era) ()
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)) ->
  -- | 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))
-> Set (Credential ColdCommitteeRole)
-> [(Credential ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
mParent Set (Credential ColdCommitteeRole)
ccsToRemove [(Credential ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold = do
  nes <- SimpleGetter (NewEpochState era) (NewEpochState era)
-> ImpTestM era (NewEpochState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (NewEpochState era -> Const r (NewEpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall a. a -> a
SimpleGetter (NewEpochState era) (NewEpochState era)
id
  let
    curEpochNo = NewEpochState era
nes NewEpochState era
-> Getting EpochNo (NewEpochState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
    rootCommittee = NewEpochState era
nes NewEpochState era
-> Getting
     (PRoot (GovPurposeId 'CommitteePurpose))
     (NewEpochState era)
     (PRoot (GovPurposeId 'CommitteePurpose))
-> PRoot (GovPurposeId 'CommitteePurpose)
forall s a. s -> Getting a s a -> a
^. (GovState era
 -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era))
-> NewEpochState era
-> Const
     (PRoot (GovPurposeId 'CommitteePurpose)) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era
  -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era))
 -> NewEpochState era
 -> Const
      (PRoot (GovPurposeId 'CommitteePurpose)) (NewEpochState era))
-> ((PRoot (GovPurposeId 'CommitteePurpose)
     -> Const
          (PRoot (GovPurposeId 'CommitteePurpose))
          (PRoot (GovPurposeId 'CommitteePurpose)))
    -> GovState era
    -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era))
-> Getting
     (PRoot (GovPurposeId 'CommitteePurpose))
     (NewEpochState era)
     (PRoot (GovPurposeId 'CommitteePurpose))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proposals era
 -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era))
-> GovState era
-> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL ((Proposals era
  -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era))
 -> GovState era
 -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era))
-> ((PRoot (GovPurposeId 'CommitteePurpose)
     -> Const
          (PRoot (GovPurposeId 'CommitteePurpose))
          (PRoot (GovPurposeId 'CommitteePurpose)))
    -> Proposals era
    -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era))
-> (PRoot (GovPurposeId 'CommitteePurpose)
    -> Const
         (PRoot (GovPurposeId 'CommitteePurpose))
         (PRoot (GovPurposeId 'CommitteePurpose)))
-> GovState era
-> Const (PRoot (GovPurposeId 'CommitteePurpose)) (GovState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovRelation PRoot
 -> Const
      (PRoot (GovPurposeId 'CommitteePurpose)) (GovRelation PRoot))
-> Proposals era
-> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era)
forall era (f :: * -> *).
Functor f =>
(GovRelation PRoot -> f (GovRelation PRoot))
-> Proposals era -> f (Proposals era)
pRootsL ((GovRelation PRoot
  -> Const
       (PRoot (GovPurposeId 'CommitteePurpose)) (GovRelation PRoot))
 -> Proposals era
 -> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era))
-> ((PRoot (GovPurposeId 'CommitteePurpose)
     -> Const
          (PRoot (GovPurposeId 'CommitteePurpose))
          (PRoot (GovPurposeId 'CommitteePurpose)))
    -> GovRelation PRoot
    -> Const
         (PRoot (GovPurposeId 'CommitteePurpose)) (GovRelation PRoot))
-> (PRoot (GovPurposeId 'CommitteePurpose)
    -> Const
         (PRoot (GovPurposeId 'CommitteePurpose))
         (PRoot (GovPurposeId 'CommitteePurpose)))
-> Proposals era
-> Const (PRoot (GovPurposeId 'CommitteePurpose)) (Proposals era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PRoot (GovPurposeId 'CommitteePurpose)
 -> Const
      (PRoot (GovPurposeId 'CommitteePurpose))
      (PRoot (GovPurposeId 'CommitteePurpose)))
-> GovRelation PRoot
-> Const
     (PRoot (GovPurposeId 'CommitteePurpose)) (GovRelation PRoot)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(f1 (GovPurposeId 'CommitteePurpose)
 -> f2 (f1 (GovPurposeId 'CommitteePurpose)))
-> GovRelation f1 -> f2 (GovRelation f1)
grCommitteeL
    parent = StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. a -> Maybe a -> a
fromMaybe (PRoot (GovPurposeId 'CommitteePurpose)
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. PRoot a -> StrictMaybe a
prRoot PRoot (GovPurposeId 'CommitteePurpose)
rootCommittee) Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
mParent
    newCommitteMembers =
      [(Credential ColdCommitteeRole, EpochNo)]
-> Map (Credential ColdCommitteeRole) EpochNo
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]
  mkProposal $ UpdateCommittee parent ccsToRemove newCommitteMembers threshold

submitUpdateCommittee ::
  ConwayEraImp era =>
  -- | Set the parent. When Nothing is supplied latest parent will be used.
  Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose)) ->
  -- | 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))
-> Set (Credential ColdCommitteeRole)
-> [(Credential ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
submitUpdateCommittee Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
mParent Set (Credential ColdCommitteeRole)
ccsToRemove [(Credential ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold =
  Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
-> Set (Credential ColdCommitteeRole)
-> [(Credential ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
-> Set (Credential ColdCommitteeRole)
-> [(Credential ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose))
mParent Set (Credential ColdCommitteeRole)
ccsToRemove [(Credential ColdCommitteeRole, EpochInterval)]
ccsToAdd UnitInterval
threshold ImpTestM era (ProposalProcedure era)
-> (ProposalProcedure era -> ImpM (LedgerSpec era) GovActionId)
-> ImpM (LedgerSpec era) GovActionId
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProposalProcedure era -> ImpM (LedgerSpec era) GovActionId
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 <- SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Const r (GovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  assertBool ("Expected Committee Member: " ++ show cc ++ " to be present in the committee") $
    Map.member cc (committee ^. 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 <- SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Const r (GovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  assertBool ("Expected Committee Member: " ++ show cc ++ " to be absent from the committee") $
    Map.notMember cc (committee ^. committeeMembersL)

donateToTreasury :: ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury :: forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury Coin
amount =
  String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (String
"Donation to treasury in the amount of: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Coin -> String
forall a. Show a => a -> String
show Coin
amount) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
    treasuryStart <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (Coin -> Const r Coin)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) Coin
Lens' (NewEpochState era) Coin
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) Coin
treasuryL
    submitTx_ $ mkBasicTx (mkBasicTxBody & treasuryDonationTxBodyL .~ amount)
    treasuryEndEpoch0 <- getsNES treasuryL
    -- Actual donation happens on the epoch boundary
    treasuryStart `shouldBe` treasuryEndEpoch0
    passEpoch
    treasuryEndEpoch1 <- getsNES treasuryL
    treasuryEndEpoch1 <-> treasuryStart `shouldBe` 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
  committee <- SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Const r (GovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
  let members = Map (Credential ColdCommitteeRole) EpochNo
-> Set (Credential ColdCommitteeRole)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential ColdCommitteeRole) EpochNo
 -> Set (Credential ColdCommitteeRole))
-> Map (Credential ColdCommitteeRole) EpochNo
-> Set (Credential ColdCommitteeRole)
forall a b. (a -> b) -> a -> b
$ (Committee era -> Map (Credential ColdCommitteeRole) EpochNo)
-> StrictMaybe (Committee era)
-> Map (Credential ColdCommitteeRole) EpochNo
forall m a. Monoid m => (a -> m) -> StrictMaybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Committee era -> Map (Credential ColdCommitteeRole) EpochNo
forall era.
Committee era -> Map (Credential ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee
  impAnn "Expecting committee members" $ members `shouldBe` expKhs

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

logConwayTxBalance ::
  ( EraUTxO era
  , EraGov era
  , ConwayEraTxBody era
  , ConwayEraCertState era
  ) =>
  Tx TopTx era ->
  ImpTestM era ()
logConwayTxBalance :: forall era.
(EraUTxO era, EraGov era, ConwayEraTxBody era,
 ConwayEraCertState era) =>
Tx TopTx era -> ImpTestM era ()
logConwayTxBalance Tx TopTx era
tx = do
  pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
  utxo <- getsNES utxoL
  logString $ showConwayTxBalance pp certState utxo 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 =
  ImpTestM era ()
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era ())
-> SubmitFailureExpectation era
-> ImpTestM era ()
forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
    (Vote -> Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era ()
submitVote_ Vote
vote Voter
voter GovActionId
gaId)
    (Voter
-> GovActionId
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
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 =
  ImpTestM era (Maybe GovActionId)
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe GovActionId)
forall era a.
EraGov era =>
ImpTestM era a
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpTestM era a)
-> SubmitFailureExpectation era
-> ImpTestM era a
submitBootstrapAware
    (GovActionId -> Maybe GovActionId
forall a. a -> Maybe a
Just (GovActionId -> Maybe GovActionId)
-> ImpM (LedgerSpec era) GovActionId
-> ImpTestM era (Maybe GovActionId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProposalProcedure era -> ImpM (LedgerSpec era) GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era GovActionId
submitProposal ProposalProcedure era
proposal)
    ((Maybe GovActionId
forall a. Maybe a
Nothing Maybe GovActionId
-> ImpM (LedgerSpec era) () -> ImpTestM era (Maybe GovActionId)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (ImpM (LedgerSpec era) () -> ImpTestM era (Maybe GovActionId))
-> (NonEmpty (EraRuleFailure "LEDGER" era)
    -> ImpM (LedgerSpec era) ())
-> NonEmpty (EraRuleFailure "LEDGER" era)
-> ImpTestM era (Maybe GovActionId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProposalProcedure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
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 = ImpM (LedgerSpec era) (Maybe GovActionId)
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (Maybe GovActionId)
 -> ImpM (LedgerSpec era) ())
-> (SubmitFailureExpectation era
    -> ImpM (LedgerSpec era) (Maybe GovActionId))
-> SubmitFailureExpectation era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpM (LedgerSpec era) (Maybe GovActionId)
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 ->
      ImpTestM era a -> ImpTestM era a -> ImpTestM era a
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 ->
      ImpTestM era a -> ImpTestM era a -> ImpTestM era a
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) ->
      ImpTestM era a -> ImpTestM era a -> ImpTestM era a
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
  sps <- ImpTestM era (RatifyEnv era)
forall era.
(ConwayEraGov era, ConwayEraCertState era) =>
ImpTestM era (RatifyEnv era)
getRatifyEnv ImpTestM era (RatifyEnv era)
-> (RatifyEnv era -> ImpM (LedgerSpec era) StakePoolState)
-> ImpM (LedgerSpec era) StakePoolState
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe StakePoolState -> ImpM (LedgerSpec era) StakePoolState
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Maybe StakePoolState -> ImpM (LedgerSpec era) StakePoolState)
-> (RatifyEnv era -> Maybe StakePoolState)
-> RatifyEnv era
-> ImpM (LedgerSpec era) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
kh (Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState)
-> (RatifyEnv era -> Map (KeyHash StakePool) StakePoolState)
-> RatifyEnv era
-> Maybe StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatifyEnv era -> Map (KeyHash StakePool) StakePoolState
forall era. RatifyEnv era -> Map (KeyHash StakePool) StakePoolState
reStakePools
  void $
    delegateToDRep
      (raCredential $ spsRewardAccount sps)
      stake
      drep

-- Partial implementation used for checking predicate failures
instance InjectRuleFailure "LEDGER" ShelleyDelegPredFailure ConwayEra where
  injectFailure :: ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "LEDGER" ConwayEra
injectFailure = PredicateFailure (EraRule "CERTS" ConwayEra)
-> ConwayLedgerPredFailure ConwayEra
ConwayCertsPredFailure ConwayEra
-> ConwayLedgerPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "CERTS" era)
-> ConwayLedgerPredFailure era
ConwayCertsFailure (ConwayCertsPredFailure ConwayEra
 -> ConwayLedgerPredFailure ConwayEra)
-> (ShelleyDelegPredFailure ConwayEra
    -> ConwayCertsPredFailure ConwayEra)
-> ShelleyDelegPredFailure ConwayEra
-> ConwayLedgerPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "CERTS" ConwayEra
ShelleyDelegPredFailure ConwayEra
-> ConwayCertsPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ShelleyDelegPredFailure ConwayEra where
  injectFailure :: ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "CERTS" ConwayEra
injectFailure = PredicateFailure (EraRule "CERT" ConwayEra)
-> ConwayCertsPredFailure ConwayEra
ConwayCertPredFailure ConwayEra -> ConwayCertsPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure (ConwayCertPredFailure ConwayEra
 -> ConwayCertsPredFailure ConwayEra)
-> (ShelleyDelegPredFailure ConwayEra
    -> ConwayCertPredFailure ConwayEra)
-> ShelleyDelegPredFailure ConwayEra
-> ConwayCertsPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "CERT" ConwayEra
ShelleyDelegPredFailure ConwayEra
-> ConwayCertPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERT" ShelleyDelegPredFailure ConwayEra where
  injectFailure :: ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "CERT" ConwayEra
injectFailure = PredicateFailure (EraRule "DELEG" ConwayEra)
-> ConwayCertPredFailure ConwayEra
ConwayDelegPredFailure ConwayEra -> ConwayCertPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "DELEG" era) -> ConwayCertPredFailure era
DelegFailure (ConwayDelegPredFailure ConwayEra
 -> ConwayCertPredFailure ConwayEra)
-> (ShelleyDelegPredFailure ConwayEra
    -> ConwayDelegPredFailure ConwayEra)
-> ShelleyDelegPredFailure ConwayEra
-> ConwayCertPredFailure ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "DELEG" ConwayEra
ShelleyDelegPredFailure ConwayEra
-> ConwayDelegPredFailure ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "DELEG" ShelleyDelegPredFailure ConwayEra where
  injectFailure :: ShelleyDelegPredFailure ConwayEra
-> EraRuleFailure "DELEG" ConwayEra
injectFailure (Shelley.StakeKeyAlreadyRegisteredDELEG Credential Staking
c) = Credential Staking -> ConwayDelegPredFailure ConwayEra
forall era. Credential Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential Staking
c
  injectFailure (Shelley.StakeKeyNotRegisteredDELEG Credential Staking
c) = Credential Staking -> ConwayDelegPredFailure ConwayEra
forall era. Credential Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential Staking
c
  injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG Coin
c) = Coin -> ConwayDelegPredFailure ConwayEra
forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
c
  injectFailure ShelleyDelegPredFailure ConwayEra
_ = String -> ConwayDelegPredFailure ConwayEra
forall a. HasCallStack => String -> a
error String
"Cannot inject ShelleyDelegPredFailure into ConwayEra"

getCommittee :: ConwayEraGov era => ImpTestM era (StrictMaybe (Committee era))
getCommittee :: forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (Committee era))
getCommittee = SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
 -> ImpTestM era (StrictMaybe (Committee era)))
-> SimpleGetter (NewEpochState era) (StrictMaybe (Committee era))
-> ImpTestM era (StrictMaybe (Committee era))
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> EpochState era -> Const r (EpochState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL ((GovState era -> Const r (GovState era))
 -> EpochState era -> Const r (EpochState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const r (StrictMaybe (Committee era)))
-> GovState era -> Const r (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL