{-# 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 (
  NEWEPOCH,
  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 (ConwayEra, EPOCH, NEWEPOCH)
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov,
  ConwayGovState,
  RatifyEnv (..),
  RatifySignal (..),
  RatifyState (..),
  newEpochStateDRepPulsingStateL,
  predictFuturePParams,
  pulseDRepPulsingState,
 )
import Cardano.Ledger.Conway.Rules.Epoch (ConwayEpochEvent)
import Cardano.Ledger.Conway.Rules.HardFork (ConwayHardForkEvent (..))
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Rewards (Reward)
import Cardano.Ledger.Shelley.AdaPots (AdaPots (..), totalAdaPotsES)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rewards (sumRewards)
import qualified Cardano.Ledger.Shelley.Rules as Shelley
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) (NEWEPOCH era)
  , Event (EraRule "RUPD" era) ~ Shelley.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 (NEWEPOCH era))
  , Show (PredicateFailure (NEWEPOCH era))
  ) =>
  STS (NEWEPOCH era)
  where
  type State (NEWEPOCH era) = NewEpochState era
  type Signal (NEWEPOCH era) = EpochNo
  type Environment (NEWEPOCH era) = ()
  type BaseM (NEWEPOCH era) = ShelleyBase
  type PredicateFailure (NEWEPOCH era) = Void
  type Event (NEWEPOCH era) = ConwayNewEpochEvent era

  initialRules :: [InitialRule (NEWEPOCH era)]
initialRules =
    [ State (NEWEPOCH era) -> InitialRule (NEWEPOCH era)
forall a. a -> F (Clause (NEWEPOCH era) 'Initial) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (State (NEWEPOCH era) -> InitialRule (NEWEPOCH era))
-> State (NEWEPOCH era) -> InitialRule (NEWEPOCH 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
          PoolDistr
forall a. Default a => a
def
          StashedAVVMAddresses era
forall a. Default a => a
def
    ]

  transitionRules :: [TransitionRule (NEWEPOCH era)]
transitionRules = [TransitionRule (NEWEPOCH era)
forall era.
(EraTxOut era, ConwayEraGov era, EraCertState era,
 Embed (EraRule "EPOCH" era) (NEWEPOCH 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 (NEWEPOCH era)),
 Show (PredicateFailure (NEWEPOCH era))) =>
TransitionRule (NEWEPOCH era)
newEpochTransition]

newEpochTransition ::
  forall era.
  ( EraTxOut era
  , ConwayEraGov era
  , EraCertState era
  , Embed (EraRule "EPOCH" era) (NEWEPOCH era)
  , Environment (EraRule "EPOCH" era) ~ ()
  , State (EraRule "EPOCH" era) ~ EpochState era
  , Signal (EraRule "EPOCH" era) ~ EpochNo
  , Default (StashedAVVMAddresses era)
  , Event (EraRule "RUPD" era) ~ Shelley.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 (NEWEPOCH era))
  , Show (PredicateFailure (NEWEPOCH era))
  ) =>
  TransitionRule (NEWEPOCH era)
newEpochTransition :: forall era.
(EraTxOut era, ConwayEraGov era, EraCertState era,
 Embed (EraRule "EPOCH" era) (NEWEPOCH 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 (NEWEPOCH era)),
 Show (PredicateFailure (NEWEPOCH era))) =>
TransitionRule (NEWEPOCH era)
newEpochTransition = do
  TRC
    ( _
      , nes@(NewEpochState eL _ bcur es0 ru _ _)
      , eNo
      ) <-
    Rule
  (NEWEPOCH era) 'Transition (RuleContext 'Transition (NEWEPOCH era))
