{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Epoch (
  ConwayEPOCH,
  PredicateFailure,
  ConwayEpochEvent (..),
)
where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (ProtVer, ShelleyBase)
import Cardano.Ledger.CertState (
  CertState (..),
  CommitteeState (..),
  VState,
  dsUnifiedL,
  vsCommitteeStateL,
  vsNumDormantEpochsL,
 )
import Cardano.Ledger.Coin (Coin, compactCoinOrError)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEPOCH, ConwayEra, ConwayHARDFORK, ConwayRATIFY)
import Cardano.Ledger.Conway.Governance (
  Committee,
  ConwayEraGov (..),
  ConwayGovState,
  EnactState (..),
  GovActionId,
  GovActionState (..),
  Proposals,
  RatifyEnv (..),
  RatifySignal (..),
  RatifyState (..),
  RunConwayRatify,
  cgsCommitteeL,
  cgsConstitutionL,
  cgsCurPParamsL,
  cgsFuturePParamsL,
  cgsPrevPParamsL,
  cgsProposalsL,
  ensTreasuryL,
  ensWithdrawalsL,
  epochStateDRepPulsingStateL,
  extractDRepPulsingState,
  gasDeposit,
  gasReturnAddr,
  pPropsL,
  proposalsApplyEnactment,
  proposalsGovStateL,
  setFreshDRepPulsingState,
 )
import Cardano.Ledger.Conway.Governance.Procedures (Committee (..))
import Cardano.Ledger.Conway.Rules.HardFork (
  ConwayHardForkEvent (..),
 )
import Cardano.Ledger.EpochBoundary (SnapShots (..))
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  DState (..),
  EpochState (..),
  LedgerState (..),
  PState (..),
  UTxOState (..),
  asTreasuryL,
  curPParamsEpochStateL,
  esAccountState,
  esAccountStateL,
  esLStateL,
  esSnapshotsL,
  lsCertStateL,
  lsUTxOStateL,
  prevPParamsEpochStateL,
  totalObligation,
  utxosDepositedL,
  utxosDonationL,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Rewards ()
import Cardano.Ledger.Shelley.Rules (
  ShelleyPOOLREAP,
  ShelleyPoolreapEnv (..),
  ShelleyPoolreapEvent,
  ShelleyPoolreapPredFailure,
  ShelleyPoolreapState (..),
  ShelleySNAP,
  ShelleySnapPredFailure,
  SnapEnv (..),
  UpecPredFailure,
 )
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Slot (EpochNo)
import Cardano.Ledger.UMap (RDPair (..), UMap, UView (..), (∪+), (◁))
import qualified Cardano.Ledger.UMap as UMap
import Cardano.Ledger.Val (zero, (<->))
import Control.DeepSeq (NFData)
import Control.SetAlgebra (eval, (⨃))
import Control.State.Transition (
  Embed (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  tellEvent,
  trans,
 )
import Data.Foldable (Foldable (..))
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.OMap.Strict as OMap
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Void (Void, absurd)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (.~), (<>~), (^.))

data ConwayEpochEvent era
  = PoolReapEvent (Event (EraRule "POOLREAP" era))
  | SnapEvent (Event (EraRule "SNAP" era))
  | EpochBoundaryRatifyState (RatifyState era)
  | GovInfoEvent
      -- | Enacted actions
      (Set (GovActionState era))
      -- | Actions that were removed as conflicting due to enactment
      (Set (GovActionState era))
      -- | Actions that were removed due to expiration together with their dependees
      (Set (GovActionState era))
      -- | Map of removed governance action ids that had an unregistered reward account to their unclaimed deposits so they can be transferred to the treasury.
      (Map.Map GovActionId Coin)
  | HardForkEvent (Event (EraRule "HARDFORK" era))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era
forall era x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x
$cto :: forall era x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era
$cfrom :: forall era x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x
Generic)

type instance EraRuleEvent "EPOCH" ConwayEra = ConwayEpochEvent ConwayEra

deriving instance
  ( EraPParams era
  , Eq (Event (EraRule "POOLREAP" era))
  , Eq (Event (EraRule "SNAP" era))
  , Eq (Event (EraRule "HARDFORK" era))
  ) =>
  Eq (ConwayEpochEvent era)

instance
  ( EraPParams era
  , NFData (Event (EraRule "POOLREAP" era))
  , NFData (Event (EraRule "SNAP" era))
  , NFData (Event (EraRule "HARDFORK" era))
  ) =>
  NFData (ConwayEpochEvent era)

