{-# 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 (EraCrypto era)) 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 c) = ConwayEpochEvent (ConwayEra c)

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 (EraCrypto era)
  , 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 (EraCrypto era),
 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 (EraCrypto era) ->
  (UMap (EraCrypto era), Map.Map (GovActionId (EraCrypto era)) Coin)
returnProposalDeposits :: forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era)
-> UMap (EraCrypto era)
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
returnProposalDeposits f (GovActionState era)
removedProposals UMap (EraCrypto era)
oldUMap =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' forall {era}.
GovActionState era
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
processProposal (UMap (EraCrypto era)
oldUMap, forall a. Monoid a => a
mempty) f (GovActionState era)
removedProposals
  where
    processProposal :: GovActionState era
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
processProposal GovActionState era
gas (UMap (EraCrypto era)
um, Map (GovActionId (EraCrypto era)) Coin
unclaimed)
      | forall k c v. k -> UView c k v -> Bool
UMap.member (forall c. RewardAccount c -> Credential 'Staking c
raCredential (forall era. GovActionState era -> RewardAccount (EraCrypto era)
gasReturnAddr GovActionState era
gas)) (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
um) =
          ( forall k c. (RDPair -> RDPair) -> k -> UView c k RDPair -> UMap c
UMap.adjust
              (Coin -> RDPair -> RDPair
addReward (forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas))
              (forall c. RewardAccount c -> Credential 'Staking c
raCredential (forall era. GovActionState era -> RewardAccount (EraCrypto era)
gasReturnAddr GovActionState era
gas))
              (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
um)
          , Map (GovActionId (EraCrypto era)) Coin
unclaimed
          )
      | Bool
otherwise = (UMap (EraCrypto era)
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId GovActionState era
gas) (forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas) Map (GovActionId (EraCrypto era)) 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 (EraCrypto era)) (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 (EraCrypto era)) Coin
enactedWithdrawals = EnactState era
enactedState forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (EnactState era) (Map (Credential 'Staking (EraCrypto era)) Coin)
ensWithdrawalsL
      rewardsUView :: UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewardsUView = forall c. UMap c -> UView c (Credential 'Staking c) 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 (EraCrypto era))
dsUnifiedL
      successfulWithdrawls :: Map (Credential 'Staking (EraCrypto era)) Coin
successfulWithdrawls = UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewardsUView forall c k v u. UView c k v -> Map k u -> Map k u
◁ Map (Credential 'Staking (EraCrypto era)) 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 (EraCrypto era)) 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 (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (UView (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewardsUView forall c.
UView c (Credential 'Staking c) RDPair
-> Map (Credential 'Staking c) (CompactForm Coin) -> UMap c
∪+ (HasCallStack => Coin -> CompactForm Coin
compactCoinOrError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Credential 'Staking (EraCrypto era)) 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 (EraCrypto era)) 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 (EraCrypto era)
  , 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 (EraCrypto era),
 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 (EraCrypto era)
esSnapshots = SnapShots (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era)
snapshots0, ())

  -- Activate future StakePools
  let newStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
newStakePoolParams = forall s t. Embed s t => Exp t -> s
eval (forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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 (EraCrypto era)) (PoolParams (EraCrypto era))
psFutureStakePoolParams PState era
pState0)
      pState1 :: PState era
pState1 =
        PState era
pState0
          { psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
newStakePoolParams
          , psFutureStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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 (EraCrypto era)
stakePoolDistr = forall c. SnapShots c -> PoolDistr c
ssStakeMarkPoolDistr SnapShots (EraCrypto era)
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 (EraCrypto era))
rsExpired :: forall era. RatifyState era -> Set (GovActionId (EraCrypto era))
rsExpired :: Set (GovActionId (EraCrypto era))
rsExpired} =
      forall era. DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulsingState

    (AccountState
accountState2, DState era
dState2, EnactState {Map (Credential 'Staking (EraCrypto era)) 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 (EraCrypto era)) 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 (EraCrypto era)) 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 (EraCrypto era)) (GovActionState era)
enactedActions, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedDueToEnactment, Map (GovActionId (EraCrypto era)) (GovActionState era)
expiredActions) =
      forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment Seq (GovActionState era)
rsEnacted Set (GovActionId (EraCrypto era))
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 (EraCrypto era)) (GovActionState era)
allRemovedGovActions = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map (GovActionId (EraCrypto era)) (GovActionState era)
expiredActions, Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedActions, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedDueToEnactment]
    (UMap (EraCrypto era)
newUMap, Map (GovActionId (EraCrypto era)) Coin
unclaimed) =
      forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era)
-> UMap (EraCrypto era)
-> (UMap (EraCrypto era), Map (GovActionId (EraCrypto era)) Coin)
returnProposalDeposits Map (GovActionId (EraCrypto era)) (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 (EraCrypto era))
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 (EraCrypto era)) 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 (EraCrypto era)) (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 (EraCrypto era)) (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 (EraCrypto era)) (GovActionState era)
expiredActions)
      Map (GovActionId (EraCrypto era)) 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 (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap (EraCrypto era)
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 (EraCrypto era)) 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 (EraCrypto era))
esSnapshotsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ SnapShots (EraCrypto era)
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 (EraCrypto era)
-> EpochState era
-> ReaderT Globals m (EpochState era)
setFreshDRepPulsingState Signal (ConwayEPOCH era)
eNo PoolDistr (EraCrypto era)
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 (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
creds) =
  forall era.
Map
  (Credential 'ColdCommitteeRole (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
-> 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 (EraCrypto era))
  (CommitteeAuthorization (EraCrypto era))
creds Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members
  where
    members :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers StrictMaybe (Committee era)
committee