F (Clause (NEWEPOCH era) 'Transition) (TRC (NEWEPOCH era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  if eNo /= succ eL
    then
      pure $
        nes
          & newEpochStateDRepPulsingStateL %~ pulseDRepPulsingState
          & newEpochStateGovStateL %~ predictFuturePParams
    else do
      es1 <- case ru of -- Here is where we extract the result of Reward pulsing.
        StrictMaybe PulsingRewUpdate
SNothing -> EpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
forall a. a -> F (Clause (NEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es0
        SJust p :: PulsingRewUpdate
p@(Pulsing RewardSnapShot
_ Pulser
_) -> do
          (ans, event) <- BaseM
  (NEWEPOCH era)
  (RewardUpdate, Map (Credential Staking) (Set Reward))
-> Rule
     (NEWEPOCH 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)
          tellReward (DeltaRewardEvent (Shelley.RupdEvent eNo event))
          updateRewards es0 eNo ans
        SJust (Complete RewardUpdate
ru') -> EpochState era
-> EpochNo
-> RewardUpdate
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
forall era.
(EraGov era, EraCertState era) =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (NEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 EpochNo
Signal (NEWEPOCH era)
eNo RewardUpdate
ru'
      es2 <- trans @(EraRule "EPOCH" era) $ TRC ((), es1, eNo)
      let adaPots = EpochState era -> AdaPots
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es2
      tellEvent $ TotalAdaPotsEvent adaPots
      let pd' = SnapShots -> PoolDistr
ssStakeMarkPoolDistr (EpochState era -> SnapShots
forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es0)
      -- See `Shelley.NEWEPOCH` for details on the implementation
      pure $
        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) ~ Shelley.RupdEvent =>
  ConwayNewEpochEvent era ->
  Rule (NEWEPOCH era) rtype ()
tellReward :: forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent) =>
ConwayNewEpochEvent era -> Rule (NEWEPOCH era) rtype ()
tellReward (DeltaRewardEvent (Shelley.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 (NEWEPOCH era) rtype) ()
forall a. a -> F (Clause (NEWEPOCH era) rtype) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellReward ConwayNewEpochEvent era
x = Event (NEWEPOCH era) -> F (Clause (NEWEPOCH era) rtype) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent Event (NEWEPOCH era)
ConwayNewEpochEvent era
x

updateRewards ::
  (EraGov era, EraCertState era) =>
  EpochState era ->
  EpochNo ->
  RewardUpdate ->
  Rule (NEWEPOCH era) 'Transition (EpochState era)
updateRewards :: forall era.
(EraGov era, EraCertState era) =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (NEWEPOCH 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 (NEWEPOCH era) 'Transition) ()
-> F (Clause (NEWEPOCH 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 (NEWEPOCH era) 'Transition) ()
forall a. a -> F (Clause (NEWEPOCH 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 (NEWEPOCH era) -> F (Clause (NEWEPOCH era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (NEWEPOCH era) -> F (Clause (NEWEPOCH era) 'Transition) ())
-> Event (NEWEPOCH era) -> F (Clause (NEWEPOCH 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 (NEWEPOCH era) -> F (Clause (NEWEPOCH era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (NEWEPOCH era) -> F (Clause (NEWEPOCH era) 'Transition) ())
-> Event (NEWEPOCH era) -> F (Clause (NEWEPOCH 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
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
forall a. a -> F (Clause (NEWEPOCH era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es'

instance
  ( STS (NEWEPOCH era)
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , PredicateFailure (EraRule "NEWEPOCH" era) ~ PredicateFailure (NEWEPOCH era)
  ) =>
  Embed (NEWEPOCH era) (Shelley.TICK era)
  where
  wrapFailed :: PredicateFailure (NEWEPOCH era) -> PredicateFailure (TICK era)
wrapFailed = \case {}
  wrapEvent :: Event (NEWEPOCH era) -> Event (TICK era)
wrapEvent = Event (EraRule "NEWEPOCH" era) -> ShelleyTickEvent era
Event (NEWEPOCH era) -> Event (TICK era)
forall era. Event (EraRule "NEWEPOCH" era) -> ShelleyTickEvent era
Shelley.TickNewEpochEvent

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

instance InjectRuleEvent "NEWEPOCH" ConwayEpochEvent ConwayEra where
  injectEvent :: ConwayEpochEvent ConwayEra -> EraRuleEvent "NEWEPOCH" ConwayEra
injectEvent = Event (EraRule "EPOCH" ConwayEra) -> ConwayNewEpochEvent ConwayEra
ConwayEpochEvent ConwayEra -> EraRuleEvent "NEWEPOCH" ConwayEra
forall era. Event (EraRule "EPOCH" era) -> ConwayNewEpochEvent era
EpochEvent

instance InjectRuleEvent "NEWEPOCH" ConwayHardForkEvent ConwayEra where
  injectEvent :: ConwayHardForkEvent ConwayEra -> EraRuleEvent "NEWEPOCH" ConwayEra
injectEvent = Event (EraRule "EPOCH" ConwayEra) -> ConwayNewEpochEvent ConwayEra
ConwayEpochEvent ConwayEra -> ConwayNewEpochEvent ConwayEra
forall era. Event (EraRule "EPOCH" era) -> ConwayNewEpochEvent era
EpochEvent (ConwayEpochEvent ConwayEra -> ConwayNewEpochEvent ConwayEra)
-> (ConwayHardForkEvent ConwayEra -> ConwayEpochEvent ConwayEra)
-> ConwayHardForkEvent ConwayEra
-> ConwayNewEpochEvent ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayHardForkEvent ConwayEra -> EraRuleEvent "EPOCH" ConwayEra
ConwayHardForkEvent ConwayEra -> ConwayEpochEvent ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent