{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Conway.Imp.EnactSpec (spec) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.Rules
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyTickEvent (..))
import Cardano.Ledger.Val (zero, (<->))
import Control.Monad (forM)
import Control.Monad.Writer (listen)
import Control.State.Transition.Extended (STS (..))
import Data.Default (def)
import Data.Foldable as F (foldl', traverse_)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Typeable (cast)
import Data.Word (Word64)
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Arbitrary (uniformSubSet)
import Test.Cardano.Ledger.Core.Rational
import Test.Cardano.Ledger.Imp.Common
import Type.Reflection (Typeable)

spec ::
  forall era.
  ( ConwayEraImp era
  , NFData (Event (EraRule "ENACT" era))
  , ToExpr (Event (EraRule "ENACT" era))
  , Eq (Event (EraRule "ENACT" era))
  , Typeable (Event (EraRule "ENACT" era))
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era)),
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era))) =>
SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
constitutionSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec

treasuryWithdrawalsSpec ::
  forall era.
  ( ConwayEraImp era
  , NFData (Event (EraRule "ENACT" era))
  , ToExpr (Event (EraRule "ENACT" era))
  , Eq (Event (EraRule "ENACT" era))
  , Typeable (Event (EraRule "ENACT" era))
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec :: forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era))) =>
SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Treasury withdrawals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- Treasury withdrawals are disallowed in bootstrap, so we're running these tests only post-bootstrap
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Modify EnactState as expected" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      RewardAccount
rewardAcount1 <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
      GovActionId
govActionId <- [(RewardAccount, Coin)] -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount
rewardAcount1, Integer -> Coin
Coin Integer
666)]
      GovActionState era
gas <- GovActionId -> ImpTestM era (GovActionState era)
forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId
      let govAction :: GovAction era
govAction = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      EnactState era
enactStateInit <- ImpTestM era (EnactState era)
forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
      let signal :: EnactSignal era
signal =
            EnactSignal
              { esGovActionId :: GovActionId
esGovActionId = GovActionId
govActionId
              , esGovAction :: GovAction era
esGovAction = GovAction era
govAction
              }
          enactState :: EnactState era
enactState =
            EnactState era
enactStateInit
              { ensTreasury = Coin 1000
              }
      EnactState era
enactState' <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"ENACT" () EnactState era
State (EraRule "ENACT" era)
enactState EnactSignal era
Signal (EraRule "ENACT" era)
signal
      EnactState era -> Map (Credential 'Staking) Coin
forall era. EnactState era -> Map (Credential 'Staking) Coin
ensWithdrawals EnactState era
enactState' Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [(RewardAccount -> Credential 'Staking
raCredential RewardAccount
rewardAcount1, Integer -> Coin
Coin Integer
666)]

      RewardAccount
rewardAcount2 <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
      let withdrawals' :: [(RewardAccount, Coin)]
withdrawals' =
            [ (RewardAccount
rewardAcount1, Integer -> Coin
Coin Integer
111)
            , (RewardAccount
rewardAcount2, Integer -> Coin
Coin Integer
222)
            ]
      GovActionId
govActionId' <- [(RewardAccount, Coin)] -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals'
      GovActionState era
gas' <- GovActionId -> ImpTestM era (GovActionState era)
forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId -> ImpTestM era (GovActionState era)
getGovActionState GovActionId
govActionId'
      let govAction' :: GovAction era
govAction' = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas'
      let signal' :: EnactSignal era
signal' =
            EnactSignal
              { esGovActionId :: GovActionId
esGovActionId = GovActionId
govActionId'
              , esGovAction :: GovAction era
esGovAction = GovAction era
govAction'
              }

      EnactState era
enactState'' <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"ENACT" () EnactState era
State (EraRule "ENACT" era)
enactState' EnactSignal era
Signal (EraRule "ENACT" era)
signal'

      EnactState era -> Map (Credential 'Staking) Coin
forall era. EnactState era -> Map (Credential 'Staking) Coin
ensWithdrawals EnactState era
enactState''
        Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [ (RewardAccount -> Credential 'Staking
raCredential RewardAccount
rewardAcount1, Integer -> Coin
Coin Integer
777)
                   , (RewardAccount -> Credential 'Staking
raCredential RewardAccount
rewardAcount2, Integer -> Coin
Coin Integer
222)
                   ]
      EnactState era -> Coin
forall era. EnactState era -> Coin
ensTreasury EnactState era
enactState'' Coin -> Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Integer -> Coin
Coin Integer
1

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in a single proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      NonEmpty (Credential 'HotCommitteeRole)
committeeCs <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
drepC, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
      Coin
initialTreasury <- 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
      Int
numWithdrawals <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
      [(RewardAccount, Coin)]
withdrawals <- Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
genWithdrawalsExceeding Coin
initialTreasury Int
numWithdrawals

      ImpTestM era GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era GovActionId -> ImpTestM era ())
-> ImpTestM era GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ [(RewardAccount, Coin)]
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)]
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals Credential 'DRepRole
drepC NonEmpty (Credential 'HotCommitteeRole)
committeeCs
      Coin -> [(RewardAccount, Coin)] -> ImpTestM era ()
forall {era} {b}.
(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 ...),
 EraCertState era) =>
Coin -> [(RewardAccount, b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount, Coin)]
withdrawals

      let sumRequested :: Coin
sumRequested = ((RewardAccount, Coin) -> Coin) -> [(RewardAccount, Coin)] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RewardAccount, Coin) -> Coin
forall a b. (a, b) -> b
snd [(RewardAccount, Coin)]
withdrawals

      String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Submit a treasury donation that can cover the withdrawals" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        let tx :: Tx era
tx =
              TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
sumRequested Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
initialTreasury)
        Tx era -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
      Nat -> ImpTestM era ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      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 ImpTestM era Coin -> Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