instance
  ( EraTxOut era
  , RunConwayRatify era
  , ConwayEraGov era
  , Embed (EraRule "SNAP" era) (ConwayEPOCH era)
  , Environment (EraRule "SNAP" era) ~ SnapEnv era
  , State (EraRule "SNAP" era) ~ SnapShots
  , Signal (EraRule "SNAP" era) ~ ()
  , Embed (EraRule "POOLREAP" era) (ConwayEPOCH era)
  , Environment (EraRule "POOLREAP" era) ~ ShelleyPoolreapEnv era
  , State (EraRule "POOLREAP" era) ~ ShelleyPoolreapState era
  , Signal (EraRule "POOLREAP" era) ~ EpochNo
  , Eq (UpecPredFailure era)
  , Show (UpecPredFailure era)
  , Embed (EraRule "RATIFY" era) (ConwayEPOCH era)
  , Environment (EraRule "RATIFY" era) ~ RatifyEnv era
  , GovState era ~ ConwayGovState era
  , State (EraRule "RATIFY" era) ~ RatifyState era
  , Signal (EraRule "RATIFY" era) ~ RatifySignal era
  , Embed (EraRule "HARDFORK" era) (ConwayEPOCH era)
  , Environment (EraRule "HARDFORK" era) ~ ()
  , State (EraRule "HARDFORK" era) ~ EpochState era
  , Signal (EraRule "HARDFORK" era) ~ ProtVer
  ) =>
  STS (ConwayEPOCH era)
  where
  type State (ConwayEPOCH era) = EpochState era
  type Signal (ConwayEPOCH era) = EpochNo
  type Environment (ConwayEPOCH era) = ()
  type BaseM (ConwayEPOCH era) = ShelleyBase

  -- EPOCH rule can never fail
  type PredicateFailure (ConwayEPOCH era) = Void
  type Event (ConwayEPOCH era) = ConwayEpochEvent era
  transitionRules :: [TransitionRule (ConwayEPOCH era)]
transitionRules = [forall era.
(RunConwayRatify era, Embed (EraRule "SNAP" era) (ConwayEPOCH era),
 EraTxOut era, Eq (UpecPredFailure era), Show (UpecPredFailure era),
 Environment (EraRule "SNAP" era) ~ SnapEnv era,
 State (EraRule "SNAP" era) ~ SnapShots,
 Signal (EraRule "SNAP" era) ~ (),
 Embed (EraRule "POOLREAP" era) (ConwayEPOCH era),
 Environment (EraRule "POOLREAP" era) ~ ShelleyPoolreapEnv era,
 State (EraRule "POOLREAP" era) ~ ShelleyPoolreapState era,
 Signal (EraRule "POOLREAP" era) ~ EpochNo,
 Embed (EraRule "RATIFY" era) (ConwayEPOCH era),
 Environment (EraRule "RATIFY" era) ~ RatifyEnv era,
 State (EraRule "RATIFY" era) ~ RatifyState era,
 GovState era ~ ConwayGovState era,
 Signal (EraRule "RATIFY" era) ~ RatifySignal era, ConwayEraGov era,
 Embed (EraRule "HARDFORK" era) (ConwayEPOCH era),
 Environment (EraRule "HARDFORK" era) ~ (),
 State (EraRule "HARDFORK" era) ~ EpochState era,
 Signal (EraRule "HARDFORK" era) ~ ProtVer) =>
TransitionRule (ConwayEPOCH era)
epochTransition]

returnProposalDeposits ::
  Foldable f =>
  f (GovActionState era) ->
  UMap ->
  (UMap, Map.Map GovActionId Coin)
returnProposalDeposits :: forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era) -> UMap -> (UMap, Map GovActionId Coin)
returnProposalDeposits f (GovActionState era)
removedProposals UMap
oldUMap =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' forall {era}.
GovActionState era
-> (UMap, Map GovActionId Coin) -> (UMap, Map GovActionId Coin)
processProposal (UMap
oldUMap, forall a. Monoid a => a
mempty) f (GovActionState era)
removedProposals
  where
    processProposal :: GovActionState era
-> (UMap, Map GovActionId Coin) -> (UMap, Map GovActionId Coin)
processProposal GovActionState era
gas (UMap
um, Map GovActionId Coin
unclaimed)
      | forall k v. k -> UView k v -> Bool
