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

module Cardano.Ledger.Conway.Rules.NewEpoch (
  ConwayNEWEPOCH,
  ConwayNewEpochEvent (..),
) where

import Cardano.Ledger.BaseTypes (
  BlocksMade (BlocksMade),
  ShelleyBase,
  StrictMaybe (SJust, SNothing),
 )
import Cardano.Ledger.Coin (toDeltaCoin)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEPOCH, ConwayEra, ConwayNEWEPOCH)
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov,
  ConwayGovState,
  RatifyEnv (..),
  RatifySignal (..),
  RatifyState (..),
  newEpochStateDRepPulsingStateL,
  predictFuturePParams,
  pulseDRepPulsingState,
 )
import Cardano.Ledger.Conway.Rules.Epoch (ConwayEpochEvent)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.AdaPots (AdaPots (..), totalAdaPotsES)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rewards (sumRewards)
import Cardano.Ledger.Shelley.Rules (
  RupdEvent (..),
  ShelleyTICK,
  ShelleyTickEvent (..),
  ShelleyTickPredFailure (..),
 )
import Cardano.Ledger.Slot (EpochNo (EpochNo))
import Cardano.Ledger.State
import qualified Cardano.Ledger.Val as Val
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Control.State.Transition
import Data.Default (Default (..))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (^.))

data ConwayNewEpochEvent era
  = DeltaRewardEvent !(Event (EraRule "RUPD" era))
  | RestrainedRewards
      !EpochNo
      !(Map.Map (Credential 'Staking) (Set Reward))
      !(Set (Credential 'Staking))
  | TotalRewardEvent
      !EpochNo
      !(Map.Map (Credential 'Staking) (Set Reward))
  | EpochEvent !(Event (EraRule "EPOCH" era))
  | TotalAdaPotsEvent !AdaPots
  deriving ((forall x.
 ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x)
-> (forall x.
    Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era)
-> Generic (ConwayNewEpochEvent era)
forall x.
Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era
forall x.
ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era
forall era x.
ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x
$cfrom :: forall era x.
ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x
from :: forall x.
ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x
$cto :: forall era x.
Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era
to :: forall x.
Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era
Generic)

type instance EraRuleEvent "NEWEPOCH" ConwayEra = ConwayNewEpochEvent ConwayEra

deriving instance
  ( Eq (Event (EraRule "EPOCH" era))
  , Eq (Event (EraRule "RUPD" era))
  ) =>
  Eq (ConwayNewEpochEvent era)

instance
  ( NFData (Event (EraRule "EPOCH" era))
  , NFData (Event (EraRule "RUPD" era))
  ) =>
  NFData (ConwayNewEpochEvent era)

instance
  ( EraTxOut era
  , ConwayEraGov era
  , EraStake era
  , EraCertState era
  , Embed (EraRule "EPOCH" era) (ConwayNEWEPOCH era)
  , Event (EraRule "RUPD" era) ~ RupdEvent
  , Environment (EraRule "EPOCH" era) ~ ()
  , State (EraRule "EPOCH" era) ~ EpochState era
  , Signal (EraRule "EPOCH" era) ~ EpochNo
  , Default (EpochState era)
  , Default (StashedAVVMAddresses era)
  , Signal (EraRule "RATIFY" era) ~ RatifySignal era
  , State (EraRule "RATIFY" era) ~ RatifyState era
  , Environment (EraRule "RATIFY" era) ~ RatifyEnv era
  , GovState era ~ ConwayGovState era
  , Eq (PredicateFailure (EraRule "RATIFY" era))
  , Show (PredicateFailure (EraRule "RATIFY" era))
  , Eq (PredicateFailure (ConwayNEWEPOCH era))
  , Show (PredicateFailure (ConwayNEWEPOCH era))
  ) =>
  STS (ConwayNEWEPOCH era)
  where
  type State (ConwayNEWEPOCH era) = NewEpochState era
  type Signal (ConwayNEWEPOCH era) = EpochNo
  type Environment (ConwayNEWEPOCH era) = ()
  type BaseM (ConwayNEWEPOCH era) = ShelleyBase
  type PredicateFailure (ConwayNEWEPOCH era) = Void
  type Event (ConwayNEWEPOCH era) = ConwayNewEpochEvent era

  initialRules :: [InitialRule (ConwayNEWEPOCH era)]
initialRules =
    [ State (ConwayNEWEPOCH era) -> InitialRule (ConwayNEWEPOCH era)
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Initial) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (State (ConwayNEWEPOCH era) -> InitialRule (ConwayNEWEPOCH era))
-> State (ConwayNEWEPOCH era) -> InitialRule (ConwayNEWEPOCH era)
forall a b. (a -> b) -> a -> b
$
        EpochNo
-> BlocksMade
-> BlocksMade
-> EpochState era
-> StrictMaybe PulsingRewUpdate
-> PoolDistr
-> StashedAVVMAddresses era
-> NewEpochState era
forall era.
EpochNo
-> BlocksMade
-> BlocksMade
-> EpochState era
-> StrictMaybe PulsingRewUpdate
-> PoolDistr
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
          (Word64 -> EpochNo
EpochNo Word64
0)
          (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Natural
forall k a. Map k a
Map.empty)
          (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Natural
forall k a. Map k a
Map.empty)
          EpochState era
forall a. Default a => a
def
          StrictMaybe PulsingRewUpdate
forall a. StrictMaybe a
SNothing
          (Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Map k a
Map.empty CompactForm Coin
forall a. Monoid a => a
mempty)
          StashedAVVMAddresses era
forall a. Default a => a
def
    ]

  transitionRules :: [TransitionRule (ConwayNEWEPOCH era)]
transitionRules = [TransitionRule (ConwayNEWEPOCH era)
forall era.
(EraTxOut era, ConwayEraGov era, EraCertState era,
 Embed (EraRule "EPOCH" era) (ConwayNEWEPOCH era),
 Environment (EraRule "EPOCH" era) ~ (),
 State (EraRule "EPOCH" era) ~ EpochState era,
 Signal (EraRule "EPOCH" era) ~ EpochNo,
 Default (StashedAVVMAddresses era),
 Event (EraRule "RUPD" era) ~ RupdEvent,
 Signal (EraRule "RATIFY" era) ~ RatifySignal era,
 State (EraRule "RATIFY" era) ~ RatifyState era,
 Environment (EraRule "RATIFY" era) ~ RatifyEnv era,
 GovState era ~ ConwayGovState era,
 Eq (PredicateFailure (EraRule "RATIFY" era)),
 Show (PredicateFailure (EraRule "RATIFY" era)),
 Eq (PredicateFailure (ConwayNEWEPOCH era)),
 Show (PredicateFailure (ConwayNEWEPOCH era))) =>
TransitionRule (ConwayNEWEPOCH era)
newEpochTransition]

newEpochTransition ::
  forall era.
  ( EraTxOut era
  , ConwayEraGov era
  , EraCertState era
  , Embed (EraRule "EPOCH" era) (ConwayNEWEPOCH era)
  , Environment (EraRule "EPOCH" era) ~ ()
  , State (EraRule "EPOCH" era) ~ EpochState era
  , Signal (EraRule "EPOCH" era) ~ EpochNo
  , Default (StashedAVVMAddresses era)
  , Event (EraRule "RUPD" era) ~ RupdEvent
  , Signal (EraRule "RATIFY" era) ~ RatifySignal era
  , State (EraRule "RATIFY" era) ~ RatifyState era
  , Environment (EraRule "RATIFY" era) ~ RatifyEnv era
  , GovState era ~ ConwayGovState era
  , Eq (PredicateFailure (EraRule "RATIFY" era))
  , Show (PredicateFailure (EraRule "RATIFY" era))
  , Eq (PredicateFailure (ConwayNEWEPOCH era))
  , Show (PredicateFailure (ConwayNEWEPOCH era))
  ) =>
  TransitionRule (ConwayNEWEPOCH era)
newEpochTransition :: forall era.
(EraTxOut era, ConwayEraGov era, EraCertState era,
 Embed (EraRule "EPOCH" era) (ConwayNEWEPOCH era),
 Environment (EraRule "EPOCH" era) ~ (),
 State (EraRule "EPOCH" era) ~ EpochState era,
 Signal (EraRule "EPOCH" era) ~ EpochNo,
 Default (StashedAVVMAddresses era),
 Event (EraRule "RUPD" era) ~ RupdEvent,
 Signal (EraRule "RATIFY" era) ~ RatifySignal era,
 State (EraRule "RATIFY" era) ~ RatifyState era,
 Environment (EraRule "RATIFY" era) ~ RatifyEnv era,
 GovState era ~ ConwayGovState era,
 Eq (PredicateFailure (EraRule "RATIFY" era)),
 Show (PredicateFailure (EraRule "RATIFY" era)),
 Eq (PredicateFailure (ConwayNEWEPOCH era)),
 Show (PredicateFailure (ConwayNEWEPOCH era))) =>
TransitionRule (ConwayNEWEPOCH era)
newEpochTransition = do
  TRC
    ( Environment (ConwayNEWEPOCH era)
_
      , nes :: State (ConwayNEWEPOCH era)
nes@(NewEpochState EpochNo
eL BlocksMade
_ BlocksMade
bcur EpochState era
es0 StrictMaybe PulsingRewUpdate
ru PoolDistr
_ StashedAVVMAddresses era
_)
      , Signal (ConwayNEWEPOCH era)
eNo
      ) <-
    Rule
  (ConwayNEWEPOCH era)
  'Transition
  (RuleContext 'Transition (ConwayNEWEPOCH era))
F (Clause (ConwayNEWEPOCH era) 'Transition)
  (TRC (ConwayNEWEPOCH era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  if EpochNo
Signal (ConwayNEWEPOCH era)
eNo EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
eL
    then
      NewEpochState era
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era)
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era
 -> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era))
-> NewEpochState era
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
        State (ConwayNEWEPOCH era)
NewEpochState era
nes
          NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (DRepPulsingState era -> Identity (DRepPulsingState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL ((DRepPulsingState era -> Identity (DRepPulsingState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (DRepPulsingState era -> DRepPulsingState era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DRepPulsingState era -> DRepPulsingState era
forall era.
EraStake era =>
DRepPulsingState era -> DRepPulsingState era
pulseDRepPulsingState
          NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
(ConwayGovState era -> Identity (ConwayGovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((ConwayGovState era -> Identity (ConwayGovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (ConwayGovState era -> ConwayGovState era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ConwayGovState era -> ConwayGovState era
forall era.
EraStake era =>
ConwayGovState era -> ConwayGovState era
predictFuturePParams
    else do
      EpochState era
es1 <- case StrictMaybe PulsingRewUpdate
ru of -- Here is where we extract the result of Reward pulsing.
        StrictMaybe PulsingRewUpdate
SNothing -> EpochState era
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (EpochState era)
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es0
        SJust p :: PulsingRewUpdate
p@(Pulsing RewardSnapShot
_ Pulser
_) -> do
          (RewardUpdate
ans, Map (Credential 'Staking) (Set Reward)
event) <- BaseM
  (ConwayNEWEPOCH era)
  (RewardUpdate, Map (Credential 'Staking) (Set Reward))
-> Rule
     (ConwayNEWEPOCH era)
     'Transition
     (RewardUpdate, Map (Credential 'Staking) (Set Reward))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (PulsingRewUpdate
-> ShelleyBase
     (RewardUpdate, Map (Credential 'Staking) (Set Reward))
completeRupd PulsingRewUpdate
p)
          ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) 'Transition ()
forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent) =>
ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) rtype ()
tellReward (Event (EraRule "RUPD" era) -> ConwayNewEpochEvent era
forall era. Event (EraRule "RUPD" era) -> ConwayNewEpochEvent era
DeltaRewardEvent (EpochNo -> Map (Credential 'Staking) (Set Reward) -> RupdEvent
RupdEvent EpochNo
Signal (ConwayNEWEPOCH era)
eNo Map (Credential 'Staking) (Set Reward)
event))
          EpochState era
-> EpochNo
-> RewardUpdate
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (EpochState era)
forall era.
(EraGov era, EraCertState era) =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 EpochNo
Signal (ConwayNEWEPOCH era)
eNo RewardUpdate
ans
        SJust (Complete RewardUpdate
ru') -> EpochState era
-> EpochNo
-> RewardUpdate
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (EpochState era)
forall era.
(EraGov era, EraCertState era) =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 EpochNo
Signal (ConwayNEWEPOCH era)
eNo RewardUpdate
ru'
      EpochState era
es2 <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "EPOCH" era) (RuleContext 'Transition (EraRule "EPOCH" era)
 -> Rule
      (ConwayNEWEPOCH era) 'Transition (State (EraRule "EPOCH" era)))
-> RuleContext 'Transition (EraRule "EPOCH" era)
-> Rule
     (ConwayNEWEPOCH era) 'Transition (State (EraRule "EPOCH" era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "EPOCH" era), State (EraRule "EPOCH" era),
 Signal (EraRule "EPOCH" era))
-> TRC (EraRule "EPOCH" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "EPOCH" era)
EpochState era
es1, Signal (EraRule "EPOCH" era)
Signal (ConwayNEWEPOCH era)
eNo)
      let adaPots :: AdaPots
adaPots = EpochState era -> AdaPots
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es2
      Event (ConwayNEWEPOCH era)
-> Rule (ConwayNEWEPOCH era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ConwayNEWEPOCH era)
 -> Rule (ConwayNEWEPOCH era) 'Transition ())
-> Event (ConwayNEWEPOCH era)
-> Rule (ConwayNEWEPOCH era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ AdaPots -> ConwayNewEpochEvent era
forall era. AdaPots -> ConwayNewEpochEvent era
TotalAdaPotsEvent AdaPots
adaPots
      let pd' :: PoolDistr
pd' = SnapShots -> PoolDistr
ssStakeMarkPoolDistr (EpochState era -> SnapShots
forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es0)
      -- See `ShelleyNEWEPOCH` for details on the implementation
      NewEpochState era
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era)
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era
 -> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era))
-> NewEpochState era
-> F (Clause (ConwayNEWEPOCH era) 'Transition) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
        State (ConwayNEWEPOCH era)
nes
          { nesEL = eNo
          , nesBprev = bcur
          , nesBcur = BlocksMade mempty
          , nesEs = es2
          , nesRu = SNothing
          , nesPd = pd'
          }

-- | tell a RupdEvent as a DeltaRewardEvent only if the map is non-empty
tellReward ::
  Event (EraRule "RUPD" era) ~ RupdEvent =>
  ConwayNewEpochEvent era ->
  Rule (ConwayNEWEPOCH era) rtype ()
tellReward :: forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent) =>
ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) rtype ()
tellReward (DeltaRewardEvent (RupdEvent EpochNo
_ Map (Credential 'Staking) (Set Reward)
m)) | Map (Credential 'Staking) (Set Reward) -> Bool
forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking) (Set Reward)
m = () -> F (Clause (ConwayNEWEPOCH era) rtype) ()
forall a. a -> F (Clause (ConwayNEWEPOCH era) rtype) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellReward ConwayNewEpochEvent era
x = Event (ConwayNEWEPOCH era)
-> F (Clause (ConwayNEWEPOCH era) rtype) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent Event (ConwayNEWEPOCH era)
ConwayNewEpochEvent era
x

updateRewards ::
  (EraGov era, EraCertState era) =>
  EpochState era ->
  EpochNo ->
  RewardUpdate ->
  Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards :: forall era.
(EraGov era, EraCertState era) =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es EpochNo
e ru' :: RewardUpdate
ru'@(RewardUpdate DeltaCoin
dt DeltaCoin
dr Map (Credential 'Staking) (Set Reward)
rs_ DeltaCoin
df NonMyopic
_) = do
  let totRs :: Coin
totRs = ProtVer -> Map (Credential 'Staking) (Set Reward) -> Coin
sumRewards (EpochState era
es 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)
prevPParamsEpochStateL ((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) Map (Credential 'Staking) (Set Reward)
rs_
   in Bool
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (DeltaCoin -> Bool
forall t. Val t => t -> Bool
Val.isZero (DeltaCoin
dt DeltaCoin -> DeltaCoin -> DeltaCoin
forall a. Semigroup a => a -> a -> a
<> DeltaCoin
dr DeltaCoin -> DeltaCoin -> DeltaCoin
forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
totRs DeltaCoin -> DeltaCoin -> DeltaCoin
forall a. Semigroup a => a -> a -> a
<> DeltaCoin
df)) (() -> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  let !(!EpochState era
es', FilteredRewards era
filtered) = RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
forall era.
(EraGov era, EraCertState era) =>
RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate
ru' EpochState era
es
  Event (ConwayNEWEPOCH era)
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ConwayNEWEPOCH era)
 -> F (Clause (ConwayNEWEPOCH era) 'Transition) ())
-> Event (ConwayNEWEPOCH era)
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> Set (Credential 'Staking)
-> ConwayNewEpochEvent era
forall era.
EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> Set (Credential 'Staking)
-> ConwayNewEpochEvent era
RestrainedRewards EpochNo
e (FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frShelleyIgnored FilteredRewards era
filtered) (FilteredRewards era -> Set (Credential 'Staking)
forall era. FilteredRewards era -> Set (Credential 'Staking)
frUnregistered FilteredRewards era
filtered)
  -- This event (which is only generated once per epoch) must be generated even if the
  -- map is empty (db-sync depends on it).
  Event (ConwayNEWEPOCH era)
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ConwayNEWEPOCH era)
 -> F (Clause (ConwayNEWEPOCH era) 'Transition) ())
-> Event (ConwayNEWEPOCH era)
-> F (Clause (ConwayNEWEPOCH era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> ConwayNewEpochEvent era
forall era.
EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> ConwayNewEpochEvent era
TotalRewardEvent EpochNo
e (FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered FilteredRewards era
filtered)
  EpochState era
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
forall a. a -> F (Clause (ConwayNEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es'

instance
  ( STS (ConwayNEWEPOCH era)
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , PredicateFailure (EraRule "NEWEPOCH" era) ~ PredicateFailure (ConwayNEWEPOCH era)
  ) =>
  Embed (ConwayNEWEPOCH era) (ShelleyTICK era)
  where
  wrapFailed :: PredicateFailure (ConwayNEWEPOCH era)
-> PredicateFailure (ShelleyTICK era)
wrapFailed = PredicateFailure (EraRule "NEWEPOCH" era)
-> ShelleyTickPredFailure era
PredicateFailure (ConwayNEWEPOCH era)
-> PredicateFailure (ShelleyTICK era)
forall era.
PredicateFailure (EraRule "NEWEPOCH" era)
-> ShelleyTickPredFailure era
NewEpochFailure
  wrapEvent :: Event (ConwayNEWEPOCH era) -> Event (ShelleyTICK era)
wrapEvent = Event (EraRule "NEWEPOCH" era) -> ShelleyTickEvent era
Event (ConwayNEWEPOCH era) -> Event (ShelleyTICK era)
forall era. Event (EraRule "NEWEPOCH" era) -> ShelleyTickEvent era
TickNewEpochEvent

instance
  ( STS (ConwayEPOCH era)
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  ) =>
  Embed (ConwayEPOCH era) (ConwayNEWEPOCH era)
  where
  wrapFailed :: PredicateFailure (ConwayEPOCH era)
-> PredicateFailure (ConwayNEWEPOCH era)
wrapFailed = \case {}
  wrapEvent :: Event (ConwayEPOCH era) -> Event (ConwayNEWEPOCH era)
wrapEvent = Event (EraRule "EPOCH" era) -> ConwayNewEpochEvent era
Event (ConwayEPOCH era) -> Event (ConwayNEWEPOCH era)
forall era. Event (EraRule "EPOCH" era) -> ConwayNewEpochEvent era
EpochEvent