forall t. Val t => t
zero
      [(RewardAccount, Coin)] -> ImpTestM era Coin
forall {era} {b}.
(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 ...),
 EraCertState era) =>
[(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, Coin)]
withdrawals ImpTestM era Coin -> Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
sumRequested

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding maxBound Word64 submitted in a single proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      NonEmpty (Credential 'HotCommitteeRole)
committeeCs <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
drepC, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
      Coin
initialTreasury <- 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
      Int
numWithdrawals <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
      [(RewardAccount, Coin)]
withdrawals <- Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
genWithdrawalsExceeding (Integer -> Coin
Coin (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64))) Int
numWithdrawals
      ImpTestM era GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era GovActionId -> ImpTestM era ())
-> ImpTestM era GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ [(RewardAccount, Coin)]
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)]
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactTreasuryWithdrawals [(RewardAccount, Coin)]
withdrawals Credential 'DRepRole
drepC NonEmpty (Credential 'HotCommitteeRole)
committeeCs
      Coin -> [(RewardAccount, Coin)] -> ImpTestM era ()
forall {era} {b}.
(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 ...),
 EraCertState era) =>
Coin -> [(RewardAccount, b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount, Coin)]
withdrawals

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in several proposals within the same epoch" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$
      ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
        NonEmpty (Credential 'HotCommitteeRole)
committeeCs <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
        (Credential 'DRepRole
drepC, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
        Coin -> ImpTestM era ()
forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury (Coin -> ImpTestM era ()) -> Coin -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5_000_000
        Coin
initialTreasury <- 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
        Int
numWithdrawals <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
        [(RewardAccount, Coin)]
withdrawals <- Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
genWithdrawalsExceeding Coin
initialTreasury Int
numWithdrawals

        String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"submit in individual proposals in the same epoch" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          ((RewardAccount, Coin) -> ImpTestM era ())
-> [(RewardAccount, Coin)] -> ImpTestM era ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
            ( \(RewardAccount, Coin)
w -> do
                GovActionId
gaId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals @era [(RewardAccount, Coin)
Item [(RewardAccount, Coin)]
w]
                Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepC) GovActionId
gaId
                NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpTestM era ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeCs GovActionId
gaId
            )
            [(RewardAccount, Coin)]
withdrawals
          Nat -> ImpTestM era ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2

          let expectedTreasury :: Coin
expectedTreasury =
                (Coin -> (RewardAccount, Coin) -> Coin)
-> Coin -> [(RewardAccount, Coin)] -> Coin
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
                  ( \Coin
acc (RewardAccount
_, Coin
x) ->
                      if Coin
acc Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
x
                        then Coin
acc Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
x
                        else Coin
acc
                  )
                  Coin
initialTreasury
                  [(RewardAccount, Coin)]
withdrawals

          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 ImpTestM era Coin -> Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
expectedTreasury
          -- check that the sum of the rewards matches what was spent from the treasury
          [(RewardAccount, Coin)] -> ImpTestM era Coin
forall {era} {b}.
(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 ...),
 EraCertState era) =>
[(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, Coin)]
withdrawals ImpTestM era Coin -> Coin -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` (Coin
initialTreasury Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
expectedTreasury)
  where
    sumRewardAccounts :: [(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, b)]
withdrawals = [Coin] -> Coin
forall a. Monoid a => [a] -> a
mconcat ([Coin] -> Coin)
-> ImpM (LedgerSpec era) [Coin] -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((RewardAccount, b) -> ImpM (LedgerSpec era) Coin)
-> [(RewardAccount, b)] -> ImpM (LedgerSpec era) [Coin]
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) -> [a] -> f [b]
traverse (RewardAccount -> ImpM (LedgerSpec era) Coin
forall era. EraCertState era => RewardAccount -> ImpTestM era Coin
getRewardAccountAmount (RewardAccount -> ImpM (LedgerSpec era) Coin)
-> ((RewardAccount, b) -> RewardAccount)
-> (RewardAccount, b)
-> ImpM (LedgerSpec era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewardAccount, b) -> RewardAccount
forall a b. (a, b) -> a
fst) [(RewardAccount, b)]
withdrawals
    genWithdrawalsExceeding :: Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
genWithdrawalsExceeding (Coin Integer
val) Int
n = do
      [Integer]
vals <- Integer -> Int -> ImpM (LedgerSpec era) [Integer]
forall {m :: * -> *} {a}.
(MonadGen m, Random a, Integral a) =>
a -> Int -> m [a]
genValuesExceeding Integer
val Int
n
      [Coin]
-> (Coin -> ImpM (LedgerSpec era) (RewardAccount, Coin))
-> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Integer -> Coin
Coin (Integer -> Coin) -> [Integer] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Integer]
vals) ((Coin -> ImpM (LedgerSpec era) (RewardAccount, Coin))
 -> ImpM (LedgerSpec era) [(RewardAccount, Coin)])
-> (Coin -> ImpM (LedgerSpec era) (RewardAccount, Coin))
-> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
forall a b. (a -> b) -> a -> b
$ \Coin
coin -> (,Coin
coin) (RewardAccount -> (RewardAccount, Coin))
-> ImpM (LedgerSpec era) RewardAccount
-> ImpM (LedgerSpec era) (RewardAccount, Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
    checkNoWithdrawal :: Coin -> [(RewardAccount, b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount, b)]
withdrawals = do
      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 ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
initialTreasury
      [(RewardAccount, b)] -> ImpTestM era Coin
forall {era} {b}.
(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 ...),
 EraCertState era) =>
[(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, b)]
withdrawals ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
forall t. Val t => t
zero
    genValuesExceeding :: a -> Int -> m [a]
genValuesExceeding a
val Int
n = do
      [a]
pcts <- Int -> m a -> m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (m a -> m [a]) -> m a -> m [a]
forall a b. (a -> b) -> a -> b
$ (a, a) -> m a
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (a
1, a
100)
      let tot :: a
tot = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
pcts
      let amounts :: [a]
amounts = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> Ratio a -> a
forall b. Integral b => Ratio a -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
val) a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
tot)) [a]
pcts
      let minNeeded :: a
minNeeded = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a
val a -> a -> a
forall a. Num a => a -> a -> a
- [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
amounts a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
      a
excess <- (a, a) -> m a
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (a
minNeeded, a
val a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
      [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ a
excess a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
amounts

hardForkInitiationSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec =
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
    (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
_ <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId1, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId2, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (Credential 'DRepRole
dRep1, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
11_000_000
    (Credential 'DRepRole
dRep2, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
11_000_000
    ProtVer
curProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- Version -> ImpM (LedgerSpec era) Version
forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion (Version -> ImpM (LedgerSpec era) Version)
-> Version -> ImpM (LedgerSpec era) Version
forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    GovActionId
govActionId <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose era)
forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpTestM era ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' GovActionId
govActionId
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep1) GovActionId
govActionId
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId1) GovActionId
govActionId
    Nat -> ImpTestM era ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      ImpTestM era ()
-> (ImpTestM era ()
    -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era]))
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a b. a -> (a -> b) -> b
& ImpTestM era () -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
-> (((), [SomeSTSEvent era]) -> ImpTestM era ()) -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents ([SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> [SomeSTSEvent era]
-> ImpTestM era ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a b. (a, b) -> b
snd (((), [SomeSTSEvent era]) -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> ImpTestM era ()
forall a b.
(((), [SomeSTSEvent era]) -> a -> b)
-> (((), [SomeSTSEvent era]) -> a) -> ((), [SomeSTSEvent era]) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeSTSEvent era]
-> ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a. a -> ((), [SomeSTSEvent era]) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep2) GovActionId
govActionId
    Nat -> ImpTestM era ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      ImpTestM era ()
-> (ImpTestM era ()
    -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era]))
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a b. a -> (a -> b) -> b
& ImpTestM era () -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
-> (((), [SomeSTSEvent era]) -> ImpTestM era ()) -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents ([SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> [SomeSTSEvent era]
-> ImpTestM era ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a b. (a, b) -> b
snd (((), [SomeSTSEvent era]) -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> ImpTestM era ()
forall a b.
(((), [SomeSTSEvent era]) -> a -> b)
-> (((), [SomeSTSEvent era]) -> a) -> ((), [SomeSTSEvent era]) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeSTSEvent era]
-> ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a. a -> ((), [SomeSTSEvent era]) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId2) GovActionId
govActionId
    Nat -> ImpTestM era ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      ImpTestM era ()
-> (ImpTestM era ()
    -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era]))
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a b. a -> (a -> b) -> b
& ImpTestM era () -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
-> (((), [SomeSTSEvent era]) -> ImpTestM era ()) -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents ([SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> [SomeSTSEvent era]
-> ImpTestM era ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a b. (a, b) -> b
snd
        (((), [SomeSTSEvent era]) -> [SomeSTSEvent era] -> ImpTestM era ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> ImpTestM era ()
forall a b.
(((), [SomeSTSEvent era]) -> a -> b)
-> (((), [SomeSTSEvent era]) -> a) -> ((), [SomeSTSEvent era]) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeSTSEvent era]
-> ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a. a -> ((), [SomeSTSEvent era]) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"TICK" (Event (EraRule "TICK" era) -> Item [SomeSTSEvent era])
-> (ConwayEpochEvent era -> Event (EraRule "TICK" era))
-> ConwayEpochEvent era
-> Item [SomeSTSEvent era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayEpochEvent era -> EraRuleEvent "TICK" era
ConwayEpochEvent era -> Event (EraRule "TICK" era)
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (ConwayEpochEvent era -> Item [SomeSTSEvent era])
-> ConwayEpochEvent era -> Item [SomeSTSEvent era]
forall a b. (a -> b) -> a -> b
$
              Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent (ProtVer -> ConwayHardForkEvent era
forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent ProtVer
nextProtVer)
          ]

    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

hardForkInitiationNoDRepsSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation without DRep voting" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
forall a. Default a => a
def)
    (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
_ <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId1, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId2, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    ProtVer
curProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- Version -> ImpM (LedgerSpec era) Version
forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion (Version -> ImpM (LedgerSpec era) Version)
-> Version -> ImpM (LedgerSpec era) Version
forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    GovActionId
govActionId <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose era)
forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' GovActionId
govActionId
    Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId1) GovActionId
govActionId
    Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      ImpM (LedgerSpec era) ()
-> (ImpM (LedgerSpec era) ()
    -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era]))
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a b. a -> (a -> b) -> b
& ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
-> (((), [SomeSTSEvent 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
>>= [SomeSTSEvent era]
-> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents ([SomeSTSEvent era]
 -> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> [SomeSTSEvent era]
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a b. (a, b) -> b
snd (((), [SomeSTSEvent era])
 -> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> ImpM (LedgerSpec era) ()
forall a b.
(((), [SomeSTSEvent era]) -> a -> b)
-> (((), [SomeSTSEvent era]) -> a) -> ((), [SomeSTSEvent era]) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeSTSEvent era]
-> ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a. a -> ((), [SomeSTSEvent era]) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId2) GovActionId
govActionId
    Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      ImpM (LedgerSpec era) ()
-> (ImpM (LedgerSpec era) ()
    -> ImpM (LedgerSpec era) ((), [SomeSTSEvent era]))
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a b. a -> (a -> b) -> b
& ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
-> (((), [SomeSTSEvent 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
>>= [SomeSTSEvent era]
-> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents ([SomeSTSEvent era]
 -> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> [SomeSTSEvent era]
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a b. (a, b) -> b
snd
        (((), [SomeSTSEvent era])
 -> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ())
-> (((), [SomeSTSEvent era]) -> [SomeSTSEvent era])
-> ((), [SomeSTSEvent era])
-> ImpM (LedgerSpec era) ()
forall a b.
(((), [SomeSTSEvent era]) -> a -> b)
-> (((), [SomeSTSEvent era]) -> a) -> ((), [SomeSTSEvent era]) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeSTSEvent era]
-> ((), [SomeSTSEvent era]) -> [SomeSTSEvent era]
forall a. a -> ((), [SomeSTSEvent era]) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"TICK" (Event (EraRule "TICK" era) -> Item [SomeSTSEvent era])
-> (ConwayEpochEvent era -> Event (EraRule "TICK" era))
-> ConwayEpochEvent era
-> Item [SomeSTSEvent era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayEpochEvent era -> EraRuleEvent "TICK" era
ConwayEpochEvent era -> Event (EraRule "TICK" era)
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (ConwayEpochEvent era -> Item [SomeSTSEvent era])
-> ConwayEpochEvent era -> Item [SomeSTSEvent era]
forall a b. (a -> b) -> a -> b
$
              Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent (ProtVer -> ConwayHardForkEvent era
forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent ProtVer
nextProtVer)
          ]
    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

pparamPredictionSpec :: ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"futurePParams" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
forall a. Default a => a
def)
    (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
_ <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId1, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool
stakePoolId2, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    ProtVer
curProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- Version -> ImpM (LedgerSpec era) Version
forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion (Version -> ImpM (LedgerSpec era) Version)
-> Version -> ImpM (LedgerSpec era) Version
forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    GovActionId
govActionId <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose era)
forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' GovActionId
govActionId
    Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId1) GovActionId
govActionId
    Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
stakePoolId2) GovActionId
govActionId
    ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    ImpM (LedgerSpec era) ()
forall era. ImpTestM era ()
advanceToPointOfNoReturn
    ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec =
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NoConfidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtCommitteeNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtCommitteeNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
200
    let
      getCommittee :: 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
. (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))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> LedgerState era -> Const r (LedgerState 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
. (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))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> UTxOState era -> Const r (UTxOState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee 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))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> GovState era -> Const r (GovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> UTxOState era
-> Const r (UTxOState 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
      assertNoCommittee :: HasCallStack => ImpTestM era ()
      assertNoCommittee :: HasCallStack => ImpTestM era ()
assertNoCommittee =
        do
          StrictMaybe (Committee era)
committee <- ImpTestM era (StrictMaybe (Committee era))
getCommittee
          String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"There should not be a committee" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ StrictMaybe (Committee era)
committee StrictMaybe (Committee era)
-> StrictMaybe (Committee era) -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` StrictMaybe (Committee era)
forall a. StrictMaybe a
SNothing
    KeyHash 'ColdCommitteeRole
khCC <- ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    Set (Credential 'ColdCommitteeRole)
initialCommitteeMembers <- ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers

    (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
    EpochNo
startEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
    let committeeMap :: Map (Credential 'ColdCommitteeRole) EpochNo
committeeMap =
          [(Credential 'ColdCommitteeRole, EpochNo)]
-> Map (Credential 'ColdCommitteeRole) EpochNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'ColdCommitteeRole
khCC, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
50))
            ]
    prevGaidCommittee :: GovPurposeId 'CommitteePurpose era
prevGaidCommittee@(GovPurposeId GovActionId
gaidCommittee) <-
      StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Credential 'DRepRole
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose era)
forall era.
(HasCallStack, ConwayEraImp era) =>
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Credential 'DRepRole
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee
        StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. StrictMaybe a
SNothing
        Credential 'DRepRole
drep
        Set (Credential 'ColdCommitteeRole)
initialCommitteeMembers
        Map (Credential 'ColdCommitteeRole) EpochNo
committeeMap
    (KeyHash 'StakePool
khSPO, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
    ImpTestM era ()
forall era.
(ToExpr (InstantStake era), HasCallStack) =>
ImpTestM era ()
logInstantStake
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
khSPO) GovActionId
gaidCommittee
    Int -> ImpTestM era () -> ImpTestM era ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 ImpTestM era ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Committee should be elected" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      StrictMaybe (Committee era)
committee <- ImpTestM era (StrictMaybe (Committee era))
getCommittee
      StrictMaybe (Committee era)
committee StrictMaybe (Committee era)
-> StrictMaybe (Committee era) -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Committee era -> StrictMaybe (Committee era)
forall a. a -> StrictMaybe a
SJust (Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
Committee Map (Credential 'ColdCommitteeRole) EpochNo
committeeMap (UnitInterval -> Committee era) -> UnitInterval -> Committee era
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
    GovActionId
gaidNoConf <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal (StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence (GovPurposeId 'CommitteePurpose era
-> StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. a -> StrictMaybe a
SJust GovPurposeId 'CommitteePurpose era
prevGaidCommittee)) 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
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
khSPO) GovActionId
gaidNoConf
    Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drep) GovActionId
gaidNoConf
    Int -> ImpTestM era () -> ImpTestM era ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 ImpTestM era ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    ImpTestM era ()
HasCallStack => ImpTestM era ()
assertNoCommittee

constitutionSpec ::
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
constitutionSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
constitutionSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Constitution" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (Credential 'HotCommitteeRole
committeeMember1 :| [Item [Credential 'HotCommitteeRole]
committeeMember2]) <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
    (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
    Constitution era
initialConstitution <- ImpTestM era (Constitution era)
forall era. ConwayEraImp era => ImpTestM era (Constitution era)
getConstitution
    (ProposalProcedure era
proposal, Constitution era
constitution) <- StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (ProposalProcedure era, Constitution era)
forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (ProposalProcedure era, Constitution era)
mkConstitutionProposal StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
forall a. StrictMaybe a
SNothing
    Maybe GovActionId
mbGovActionId <-
      ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
        NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal)]
    Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbGovActionId ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
govActionId -> do
      Proposals era
proposalsBeforeVotes <- 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)
(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))
-> ((Proposals era -> Const r (Proposals era))
    -> ConwayGovState era -> Const r (ConwayGovState 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)
(Proposals era -> Const r (Proposals era))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL
      DRepPulsingState era
pulserBeforeVotes <- SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpTestM era (DRepPulsingState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
SimpleGetter (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL

      Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep) GovActionId
govActionId
      Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
committeeMember1) GovActionId
govActionId
      Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Item [Credential 'HotCommitteeRole]
Credential 'HotCommitteeRole
committeeMember2) GovActionId
govActionId

      Proposals era
proposalsAfterVotes <- 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)
(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))
-> ((Proposals era -> Const r (Proposals era))
    -> ConwayGovState era -> Const r (ConwayGovState 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)
(Proposals era -> Const r (Proposals era))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL
      DRepPulsingState era
pulserAfterVotes <- SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpTestM era (DRepPulsingState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
SimpleGetter (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Votes are recorded in the proposals" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        let proposalsWithVotes :: Proposals era
proposalsWithVotes =
              Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
committeeMember1)
                Vote
VoteYes
                GovActionId
govActionId
                ( Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                    (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Item [Credential 'HotCommitteeRole]
Credential 'HotCommitteeRole
committeeMember2)
                    Vote
VoteYes
                    GovActionId
govActionId
                    ( Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                        (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep)
                        Vote
VoteYes
                        GovActionId
govActionId
                        Proposals era
proposalsBeforeVotes
                    )
                )
        Proposals era
proposalsAfterVotes Proposals era -> Proposals era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Proposals era
proposalsWithVotes

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser has not changed" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        DRepPulsingState era
pulserAfterVotes DRepPulsingState era
-> DRepPulsingState era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` DRepPulsingState era
pulserBeforeVotes

      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"New constitution is not enacted after one epoch" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        Constitution era
constitutionAfterOneEpoch <- 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
        Constitution era
constitutionAfterOneEpoch Constitution era -> Constitution era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
initialConstitution

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser should reflect the constitution to be enacted" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        DRepPulsingState era
pulser <- SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpTestM era (DRepPulsingState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
SimpleGetter (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL
        let ratifyState :: RatifyState era
ratifyState = DRepPulsingState era -> RatifyState era
forall era. EraStake era => DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        GovActionState era -> GovActionId
forall era. GovActionState era -> GovActionId
gasId (GovActionState era -> GovActionId)
-> Seq (GovActionState era) -> Seq GovActionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RatifyState era -> Seq (GovActionState era)
forall era. RatifyState era -> Seq (GovActionState era)
rsEnacted RatifyState era
ratifyState Seq GovActionId -> Seq GovActionId -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` GovActionId
govActionId GovActionId -> Seq GovActionId -> Seq GovActionId
forall a. a -> Seq a -> Seq a
Seq.:<| Seq GovActionId
forall a. Seq a
Seq.Empty
        RatifyState era -> EnactState era
forall era. RatifyState era -> EnactState era
rsEnactState RatifyState era
ratifyState EnactState era
-> Getting (Constitution era) (EnactState era) (Constitution era)
-> Constitution era
forall s a. s -> Getting a s a -> a
^. Getting (Constitution era) (EnactState era) (Constitution era)
forall era (f :: * -> *).
Functor f =>
(Constitution era -> f (Constitution era))
-> EnactState era -> f (EnactState era)
ensConstitutionL Constitution era -> Constitution era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution

      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Constitution is enacted after two epochs" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        Constitution era
curConstitution <- 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
        Constitution era
curConstitution Constitution era -> Constitution era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser is reset" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        DRepPulsingState era
pulser <- SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpTestM era (DRepPulsingState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
SimpleGetter (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL
        let pulserRatifyState :: RatifyState era
pulserRatifyState = DRepPulsingState era -> RatifyState era
forall era. EraStake era => DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        RatifyState era -> Seq (GovActionState era)
forall era. RatifyState era -> Seq (GovActionState era)
rsEnacted RatifyState era
pulserRatifyState Seq (GovActionState era)
-> Seq (GovActionState era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Seq (GovActionState era)
forall a. Seq a
Seq.empty
        EnactState era
enactState <- ImpTestM era (EnactState era)
forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
        RatifyState era -> EnactState era
forall era. RatifyState era -> EnactState era
rsEnactState RatifyState era
pulserRatifyState EnactState era -> EnactState era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` EnactState era
enactState

actionPrioritySpec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Competing proposals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"higher action priority wins" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (Credential 'DRepRole
drepC, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
      (KeyHash 'StakePool
poolKH, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
      Credential 'ColdCommitteeRole
cc <- KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ProposalProcedure era
proposal <-
        Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole
cc, Word32 -> EpochInterval
EpochInterval Word32
30)] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3)
      Maybe GovActionId
mbGai1 <-
        ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
          NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbGai1 ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
gai1 -> do
        -- gai2 is the first action of a higher priority
        GovActionId
gai2 <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. StrictMaybe a
SNothing
        GovActionId
gai3 <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. StrictMaybe a
SNothing
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ @[]
          ( \GovActionId
gaid -> do
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepC) GovActionId
gaid
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
poolKH) GovActionId
gaid
          )
          [Item [GovActionId]
GovActionId
gai1, Item [GovActionId]
GovActionId
gai2, Item [GovActionId]
GovActionId
gai3]
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee
          ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` GovPurposeId 'CommitteePurpose era
-> StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'CommitteePurpose era
forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
gai2)
        ImpM (LedgerSpec era) ()
forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals

        StrictMaybe (Committee era)
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
. (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))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> LedgerState era -> Const r (LedgerState 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
. (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))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> UTxOState era -> Const r (UTxOState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee 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)
(ConwayGovState era -> Const r (ConwayGovState era))
-> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL ((ConwayGovState era -> Const r (ConwayGovState era))
 -> UTxOState era -> Const r (UTxOState era))
-> ((StrictMaybe (Committee era)
     -> Const r (StrictMaybe (Committee era)))
    -> ConwayGovState era -> Const r (ConwayGovState era))
-> (StrictMaybe (Committee era)
    -> Const r (StrictMaybe (Committee era)))
-> UTxOState era
-> Const r (UTxOState 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
        StrictMaybe (Committee era)
committee StrictMaybe (Committee era)
-> StrictMaybe (Committee era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` StrictMaybe (Committee era)
forall a. StrictMaybe a
SNothing

    -- distinct constitutional values for minFee
    let genMinFeeVals :: ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals =
          (\Integer
x Integer
y Integer
z -> (Integer -> Coin
Coin Integer
x, Integer -> Coin
Coin Integer
y, Integer -> Coin
Coin Integer
z))
            (Integer -> Integer -> Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Integer -> Integer -> (Coin, Coin, Coin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
30, Integer
330)
            ImpM (LedgerSpec era) (Integer -> Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Integer -> (Coin, Coin, Coin))
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
330, Integer
660)
            ImpM (LedgerSpec era) (Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Coin, Coin, Coin)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
660, Integer
1000)

    SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitExpectLedgerRuleConformance (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/642
      -- TODO: Remove this override once the issue is fixed
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"proposals of same priority are enacted in order of submission" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtPPSecurityGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
        ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtPPEconomicGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
forall a. Default a => a
def)
        (Coin
val1, Coin
val2, Coin
val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

        NonEmpty (Credential 'HotCommitteeRole)
committeeCs <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
        (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        GovActionId
pGai0 <-
          StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange
            StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing
            (PParamsUpdate era -> ImpTestM era GovActionId)
-> PParamsUpdate era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val1
        GovActionId
pGai1 <-
          StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange
            (GovActionId -> StrictMaybe GovActionId
forall a. a -> StrictMaybe a
SJust GovActionId
pGai0)
            (PParamsUpdate era -> ImpTestM era GovActionId)
-> PParamsUpdate era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val2
        GovActionId
pGai2 <-
          StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange
            (GovActionId -> StrictMaybe GovActionId
forall a. a -> StrictMaybe a
SJust GovActionId
pGai1)
            (PParamsUpdate era -> ImpTestM era GovActionId)
-> PParamsUpdate era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val3
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ @[]
          ( \GovActionId
gaid -> do
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
gaid
              NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeCs GovActionId
gaid
          )
          [Item [GovActionId]
GovActionId
pGai0, Item [GovActionId]
GovActionId
pGai1, Item [GovActionId]
GovActionId
pGai2]
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange
          ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` GovPurposeId 'PParamUpdatePurpose era
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'PParamUpdatePurpose era
forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
pGai2)
        ImpM (LedgerSpec era) ()
forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals
        SimpleGetter (NewEpochState era) Coin -> ImpTestM 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
ppMinFeeAL)
          ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
val3

    SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall era.
SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
disableImpInitExpectLedgerRuleConformance (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/642
      -- TODO: Remove this override once the issue is fixed
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"only the first action of a transaction gets enacted" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtPPSecurityGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
        ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtPPEconomicGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
forall a. Default a => a
def)
        (Coin
val1, Coin
val2, Coin
val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

        NonEmpty (Credential 'HotCommitteeRole)
committeeCs <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
        (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        StrictMaybe ScriptHash
policy <- ImpTestM era (StrictMaybe ScriptHash)
forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe ScriptHash)
getGovPolicy
        NonEmpty GovActionId
gaids <-
          NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
submitGovActions (NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId))
-> NonEmpty (GovAction era) -> ImpTestM era (NonEmpty GovActionId)
forall a b. (a -> b) -> a -> b
$
            [GovAction era] -> NonEmpty (GovAction era)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
              [ StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange
                  StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
forall a. StrictMaybe a
SNothing
                  (PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val1)
                  StrictMaybe ScriptHash
policy
              , StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange
                  StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
forall a. StrictMaybe a
SNothing
                  (PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val2)
                  StrictMaybe ScriptHash
policy
              , StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange
                  StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
forall a. StrictMaybe a
SNothing
                  (PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
val3)
                  StrictMaybe ScriptHash
policy
              ]
        (GovActionId -> ImpM (LedgerSpec era) ())
-> NonEmpty GovActionId -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          ( \GovActionId
gaid -> do
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
gaid
              NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeCs GovActionId
gaid
          )
          NonEmpty GovActionId
gaids
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        SimpleGetter (NewEpochState era) Coin -> ImpTestM 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
ppMinFeeAL)
          ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
val1
        ImpM (LedgerSpec era) ()
forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals

expectHardForkEvents ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  ) =>
  [SomeSTSEvent era] ->
  [SomeSTSEvent era] ->
  ImpTestM era ()
expectHardForkEvents :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents [SomeSTSEvent era]
actual [SomeSTSEvent era]
expected =
  (SomeSTSEvent era -> Bool)
-> [SomeSTSEvent era] -> [SomeSTSEvent era]
forall a. (a -> Bool) -> [a] -> [a]
filter SomeSTSEvent era -> Bool
isHardForkEvent [SomeSTSEvent era]
actual [SomeSTSEvent era]
-> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` [SomeSTSEvent era]
expected
  where
    isHardForkEvent :: SomeSTSEvent era -> Bool
isHardForkEvent (SomeSTSEvent Event (EraRule rule era)
ev)
      | Just
          (TickNewEpochEvent (EpochEvent (HardForkEvent (ConwayHardForkEvent ProtVer
_))) :: ShelleyTickEvent era) <-
          Event (EraRule rule era) -> Maybe (ShelleyTickEvent era)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Event (EraRule rule era)
ev =
          Bool
True
      | Bool
otherwise = Bool
False

committeeSpec ::
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
committeeSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Committee enactment" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Enact UpdateCommitee with lengthy lifetime" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      NonNegative Nat
n <- ImpM (LedgerSpec era) (NonNegative Nat)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
n
      (Credential 'DRepRole
drepCred, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
      (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      Credential 'ColdCommitteeRole
cc <- KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      EpochInterval Word32
committeeMaxTermLength <-
        SimpleGetter (NewEpochState era) EpochInterval
-> ImpTestM era EpochInterval
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) EpochInterval
 -> ImpTestM era EpochInterval)
-> SimpleGetter (NewEpochState era) EpochInterval
-> ImpTestM era EpochInterval
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))
-> ((EpochInterval -> Const r EpochInterval)
    -> EpochState era -> Const r (EpochState era))
-> (EpochInterval -> Const r EpochInterval)
-> 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))
-> ((EpochInterval -> Const r EpochInterval)
    -> PParams era -> Const r (PParams era))
-> (EpochInterval -> Const r EpochInterval)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpochInterval -> Const r EpochInterval)
-> PParams era -> Const r (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL
      ProposalProcedure era
proposal <-
        Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole
cc, Word32 -> EpochInterval
EpochInterval (Word32
committeeMaxTermLength Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2))] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
      Maybe GovActionId
mbSecondAddCCGaid <-
        ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
          NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbSecondAddCCGaid ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
secondAddCCGaid -> do
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
secondAddCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
secondAddCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Due to longer than allowed lifetime we have to wait an extra epoch for this new action to be enacted
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole
cc
        ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole
cc

    -- A CC that has resigned will need to be first voted out and then voted in to be considered active
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CC re-election" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (Credential 'DRepRole
drepCred, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
      (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
      -- Add a fresh CC
      Credential 'ColdCommitteeRole
cc <- KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ProposalProcedure era
proposal <-
        Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole
cc, Word32 -> EpochInterval
EpochInterval Word32
10)] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
      Maybe GovActionId
mbAddCCGaid <-
        ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
          NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbAddCCGaid ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
addCCGaid -> do
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
addCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
addCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Confirm that they are added
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole
cc
        -- Confirm their hot key registration
        Credential 'HotCommitteeRole
_hotKey <- Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
cc
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole
cc
        -- Have them resign
        Maybe (Credential 'HotCommitteeRole)
_ <- Credential 'ColdCommitteeRole
-> StrictMaybe Anchor
-> ImpTestM era (Maybe (Credential 'HotCommitteeRole))
forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ConwayEraCertState era) =>
Credential 'ColdCommitteeRole
-> StrictMaybe Anchor
-> ImpTestM era (Maybe (Credential 'HotCommitteeRole))
resignCommitteeColdKey Credential 'ColdCommitteeRole
cc StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole
cc
        -- Re-add the same CC
        GovActionId
reAddCCGaid <- Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
submitUpdateCommittee Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole
cc, Word32 -> EpochInterval
EpochInterval Word32
20)] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
reAddCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
reAddCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Confirm that they are still resigned
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole
cc
        -- Remove them
        GovActionId
removeCCGaid <-
          Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
submitUpdateCommittee (StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. a -> Maybe a
Just (GovPurposeId 'CommitteePurpose era
-> StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. a -> StrictMaybe a
SJust (GovPurposeId 'CommitteePurpose era
 -> StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> GovPurposeId 'CommitteePurpose era
-> StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a b. (a -> b) -> a -> b
$ GovActionId -> GovPurposeId 'CommitteePurpose era
forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
reAddCCGaid)) (Credential 'ColdCommitteeRole
-> Set (Credential 'ColdCommitteeRole)
forall a. a -> Set a
Set.singleton Credential 'ColdCommitteeRole
cc) [] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
removeCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
removeCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Confirm that they have been removed
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole
cc
        GovActionId
secondAddCCGaid <-
          Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era GovActionId
submitUpdateCommittee Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole
cc, Word32 -> EpochInterval
EpochInterval Word32
20)] (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
secondAddCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
secondAddCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Confirm that they have been added
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole
cc
        -- Confirm that after registering a hot key, they are active
        Credential 'HotCommitteeRole
_hotKey <- Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
cc
        Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'ColdCommitteeRole -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole
cc
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Removing CC with UpdateCommittee" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Non registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (Credential 'DRepRole
drepCred, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
        (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        Set (Credential 'ColdCommitteeRole)
initialCommittee <- ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
        Set (Credential 'ColdCommitteeRole) -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Set (Credential 'ColdCommitteeRole)
initialCommittee
        Set (Credential 'ColdCommitteeRole)
initialCommittee Set (Credential 'ColdCommitteeRole)
-> (Set (Credential 'ColdCommitteeRole) -> Bool)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` Bool -> Bool
not (Bool -> Bool)
-> (Set (Credential 'ColdCommitteeRole) -> Bool)
-> Set (Credential 'ColdCommitteeRole)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole) -> Bool
forall a. Set a -> Bool
Set.null
        ProposalProcedure era
proposal <-
          Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
initialCommittee [(Credential 'ColdCommitteeRole, EpochInterval)]
forall a. Monoid a => a
mempty (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Maybe GovActionId
mbRemoveCCGaid <-
          ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
            NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
        Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbRemoveCCGaid ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
removeCCGaid -> do
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
removeCCGaid
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
removeCCGaid
          Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
          Set (Credential 'ColdCommitteeRole)
finalCommittee <- ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
          Set (Credential 'ColdCommitteeRole) -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Set (Credential 'ColdCommitteeRole)
finalCommittee
          Set (Credential 'ColdCommitteeRole)
finalCommittee Set (Credential 'ColdCommitteeRole)
-> (Set (Credential 'ColdCommitteeRole) -> Bool)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` Set (Credential 'ColdCommitteeRole) -> Bool
forall a. Set a -> Bool
Set.null
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (Credential 'DRepRole
drepCred, Credential 'Staking
_, KeyPair 'Payment
_) <- 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
        (KeyHash 'StakePool
spoC, Credential 'Payment
_, Credential 'Staking
_) <- Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking))
-> Coin
-> ImpTestM
     era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        Set (Credential 'ColdCommitteeRole)
initialCommittee <- ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
        Set (Credential 'ColdCommitteeRole) -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Set (Credential 'ColdCommitteeRole)
initialCommittee
        Set (Credential 'ColdCommitteeRole)
initialCommittee Set (Credential 'ColdCommitteeRole)
-> (Set (Credential 'ColdCommitteeRole) -> Bool)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` Bool -> Bool
not (Bool -> Bool)
-> (Set (Credential 'ColdCommitteeRole) -> Bool)
-> Set (Credential 'ColdCommitteeRole)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole) -> Bool
forall a. Set a -> Bool
Set.null
        [Credential 'ColdCommitteeRole]
-> (Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList Set (Credential 'ColdCommitteeRole)
initialCommittee) ((Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (Credential 'ColdCommitteeRole -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \Credential 'ColdCommitteeRole
kh -> do
          Credential 'HotCommitteeRole
ccHotCred <- 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
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
                ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton (Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert Credential 'ColdCommitteeRole
kh Credential 'HotCommitteeRole
ccHotCred)
        [(Credential 'ColdCommitteeRole, EpochInterval)]
newCommittee <- ImpM
  (LedgerSpec era) [(Credential 'ColdCommitteeRole, EpochInterval)]
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
        Set (Credential 'ColdCommitteeRole)
initialSubCommittee <- ImpM (LedgerSpec era) (IOGenM QCGen)
forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen ImpM (LedgerSpec era) (IOGenM QCGen)
-> (IOGenM QCGen
    -> ImpTestM era (Set (Credential 'ColdCommitteeRole)))
-> ImpTestM era (Set (Credential 'ColdCommitteeRole))
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 Int
-> Set (Credential 'ColdCommitteeRole)
-> IOGenM QCGen
-> ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall g (m :: * -> *) k.
(StatefulGen g m, Ord k) =>
Maybe Int -> Set k -> g -> m (Set k)
uniformSubSet Maybe Int
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
initialCommittee
        ProposalProcedure era
proposal <-
          Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole)
initialSubCommittee [(Credential 'ColdCommitteeRole, EpochInterval)]
newCommittee (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Maybe GovActionId
mbRemoveCCGaid <-
          ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal (SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId))
-> SubmitFailureExpectation era -> ImpTestM era (Maybe GovActionId)
forall a b. (a -> b) -> a -> b
$
            NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayGovPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ ProposalProcedure era -> ConwayGovPredFailure era
forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
        Maybe GovActionId
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GovActionId
mbRemoveCCGaid ((GovActionId -> ImpM (LedgerSpec era) ())
 -> ImpM (LedgerSpec era) ())
-> (GovActionId -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \GovActionId
removeCCGaid -> do
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
drepCred) GovActionId
removeCCGaid
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash 'StakePool -> Voter
StakePoolVoter KeyHash 'StakePool
spoC) GovActionId
removeCCGaid
          Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
          Set (Credential 'ColdCommitteeRole)
finalCommittee <- ImpTestM era (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
          Set (Credential 'ColdCommitteeRole) -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Set (Credential 'ColdCommitteeRole)
finalCommittee
          Set (Credential 'ColdCommitteeRole)
finalCommittee
            Set (Credential 'ColdCommitteeRole)
-> Set (Credential 'ColdCommitteeRole) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Set (Credential 'ColdCommitteeRole)
-> Set (Credential 'ColdCommitteeRole)
-> Set (Credential 'ColdCommitteeRole)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set (Credential 'ColdCommitteeRole)
initialCommittee Set (Credential 'ColdCommitteeRole)
-> Set (Credential 'ColdCommitteeRole)
-> Set (Credential 'ColdCommitteeRole)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Credential 'ColdCommitteeRole)
initialSubCommittee) ([Credential 'ColdCommitteeRole]
-> Set (Credential 'ColdCommitteeRole)
forall a. Ord a => [a] -> Set a
Set.fromList ([Credential 'ColdCommitteeRole]
 -> Set (Credential 'ColdCommitteeRole))
-> [Credential 'ColdCommitteeRole]
-> Set (Credential 'ColdCommitteeRole)
forall a b. (a -> b) -> a -> b
$ (Credential 'ColdCommitteeRole, EpochInterval)
-> Credential 'ColdCommitteeRole
forall a b. (a, b) -> a
fst ((Credential 'ColdCommitteeRole, EpochInterval)
 -> Credential 'ColdCommitteeRole)
-> [(Credential 'ColdCommitteeRole, EpochInterval)]
-> [Credential 'ColdCommitteeRole]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Credential 'ColdCommitteeRole, EpochInterval)]
newCommittee)