UMap.member (RewardAccount -> Credential 'Staking
raCredential (forall era. GovActionState era -> RewardAccount
gasReturnAddr GovActionState era
gas)) (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
um) =
          ( forall k. (RDPair -> RDPair) -> k -> UView k RDPair -> UMap
UMap.adjust
              (Coin -> RDPair -> RDPair
addReward (forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas))
              (RewardAccount -> Credential 'Staking
raCredential (forall era. GovActionState era -> RewardAccount
gasReturnAddr GovActionState era
gas))
              (UMap -> UView (Credential 'Staking) RDPair
RewDepUView UMap
um)
          , Map GovActionId Coin
unclaimed
          )
      | Bool
otherwise = (UMap
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. GovActionState era -> GovActionId
gasId GovActionState era
gas) (forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas) Map GovActionId Coin
unclaimed)
    addReward :: Coin -> RDPair -> RDPair
addReward Coin
c RDPair
rd =
      -- Deposits have been validated at this point
      RDPair
rd {rdReward :: CompactForm Coin
rdReward = RDPair -> CompactForm Coin
rdReward RDPair
rd forall a. Semigroup a => a -> a -> a
<> HasCallStack => Coin -> CompactForm Coin
compactCoinOrError Coin
c}

-- | When there have been zero governance proposals to vote on in the previous epoch
-- increase the dormant-epoch counter by one.
updateNumDormantEpochs :: EpochNo -> Proposals era -> VState era -> VState era
updateNumDormantEpochs :: forall era. EpochNo -> Proposals era -> VState era -> VState era
updateNumDormantEpochs EpochNo
currentEpoch Proposals era
ps VState era
vState =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => (v -> Bool) -> OMap k v -> OMap k v
OMap.filter ((EpochNo
currentEpoch forall a. Ord a => a -> a -> Bool
<=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GovActionState era -> EpochNo
gasExpiresAfter) forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (Proposals era) (OMap GovActionId (GovActionState era))
pPropsL
    then VState era
vState forall a b. a -> (a -> b) -> b
& forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Enum a => a -> a
succ
    else VState era
vState

-- | Apply TreasuryWithdrawals to the EpochState
--
--   acnt' = record acnt { treasury = treasury + UTxOState.fees utxoSt
--                                  + getCoin unclaimed + donations ∸ totWithdrawals }
--
-- The utxo fees and donations are applied in the remaining body of EPOCH transition
applyEnactedWithdrawals ::
  AccountState ->
  DState era ->
  EnactState era ->
  (AccountState, DState era, EnactState era)
applyEnactedWithdrawals :: forall era.
AccountState
-> DState era
-> EnactState era
-> (AccountState, DState era, EnactState era)
applyEnactedWithdrawals AccountState
accountState DState era
dState EnactState era
enactedState =
  let enactedWithdrawals :: Map (Credential 'Staking) Coin
enactedWithdrawals = EnactState era
enactedState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (EnactState era) (Map (Credential 'Staking) Coin)
ensWithdrawalsL
      rewardsUView :: UView (Credential 'Staking) RDPair
rewardsUView = UMap -> UView (Credential 'Staking) RDPair
RewDepUView forall a b. (a -> b) -> a -> b
$ DState era
dState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (DState era) UMap
dsUnifiedL
      successfulWithdrawls :: Map (Credential 'Staking) Coin
successfulWithdrawls = UView (Credential 'Staking) RDPair
rewardsUView forall k v u. UView k v -> Map k u -> Map k u
◁ Map (Credential 'Staking) Coin
enactedWithdrawals
      accountState' :: AccountState
accountState' =
        AccountState
accountState
          -- Subtract `successfulWithdrawals` from the treasury, and add them to the rewards UMap
          -- `unclaimed` withdrawals remain in the treasury.
          -- Compared to the spec, instead of adding `unclaimed` and subtracting `totWithdrawals`
          --   + unclaimed - totWithdrawals
          -- we just subtract the `refunds`
          --   - refunds
          forall a b. a -> (a -> b) -> b
& Lens' AccountState Coin
asTreasuryL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall t. Val t => t -> t -> t
<-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential 'Staking) Coin
successfulWithdrawls)
      -- The use of the partial function `compactCoinOrError` is justified here because
      -- 1. the decoder for coin at the proposal-submission boundary has already
      --    confirmed we have a compactible value
      -- 2. the refunds and unsuccessful refunds together do not exceed the
      --    current treasury value, as enforced by the `ENACT` rule.
      dState' :: DState era
dState' =
        DState era
dState
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (UView (Credential 'Staking) RDPair
rewardsUView UView (Credential 'Staking) RDPair
-> Map (Credential 'Staking) (CompactForm Coin) -> UMap
∪+ (HasCallStack => Coin -> CompactForm Coin
compactCoinOrError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Credential 'Staking) Coin
successfulWithdrawls))
      -- Reset enacted withdrawals:
      enactedState' :: EnactState era
enactedState' =
        EnactState era
enactedState
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (EnactState era) (Map (Credential 'Staking) Coin)
ensWithdrawalsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k a. Map k a
Map.empty
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (EnactState era) Coin
ensTreasuryL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty
   in (AccountState
accountState', DState era
dState', EnactState era
enactedState')

epochTransition ::
  forall era.
  ( RunConwayRatify era
  , Embed (EraRule "SNAP" era) (ConwayEPOCH era)
  , EraTxOut era
  , Eq (UpecPredFailure era)
  , Show (UpecPredFailure era)
  , Environment (EraRule "SNAP" era) ~ SnapEnv era
  , State (EraRule "SNAP" era) ~ SnapShots
  , Signal (EraRule "SNAP" era) ~ ()
  , Embed (EraRule "POOLREAP" era) (ConwayEPOCH era)
  , Environment (EraRule "POOLREAP" era) ~ ShelleyPoolreapEnv era
  , State (EraRule "POOLREAP" era) ~ ShelleyPoolreapState era
  , Signal (EraRule "POOLREAP" era) ~ EpochNo
  , Embed (EraRule "RATIFY" era) (ConwayEPOCH era)
  , Environment (EraRule "RATIFY" era) ~ RatifyEnv era
  , State (EraRule "RATIFY" era) ~ RatifyState era
  , GovState era ~ ConwayGovState era
  , Signal (EraRule "RATIFY" era) ~ RatifySignal era
  , ConwayEraGov era
  , Embed (EraRule "HARDFORK" era) (ConwayEPOCH era)
  , Environment (EraRule "HARDFORK" era) ~ ()
  , State (EraRule "HARDFORK" era) ~ EpochState era
  , Signal (EraRule "HARDFORK" era) ~ ProtVer
  ) =>
  TransitionRule (ConwayEPOCH era)
epochTransition :: forall era.
(RunConwayRatify era, Embed (EraRule "SNAP" era) (ConwayEPOCH era),
 EraTxOut era, Eq (UpecPredFailure era), Show (UpecPredFailure era),
 Environment (EraRule "SNAP" era) ~ SnapEnv era,
 State (EraRule "SNAP" era) ~ SnapShots,
 Signal (EraRule "SNAP" era) ~ (),
 Embed (EraRule "POOLREAP" era) (ConwayEPOCH era),
 Environment (EraRule "POOLREAP" era) ~ ShelleyPoolreapEnv era,
 State (EraRule "POOLREAP" era) ~ ShelleyPoolreapState era,
 Signal (EraRule "POOLREAP" era) ~ EpochNo,
 Embed (EraRule "RATIFY" era) (ConwayEPOCH era),
 Environment (EraRule "RATIFY" era) ~ RatifyEnv era,
 State (EraRule "RATIFY" era) ~ RatifyState era,
 GovState era ~ ConwayGovState era,
 Signal (EraRule "RATIFY" era) ~ RatifySignal era, ConwayEraGov era,
 Embed (EraRule "HARDFORK" era) (ConwayEPOCH era),
 Environment (EraRule "HARDFORK" era) ~ (),
 State (EraRule "HARDFORK" era) ~ EpochState era,
 Signal (EraRule "HARDFORK" era) ~ ProtVer) =>
TransitionRule (ConwayEPOCH era)
epochTransition = do
  TRC
    ( ()
      , epochState0 :: State (ConwayEPOCH era)
epochState0@EpochState
          { esAccountState :: forall era. EpochState era -> AccountState
esAccountState = AccountState
accountState0
          , esSnapshots :: forall era. EpochState era -> SnapShots
esSnapshots = SnapShots
snapshots0
          , esLState :: forall era. EpochState era -> LedgerState era
esLState = LedgerState era
ledgerState0
          }
      , Signal (ConwayEPOCH era)
eNo
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let govState0 :: GovState era
govState0 = forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoState0
      curPParams :: PParams era
curPParams = GovState era
govState0 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL
      utxoState0 :: UTxOState era
utxoState0 = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState0
      CertState VState era
vState PState era
pState0 DState era
dState0 = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState0
  SnapShots
snapshots1 <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "SNAP" era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. LedgerState era -> PParams era -> SnapEnv era
SnapEnv LedgerState era
ledgerState0 PParams era
curPParams, SnapShots
snapshots0, ())

  -- Activate future StakePools
  let newStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
newStakePoolParams = forall s t. Embed s t => Exp t -> s
eval (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
pState0 forall k s1 (f :: * -> * -> *) v s2 (g :: * -> * -> *).
(Ord k, HasExp s1 (f k v), HasExp s2 (g k v)) =>
s1 -> s2 -> Exp (f k v)
⨃ forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams PState era
pState0)
      pState1 :: PState era
pState1 =
        PState era
pState0
          { psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = Map (KeyHash 'StakePool) PoolParams
newStakePoolParams
          , psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams = forall k a. Map k a
Map.empty
          }
  PoolreapState UTxOState era
utxoState1 AccountState
accountState1 DState era
dState1 PState era
pState2 <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "POOLREAP" era) forall a b. (a -> b) -> a -> b
$
      forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. VState era -> ShelleyPoolreapEnv era
ShelleyPoolreapEnv VState era
vState, forall era.
UTxOState era
-> AccountState
-> DState era
-> PState era
-> ShelleyPoolreapState era
PoolreapState UTxOState era
utxoState0 AccountState
accountState0 DState era
dState0 PState era
pState1, Signal (ConwayEPOCH era)
eNo)

  let
    stakePoolDistr :: PoolDistr
stakePoolDistr = SnapShots -> PoolDistr
ssStakeMarkPoolDistr SnapShots
snapshots1
    pulsingState :: DRepPulsingState era
pulsingState = State (ConwayEPOCH era)
epochState0 forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL

    ratifyState :: RatifyState era
ratifyState@RatifyState {EnactState era
rsEnactState :: forall era. RatifyState era -> EnactState era
rsEnactState :: EnactState era
rsEnactState, Seq (GovActionState era)
rsEnacted :: forall era. RatifyState era -> Seq (GovActionState era)
rsEnacted :: Seq (GovActionState era)
rsEnacted, Set GovActionId
rsExpired :: forall era. RatifyState era -> Set GovActionId
rsExpired :: Set GovActionId
rsExpired} =
      forall era. DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulsingState

    (AccountState
accountState2, DState era
dState2, EnactState {Map (Credential 'Staking) Coin
PParams era
StrictMaybe (Committee era)
Coin
Constitution era
GovRelation StrictMaybe era
ensPrevGovActionIds :: forall era. EnactState era -> GovRelation StrictMaybe era
ensWithdrawals :: forall era. EnactState era -> Map (Credential 'Staking) Coin
ensTreasury :: forall era. EnactState era -> Coin
ensPrevPParams :: forall era. EnactState era -> PParams era
ensCurPParams :: forall era. EnactState era -> PParams era
ensConstitution :: forall era. EnactState era -> Constitution era
ensCommittee :: forall era. EnactState era -> StrictMaybe (Committee era)
ensPrevGovActionIds :: GovRelation StrictMaybe era
ensWithdrawals :: Map (Credential 'Staking) Coin
ensTreasury :: Coin
ensPrevPParams :: PParams era
ensCurPParams :: PParams era
ensConstitution :: Constitution era
ensCommittee :: StrictMaybe (Committee era)
..}) =
      forall era.
AccountState
-> DState era
-> EnactState era
-> (AccountState, DState era, EnactState era)
applyEnactedWithdrawals AccountState
accountState1 DState era
dState1 EnactState era
rsEnactState

    -- NOTE: It is important that we apply the results of ratification
    -- and enactment from the pulser to the working copy of proposals.
    -- The proposals in the pulser are a subset of the current
    -- proposals, in that, in addition to the proposals in the pulser,
    -- the current proposals now contain new proposals submitted during
    -- the epoch that just passed (we are at its boundary here) and
    -- any votes that were submitted to the already pulsing as well as
    -- newly submitted proposals. We only need to apply the enactment
    -- operations to this superset to get a new set of proposals with:
    -- enacted actions and their sibling subtrees, as well as expired
    -- actions and their subtrees, removed, and with all the votes
    -- intact for the rest of them.
    (Proposals era
newProposals, Map GovActionId (GovActionState era)
enactedActions, Map GovActionId (GovActionState era)
removedDueToEnactment, Map GovActionId (GovActionState era)
expiredActions) =
      forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era))
proposalsApplyEnactment Seq (GovActionState era)
rsEnacted Set GovActionId
rsExpired (GovState era
govState0 forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL)

    -- Apply the values from the computed EnactState to the GovState
    govState1 :: ConwayGovState era
govState1 =
      GovState era
govState0
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (ConwayGovState era) (Proposals era)
cgsProposalsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proposals era
newProposals
        forall a b. a -> (a -> b) -> b
& forall era.
Lens' (ConwayGovState era) (StrictMaybe (Committee era))
cgsCommitteeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (Committee era)
ensCommittee
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (ConwayGovState era) (Constitution era)
cgsConstitutionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Constitution era
ensConstitution
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (ConwayGovState era) (PParams era)
cgsCurPParamsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. EraGov era => GovState era -> PParams era
nextEpochPParams GovState era
govState0
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (ConwayGovState era) (PParams era)
cgsPrevPParamsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
curPParams
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (ConwayGovState era) (FuturePParams era)
cgsFuturePParamsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall a. Maybe a
Nothing

    allRemovedGovActions :: Map GovActionId (GovActionState era)
allRemovedGovActions = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map GovActionId (GovActionState era)
expiredActions, Map GovActionId (GovActionState era)
enactedActions, Map GovActionId (GovActionState era)
removedDueToEnactment]
    (UMap
newUMap, Map GovActionId Coin
unclaimed) =
      forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era) -> UMap -> (UMap, Map GovActionId Coin)
returnProposalDeposits Map GovActionId (GovActionState era)
allRemovedGovActions forall a b. (a -> b) -> a -> b
$
        DState era
dState2 forall s a. s -> Getting a s a -> a
^. forall era. Lens' (DState era) UMap
dsUnifiedL

  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$
    forall era.
Set (GovActionState era)
-> Set (GovActionState era)
-> Set (GovActionState era)
-> Map GovActionId Coin
-> ConwayEpochEvent era
GovInfoEvent
      (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map GovActionId (GovActionState era)
enactedActions)
      (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map GovActionId (GovActionState era)
removedDueToEnactment)
      (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map GovActionId (GovActionState era)
expiredActions)
      Map GovActionId Coin
unclaimed

  let
    certState :: CertState era
certState =
      CertState
        { certPState :: PState era
certPState = PState era
pState2
        , certDState :: DState era
certDState = DState era
dState2 forall a b. a -> (a -> b) -> b
& forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap
newUMap
        , certVState :: VState era
certVState =
            -- Increment the dormant epoch counter
            forall era. EpochNo -> Proposals era -> VState era -> VState era
updateNumDormantEpochs Signal (ConwayEPOCH era)
eNo Proposals era
newProposals VState era
vState
              -- Remove cold credentials of committee members that were removed or were invalid
              forall a b. a -> (a -> b) -> b
& forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall era.
StrictMaybe (Committee era)
-> CommitteeState era -> CommitteeState era
updateCommitteeState (ConwayGovState era
govState1 forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (ConwayGovState era) (StrictMaybe (Committee era))
cgsCommitteeL)
        }
    accountState3 :: AccountState
accountState3 =
      AccountState
accountState2
        -- Move donations and unclaimed rewards from proposals to treasury:
        forall a b. a -> (a -> b) -> b
& Lens' AccountState Coin
asTreasuryL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ (UTxOState era
utxoState0 forall s a. s -> Getting a s a -> a
^. forall era. Lens' (UTxOState era) Coin
utxosDonationL forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map GovActionId Coin
unclaimed)
    utxoState2 :: UTxOState era
utxoState2 =
      UTxOState era
utxoState1
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (UTxOState era) Coin
utxosDepositedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. EraGov era => CertState era -> GovState era -> Coin
totalObligation CertState era
certState ConwayGovState era
govState1
        -- Clear the donations field:
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (UTxOState era) Coin
utxosDonationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t. Val t => t
zero
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ConwayGovState era
govState1
    ledgerState1 :: LedgerState era
ledgerState1 =
      LedgerState era
ledgerState0
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ CertState era
certState
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UTxOState era
utxoState2
    epochState1 :: EpochState era
epochState1 =
      State (ConwayEPOCH era)
epochState0
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (EpochState era) AccountState
esAccountStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ AccountState
accountState3
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (EpochState era) SnapShots
esSnapshotsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ SnapShots
snapshots1
        forall a b. a -> (a -> b) -> b
& forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ LedgerState era
ledgerState1
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. RatifyState era -> ConwayEpochEvent era
EpochBoundaryRatifyState RatifyState era
ratifyState
  EpochState era
epochState2 <- do
    let curPv :: ProtVer
curPv = EpochState era
epochState1 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
    if ProtVer
curPv forall a. Eq a => a -> a -> Bool
/= EpochState era
epochState1 forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
      then forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "HARDFORK" era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), EpochState era
epochState1, ProtVer
curPv)
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
epochState1
  forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall era (m :: * -> *).
(GovState era ~ ConwayGovState era, Monad m, RunConwayRatify era,
 ConwayEraGov era) =>
EpochNo
-> PoolDistr
-> EpochState era
-> ReaderT Globals m (EpochState era)
setFreshDRepPulsingState Signal (ConwayEPOCH era)
eNo PoolDistr
stakePoolDistr EpochState era
epochState2

instance
  ( Era era
  , STS (ShelleyPOOLREAP era)
  , PredicateFailure (EraRule "POOLREAP" era) ~ ShelleyPoolreapPredFailure era
  , Event (EraRule "POOLREAP" era) ~ ShelleyPoolreapEvent era
  ) =>
  Embed (ShelleyPOOLREAP era) (ConwayEPOCH era)
  where
  wrapFailed :: PredicateFailure (ShelleyPOOLREAP era)
-> PredicateFailure (ConwayEPOCH era)
wrapFailed = \case {}
  wrapEvent :: Event (ShelleyPOOLREAP era) -> Event (ConwayEPOCH era)
wrapEvent = forall era. Event (EraRule "POOLREAP" era) -> ConwayEpochEvent era
PoolReapEvent

instance
  ( EraTxOut era
  , PredicateFailure (EraRule "SNAP" era) ~ ShelleySnapPredFailure era
  , Event (EraRule "SNAP" era) ~ Shelley.SnapEvent era
  ) =>
  Embed (ShelleySNAP era) (ConwayEPOCH era)
  where
  wrapFailed :: PredicateFailure (ShelleySNAP era)
-> PredicateFailure (ConwayEPOCH era)
wrapFailed = \case {}
  wrapEvent :: Event (ShelleySNAP era) -> Event (ConwayEPOCH era)
wrapEvent = forall era. Event (EraRule "SNAP" era) -> ConwayEpochEvent era
SnapEvent

instance
  ( EraGov era
  , PredicateFailure (ConwayRATIFY era) ~ Void
  , STS (ConwayRATIFY era)
  , BaseM (ConwayRATIFY era) ~ ShelleyBase
  , Event (ConwayRATIFY era) ~ Void
  ) =>
  Embed (ConwayRATIFY era) (ConwayEPOCH era)
  where
  wrapFailed :: PredicateFailure (ConwayRATIFY era)
-> PredicateFailure (ConwayEPOCH era)
wrapFailed = forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayRATIFY era) -> Event (ConwayEPOCH era)
wrapEvent = forall a. Void -> a
absurd

instance
  ( EraGov era
  , PredicateFailure (ConwayHARDFORK era) ~ Void
  , STS (ConwayHARDFORK era)
  , BaseM (ConwayHARDFORK era) ~ ShelleyBase
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  ) =>
  Embed (ConwayHARDFORK era) (ConwayEPOCH era)
  where
  wrapFailed :: PredicateFailure (ConwayHARDFORK era)
-> PredicateFailure (ConwayEPOCH era)
wrapFailed = forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayHARDFORK era) -> Event (ConwayEPOCH era)
wrapEvent = forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent

updateCommitteeState :: StrictMaybe (Committee era) -> CommitteeState era -> CommitteeState era
updateCommitteeState :: forall era.
StrictMaybe (Committee era)
-> CommitteeState era -> CommitteeState era
updateCommitteeState StrictMaybe (Committee era)
committee (CommitteeState Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
creds) =
  forall era.
Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
-> CommitteeState era
CommitteeState forall a b. (a -> b) -> a -> b
$ forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
creds Map (Credential 'ColdCommitteeRole) EpochNo
members
  where
    members :: Map (Credential 'ColdCommitteeRole) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era -> Map (Credential 'ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee