{-# LANGUAGE BangPatterns #-}
{-# 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.Coin (Coin, compactCoinOrError)
import Cardano.Ledger.Compactible (fromCompact)
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.Conway.State
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  UTxOState (..),
  curPParamsEpochStateL,
  esLStateL,
  esSnapshotsL,
  lsCertStateL,
  lsUTxOStateL,
  prevPParamsEpochStateL,
  totalObligation,
  utxosDepositedL,
  utxosDonationL,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.Rewards ()
import Cardano.Ledger.Shelley.Rules (
  ShelleyPOOLREAP,
  ShelleyPoolreapEvent,
  ShelleyPoolreapState (..),
  ShelleySNAP,
  SnapEnv (..),
 )
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Slot (EpochNo)
import Cardano.Ledger.Val (zero, (<->))
import Control.DeepSeq (NFData)
import Control.Monad (guard)
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 x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x)
-> (forall x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era)
-> Generic (ConwayEpochEvent era)
forall x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era
forall x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x
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
$cfrom :: forall era x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x
from :: forall x. ConwayEpochEvent era -> Rep (ConwayEpochEvent era) x
$cto :: forall era x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era
to :: forall x. Rep (ConwayEpochEvent era) x -> ConwayEpochEvent era
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
  , ConwayEraCertState era
  , ConwayEraGov era
  , EraStake era
  , EraCertState 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) ~ ()
  , State (EraRule "POOLREAP" era) ~ ShelleyPoolreapState era
  , Signal (EraRule "POOLREAP" era) ~ EpochNo
  , 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 = [TransitionRule (ConwayEPOCH era)
forall era.
(RunConwayRatify era, ConwayEraCertState era, EraTxOut era,
 Environment (EraRule "SNAP" era) ~ SnapEnv era,
 State (EraRule "SNAP" era) ~ SnapShots,
 Signal (EraRule "SNAP" era) ~ (),
 Embed (EraRule "SNAP" era) (ConwayEPOCH era),
 Embed (EraRule "POOLREAP" era) (ConwayEPOCH era),
 Environment (EraRule "POOLREAP" 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, EraAccounts era) =>
  f (GovActionState era) ->
  Accounts era ->
  (Accounts era, Map.Map GovActionId Coin)
returnProposalDeposits :: forall (f :: * -> *) era.
(Foldable f, EraAccounts era) =>
f (GovActionState era)
-> Accounts era -> (Accounts era, Map GovActionId Coin)
returnProposalDeposits f (GovActionState era)
removedProposals Accounts era
oldAccounts =
  (GovActionState era
 -> (Accounts era, Map GovActionId Coin)
 -> (Accounts era, Map GovActionId Coin))
-> (Accounts era, Map GovActionId Coin)
-> f (GovActionState era)
-> (Accounts era, Map GovActionId Coin)
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' GovActionState era
-> (Accounts era, Map GovActionId Coin)
-> (Accounts era, Map GovActionId Coin)
forall {era} {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 ...),
 EraAccounts era) =>
GovActionState era
-> (Accounts era, Map GovActionId Coin)
-> (Accounts era, Map GovActionId Coin)
processProposal (Accounts era
oldAccounts, Map GovActionId Coin
forall a. Monoid a => a
mempty) f (GovActionState era)
removedProposals
  where
    processProposal :: GovActionState era
-> (Accounts era, Map GovActionId Coin)
-> (Accounts era, Map GovActionId Coin)
processProposal GovActionState era
gas (!Accounts era
accounts, !Map GovActionId Coin
unclaimed)
      | (Just AccountState era
_accountState, Accounts era
newAccounts) <- (AccountState era -> AccountState era)
-> Credential Staking
-> Accounts era
-> (Maybe (AccountState era), Accounts era)
forall era.
EraAccounts era =>
(AccountState era -> AccountState era)
-> Credential Staking
-> Accounts era
-> (Maybe (AccountState era), Accounts era)
updateLookupAccountState AccountState era -> AccountState era
addRefund Credential Staking
cred Accounts era
accounts =
          (Accounts era
newAccounts, Map GovActionId Coin
unclaimed)
      | Bool
otherwise = (Accounts era
accounts, GovActionId -> Coin -> Map GovActionId Coin -> Map GovActionId Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GovActionState era -> GovActionId
forall era. GovActionState era -> GovActionId
gasId GovActionState era
gas) (GovActionState era -> Coin
forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas) Map GovActionId Coin
unclaimed)
      where
        addRefund :: AccountState era -> AccountState era
addRefund = (CompactForm Coin -> Identity (CompactForm Coin))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> AccountState era -> Identity (AccountState era))
-> CompactForm Coin -> AccountState era -> AccountState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError (GovActionState era -> Coin
forall era. GovActionState era -> Coin
gasDeposit GovActionState era
gas)
        cred :: Credential Staking
cred = RewardAccount -> Credential Staking
raCredential (GovActionState era -> RewardAccount
forall era. GovActionState era -> RewardAccount
gasReturnAddr GovActionState era
gas)

-- | 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 OMap GovActionId (GovActionState era) -> Bool
forall a. OMap GovActionId a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OMap GovActionId (GovActionState era) -> Bool)
-> OMap GovActionId (GovActionState era) -> Bool
forall a b. (a -> b) -> a -> b
$ (GovActionState era -> Bool)
-> OMap GovActionId (GovActionState era)
-> OMap GovActionId (GovActionState era)
forall k v. Ord k => (v -> Bool) -> OMap k v -> OMap k v
OMap.filter ((EpochNo
currentEpoch EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
<=) (EpochNo -> Bool)
-> (GovActionState era -> EpochNo) -> GovActionState era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovActionState era -> EpochNo
forall era. GovActionState era -> EpochNo
gasExpiresAfter) (OMap GovActionId (GovActionState era)
 -> OMap GovActionId (GovActionState era))
-> OMap GovActionId (GovActionState era)
-> OMap GovActionId (GovActionState era)
forall a b. (a -> b) -> a -> b
$ Proposals era
ps Proposals era
-> Getting
     (OMap GovActionId (GovActionState era))
     (Proposals era)
     (OMap GovActionId (GovActionState era))
-> OMap GovActionId (GovActionState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (OMap GovActionId (GovActionState era))
  (Proposals era)
  (OMap GovActionId (GovActionState era))
forall era (f :: * -> *).
Functor f =>
(OMap GovActionId (GovActionState era)
 -> f (OMap GovActionId (GovActionState era)))
-> Proposals era -> f (Proposals era)
pPropsL
    then VState era
vState VState era -> (VState era -> VState era) -> VState era
forall a b. a -> (a -> b) -> b
& (EpochNo -> Identity EpochNo)
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo) -> VState era -> f (VState era)
vsNumDormantEpochsL ((EpochNo -> Identity EpochNo)
 -> VState era -> Identity (VState era))
-> (EpochNo -> EpochNo) -> VState era -> VState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ EpochNo -> EpochNo
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 ::
  EraAccounts era =>
  ChainAccountState ->
  DState era ->
  EnactState era ->
  (ChainAccountState, DState era, EnactState era)
applyEnactedWithdrawals :: forall era.
EraAccounts era =>
ChainAccountState
-> DState era
-> EnactState era
-> (ChainAccountState, DState era, EnactState era)
applyEnactedWithdrawals ChainAccountState
chainAccountState DState era
dState EnactState era
enactedState =
  let enactedWithdrawals :: Map (Credential Staking) Coin
enactedWithdrawals = EnactState era
enactedState EnactState era
-> Getting
     (Map (Credential Staking) Coin)
     (EnactState era)
     (Map (Credential Staking) Coin)
-> Map (Credential Staking) Coin
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) Coin)
  (EnactState era)
  (Map (Credential Staking) Coin)
forall era (f :: * -> *).
Functor f =>
(Map (Credential Staking) Coin
 -> f (Map (Credential Staking) Coin))
-> EnactState era -> f (EnactState era)
ensWithdrawalsL
      accounts :: Accounts era
accounts = DState era
dState DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
      -- 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.
      successfulWithdrawls :: Map (Credential Staking) (CompactForm Coin)
successfulWithdrawls =
        (Credential Staking -> Coin -> Maybe (CompactForm Coin))
-> Map (Credential Staking) Coin
-> Map (Credential Staking) (CompactForm Coin)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey
          (\Credential Staking
cred Coin
w -> HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError Coin
w CompactForm Coin -> Maybe () -> Maybe (CompactForm Coin)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred Accounts era
accounts))
          Map (Credential Staking) Coin
enactedWithdrawals
      chainAccountState' :: ChainAccountState
chainAccountState' =
        ChainAccountState
chainAccountState
          -- 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
          ChainAccountState
-> (ChainAccountState -> ChainAccountState) -> ChainAccountState
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> ChainAccountState -> Identity ChainAccountState
Lens' ChainAccountState Coin
casTreasuryL ((Coin -> Identity Coin)
 -> ChainAccountState -> Identity ChainAccountState)
-> (Coin -> Coin) -> ChainAccountState -> ChainAccountState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) (CompactForm Coin)
successfulWithdrawls))
      dState' :: DState era
dState' = DState era
dState DState era -> (DState era -> DState era) -> DState era
forall a b. a -> (a -> b) -> b
& (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> DState era -> Identity (DState era))
-> (Accounts era -> Accounts era) -> DState era -> DState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (Credential Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts Map (Credential Staking) (CompactForm Coin)
successfulWithdrawls
      -- Reset enacted withdrawals:
      enactedState' :: EnactState era
enactedState' =
        EnactState era
enactedState
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) Coin
 -> Identity (Map (Credential Staking) Coin))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential Staking) Coin
 -> f (Map (Credential Staking) Coin))
-> EnactState era -> f (EnactState era)
ensWithdrawalsL ((Map (Credential Staking) Coin
  -> Identity (Map (Credential Staking) Coin))
 -> EnactState era -> Identity (EnactState era))
-> Map (Credential Staking) Coin
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential Staking) Coin
forall k a. Map k a
Map.empty
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> EnactState era -> f (EnactState era)
ensTreasuryL ((Coin -> Identity Coin)
 -> EnactState era -> Identity (EnactState era))
-> Coin -> EnactState era -> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall a. Monoid a => a
mempty
   in (ChainAccountState
chainAccountState', DState era
dState', EnactState era
enactedState')

epochTransition ::
  forall era.
  ( RunConwayRatify era
  , ConwayEraCertState era
  , EraTxOut era
  , Environment (EraRule "SNAP" era) ~ SnapEnv era
  , State (EraRule "SNAP" era) ~ SnapShots
  , Signal (EraRule "SNAP" era) ~ ()
  , Embed (EraRule "SNAP" era) (ConwayEPOCH era)
  , Embed (EraRule "POOLREAP" era) (ConwayEPOCH era)
  , Environment (EraRule "POOLREAP" 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, ConwayEraCertState era, EraTxOut era,
 Environment (EraRule "SNAP" era) ~ SnapEnv era,
 State (EraRule "SNAP" era) ~ SnapShots,
 Signal (EraRule "SNAP" era) ~ (),
 Embed (EraRule "SNAP" era) (ConwayEPOCH era),
 Embed (EraRule "POOLREAP" era) (ConwayEPOCH era),
 Environment (EraRule "POOLREAP" 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@EpochState
          { esSnapshots = snapshots0
          , esLState = ledgerState0
          }
      , eNo
      ) <-
    Rule
  (ConwayEPOCH era)
  'Transition
  (RuleContext 'Transition (ConwayEPOCH era))
F (Clause (ConwayEPOCH era) 'Transition) (TRC (ConwayEPOCH era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let chainAccountState0 = State (ConwayEPOCH era)
EpochState era
epochState0 EpochState era
-> Getting ChainAccountState (EpochState era) ChainAccountState
-> ChainAccountState
forall s a. s -> Getting a s a -> a
^. Getting ChainAccountState (EpochState era) ChainAccountState
forall era. Lens' (EpochState era) ChainAccountState
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) ChainAccountState
chainAccountStateL
      govState0 = UTxOState era -> GovState era
forall era. UTxOState era -> GovState era
utxosGovState UTxOState era
utxoState0
      curPParams = GovState era
ConwayGovState era
govState0 ConwayGovState era
-> Getting (PParams era) (ConwayGovState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const (PParams era) (PParams era))
-> GovState era -> Const (PParams era) (GovState era)
Getting (PParams era) (ConwayGovState era) (PParams era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL
      utxoState0 = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState0
      certState0 = LedgerState era
ledgerState0 LedgerState era
-> Getting (CertState era) (LedgerState era) (CertState era)
-> CertState era
forall s a. s -> Getting a s a -> a
^. Getting (CertState era) (LedgerState era) (CertState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
      vState = CertState era
certState0 CertState era
-> Getting (VState era) (CertState era) (VState era) -> VState era
forall s a. s -> Getting a s a -> a
^. Getting (VState era) (CertState era) (VState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL
  snapshots1 <-
    trans @(EraRule "SNAP" era) $ TRC (SnapEnv ledgerState0 curPParams, snapshots0, ())

  PoolreapState utxoState1 chainAccountState1 certState1 <-
    trans @(EraRule "POOLREAP" era) $
      TRC ((), PoolreapState utxoState0 chainAccountState0 certState0, eNo)

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

    ratifyState@RatifyState {rsEnactState, rsEnacted, rsExpired} =
      extractDRepPulsingState pulsingState

    (chainAccountState2, dState2, EnactState {..}) =
      applyEnactedWithdrawals chainAccountState1 (certState1 ^. certDStateL) 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.
    (newProposals, enactedActions, removedDueToEnactment, expiredActions) =
      proposalsApplyEnactment rsEnacted rsExpired (govState0 ^. proposalsGovStateL)

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

    allRemovedGovActions = [Map GovActionId (GovActionState era)]
-> Map GovActionId (GovActionState era)
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]
    (newAccounts, unclaimed) =
      returnProposalDeposits allRemovedGovActions $ dState2 ^. accountsL
  tellEvent $
    GovInfoEvent
      (Set.fromList $ Map.elems enactedActions)
      (Set.fromList $ Map.elems removedDueToEnactment)
      (Set.fromList $ Map.elems expiredActions)
      unclaimed

  let
    certState2 =
      VState era -> PState era -> DState era -> CertState era
forall era.
ConwayEraCertState era =>
VState era -> PState era -> DState era -> CertState era
mkConwayCertState
        -- Increment the dormant epoch counter
        ( EpochNo -> Proposals era -> VState era -> VState era
forall era. EpochNo -> Proposals era -> VState era -> VState era
updateNumDormantEpochs EpochNo
Signal (ConwayEPOCH era)
eNo Proposals era
newProposals VState era
vState
            -- Remove cold credentials of committee members that were removed or were invalid
            VState era -> (VState era -> VState era) -> VState era
forall a b. a -> (a -> b) -> b
& (CommitteeState era -> Identity (CommitteeState era))
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(CommitteeState era -> f (CommitteeState era))
-> VState era -> f (VState era)
vsCommitteeStateL ((CommitteeState era -> Identity (CommitteeState era))
 -> VState era -> Identity (VState era))
-> (CommitteeState era -> CommitteeState era)
-> VState era
-> VState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ StrictMaybe (Committee era)
-> CommitteeState era -> CommitteeState era
forall era.
StrictMaybe (Committee era)
-> CommitteeState era -> CommitteeState era
updateCommitteeState (ConwayGovState era
govState1 ConwayGovState era
-> Getting
     (StrictMaybe (Committee era))
     (ConwayGovState era)
     (StrictMaybe (Committee era))
-> StrictMaybe (Committee era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Committee era))
  (ConwayGovState era)
  (StrictMaybe (Committee era))
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (Committee era) -> f (StrictMaybe (Committee era)))
-> ConwayGovState era -> f (ConwayGovState era)
cgsCommitteeL)
        )
        (CertState era
certState1 CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
        (DState era
dState2 DState era -> (DState era -> DState era) -> DState era
forall a b. a -> (a -> b) -> b
& (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> DState era -> Identity (DState era))
-> Accounts era -> DState era -> DState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Accounts era
newAccounts)
    chainAccountState3 =
      ChainAccountState
chainAccountState2
        -- Move donations and unclaimed rewards from proposals to treasury:
        ChainAccountState
-> (ChainAccountState -> ChainAccountState) -> ChainAccountState
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> ChainAccountState -> Identity ChainAccountState
Lens' ChainAccountState Coin
casTreasuryL ((Coin -> Identity Coin)
 -> ChainAccountState -> Identity ChainAccountState)
-> Coin -> ChainAccountState -> ChainAccountState
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ (UTxOState era
utxoState0 UTxOState era -> Getting Coin (UTxOState era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (UTxOState era) Coin
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDonationL Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Map GovActionId Coin -> Coin
forall m. Monoid m => Map GovActionId m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map GovActionId Coin
unclaimed)
    utxoState2 =
      UTxOState era
utxoState1
        UTxOState era -> (UTxOState era -> UTxOState era) -> UTxOState era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL ((Coin -> Identity Coin)
 -> UTxOState era -> Identity (UTxOState era))
-> Coin -> UTxOState era -> UTxOState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CertState era -> GovState era -> Coin
forall era.
(EraGov era, EraCertState era) =>
CertState era -> GovState era -> Coin
totalObligation CertState era
certState2 GovState era
ConwayGovState era
govState1
        -- Clear the donations field:
        UTxOState era -> (UTxOState era -> UTxOState era) -> UTxOState era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDonationL ((Coin -> Identity Coin)
 -> UTxOState era -> Identity (UTxOState era))
-> Coin -> UTxOState era -> UTxOState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall t. Val t => t
zero
        UTxOState era -> (UTxOState era -> UTxOState era) -> UTxOState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> UTxOState era -> Identity (UTxOState era)
(ConwayGovState era -> Identity (ConwayGovState era))
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL ((ConwayGovState era -> Identity (ConwayGovState era))
 -> UTxOState era -> Identity (UTxOState era))
-> ConwayGovState era -> UTxOState era -> UTxOState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ConwayGovState era
govState1
    ledgerState1 =
      LedgerState era
ledgerState0
        LedgerState era
-> (LedgerState era -> LedgerState era) -> LedgerState era
forall a b. a -> (a -> b) -> b
& (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> CertState era -> LedgerState era -> LedgerState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CertState era
certState2
        LedgerState era
-> (LedgerState era -> LedgerState era) -> LedgerState era
forall a b. a -> (a -> b) -> b
& (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> UTxOState era -> LedgerState era -> LedgerState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UTxOState era
utxoState2
    epochState1 =
      State (ConwayEPOCH era)
EpochState era
epochState0
        EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (ChainAccountState -> Identity ChainAccountState)
-> EpochState era -> Identity (EpochState era)
forall era. Lens' (EpochState era) ChainAccountState
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) ChainAccountState
chainAccountStateL ((ChainAccountState -> Identity ChainAccountState)
 -> EpochState era -> Identity (EpochState era))
-> ChainAccountState -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ChainAccountState
chainAccountState3
        EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (SnapShots -> Identity SnapShots)
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(SnapShots -> f SnapShots) -> EpochState era -> f (EpochState era)
esSnapshotsL ((SnapShots -> Identity SnapShots)
 -> EpochState era -> Identity (EpochState era))
-> SnapShots -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SnapShots
snapshots1
        EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> LedgerState era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LedgerState era
ledgerState1
  tellEvent $ EpochBoundaryRatifyState ratifyState
  epochState2 <- do
    let curPv = EpochState era
epochState1 EpochState era
-> Getting ProtVer (EpochState era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const ProtVer (PParams era))
-> EpochState era -> Const ProtVer (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const ProtVer (PParams era))
 -> EpochState era -> Const ProtVer (EpochState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> PParams era -> Const ProtVer (PParams era))
-> Getting ProtVer (EpochState era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> PParams era -> Const ProtVer (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
    if curPv /= epochState1 ^. prevPParamsEpochStateL . ppProtocolVersionL
      then trans @(EraRule "HARDFORK" era) $ TRC ((), epochState1, curPv)
      else pure epochState1
  liftSTS $ setFreshDRepPulsingState eNo stakePoolDistr epochState2

instance
  ( Era era
  , STS (ShelleyPOOLREAP 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 = Event (EraRule "POOLREAP" era) -> ConwayEpochEvent era
Event (ShelleyPOOLREAP era) -> Event (ConwayEPOCH era)
forall era. Event (EraRule "POOLREAP" era) -> ConwayEpochEvent era
PoolReapEvent

instance
  ( EraTxOut era
  , EraStake era
  , EraCertState 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 = Event (EraRule "SNAP" era) -> ConwayEpochEvent era
Event (ShelleySNAP era) -> Event (ConwayEPOCH era)
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 = Void -> Void
PredicateFailure (ConwayRATIFY era)
-> PredicateFailure (ConwayEPOCH era)
forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayRATIFY era) -> Event (ConwayEPOCH era)
wrapEvent = Void -> ConwayEpochEvent era
Event (ConwayRATIFY era) -> Event (ConwayEPOCH era)
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 = Void -> Void
PredicateFailure (ConwayHARDFORK era)
-> PredicateFailure (ConwayEPOCH era)
forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayHARDFORK era) -> Event (ConwayEPOCH era)
wrapEvent = Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
Event (ConwayHARDFORK era) -> Event (ConwayEPOCH era)
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) =
  Map (Credential ColdCommitteeRole) CommitteeAuthorization
-> CommitteeState era
forall era.
Map (Credential ColdCommitteeRole) CommitteeAuthorization
-> CommitteeState era
CommitteeState (Map (Credential ColdCommitteeRole) CommitteeAuthorization
 -> CommitteeState era)
-> Map (Credential ColdCommitteeRole) CommitteeAuthorization
-> CommitteeState era
forall a b. (a -> b) -> a -> b
$ Map (Credential ColdCommitteeRole) CommitteeAuthorization
-> Map (Credential ColdCommitteeRole) EpochNo
-> Map (Credential ColdCommitteeRole) CommitteeAuthorization
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 = (Committee era -> Map (Credential ColdCommitteeRole) EpochNo)
-> StrictMaybe (Committee era)
-> Map (Credential ColdCommitteeRole) EpochNo
forall m a. Monoid m => (a -> m) -> StrictMaybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Committee era -> Map (Credential ColdCommitteeRole) EpochNo
forall era.
Committee era -> Map (Credential ColdCommitteeRole) EpochNo
committeeMembers StrictMaybe (Committee era)
committee

instance InjectRuleEvent "EPOCH" ConwayHardForkEvent ConwayEra where
  injectEvent :: ConwayHardForkEvent ConwayEra -> EraRuleEvent "EPOCH" ConwayEra
injectEvent = Event (EraRule "HARDFORK" ConwayEra) -> ConwayEpochEvent ConwayEra
ConwayHardForkEvent ConwayEra -> EraRuleEvent "EPOCH" ConwayEra
forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent