{-# 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,
  ConwayNewEpochPredFailure (..),
  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.EpochBoundary
import Cardano.Ledger.PoolDistr (PoolDistr (..))
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 qualified Cardano.Ledger.Val as Val
import Control.DeepSeq (NFData)
import Control.State.Transition
import Data.Default (Default (..))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (^.))

newtype ConwayNewEpochPredFailure era
  = CorruptRewardUpdate
      RewardUpdate -- The reward update which violates an invariant
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayNewEpochPredFailure era) x
-> ConwayNewEpochPredFailure era
forall era x.
ConwayNewEpochPredFailure era
-> Rep (ConwayNewEpochPredFailure era) x
$cto :: forall era x.
Rep (ConwayNewEpochPredFailure era) x
-> ConwayNewEpochPredFailure era
$cfrom :: forall era x.
ConwayNewEpochPredFailure era
-> Rep (ConwayNewEpochPredFailure era) x
Generic)

deriving instance Eq (ConwayNewEpochPredFailure era)

deriving instance
  ( Show (PredicateFailure (EraRule "EPOCH" era))
  , Show (PredicateFailure (EraRule "RATIFY" era))
  ) =>
  Show (ConwayNewEpochPredFailure era)

instance NFData (ConwayNewEpochPredFailure era)

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 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
$cto :: forall era x.
Rep (ConwayNewEpochEvent era) x -> ConwayNewEpochEvent era
$cfrom :: forall era x.
ConwayNewEpochEvent era -> Rep (ConwayNewEpochEvent era) x
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
  , 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))
  ) =>
  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) = ConwayNewEpochPredFailure era
  type Event (ConwayNEWEPOCH era) = ConwayNewEpochEvent era

  initialRules :: [InitialRule (ConwayNEWEPOCH era)]
initialRules =
    [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        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 forall k a. Map k a
Map.empty)
          (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty)
          forall a. Default a => a
def
          forall a. StrictMaybe a
SNothing
          (Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty)
          forall a. Default a => a
def
    ]

  transitionRules :: [TransitionRule (ConwayNEWEPOCH era)]
transitionRules = [forall era.
(EraTxOut era, ConwayEraGov 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))) =>
TransitionRule (ConwayNEWEPOCH era)
newEpochTransition]

newEpochTransition ::
  forall era.
  ( EraTxOut era
  , ConwayEraGov 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))
  ) =>
  TransitionRule (ConwayNEWEPOCH era)
newEpochTransition :: forall era.
(EraTxOut era, ConwayEraGov 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))) =>
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
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  if Signal (ConwayNEWEPOCH era)
eNo forall a. Eq a => a -> a -> Bool
/= forall a. Enum a => a -> a
succ EpochNo
eL
    then
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        State (ConwayNEWEPOCH era)
nes
          forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall era. DRepPulsingState era -> DRepPulsingState era
pulseDRepPulsingState
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall 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 -> 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) <- 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)
          forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent) =>
ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) rtype ()
tellReward (forall era. Event (EraRule "RUPD" era) -> ConwayNewEpochEvent era
DeltaRewardEvent (EpochNo -> Map (Credential 'Staking) (Set Reward) -> RupdEvent
RupdEvent Signal (ConwayNEWEPOCH era)
eNo Map (Credential 'Staking) (Set Reward)
event))
          forall era.
EraGov era =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 Signal (ConwayNEWEPOCH era)
eNo RewardUpdate
ans
        SJust (Complete RewardUpdate
ru') -> forall era.
EraGov era =>
EpochState era
-> EpochNo
-> RewardUpdate
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 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) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), EpochState era
es1, Signal (ConwayNEWEPOCH era)
eNo)
      let adaPots :: AdaPots
adaPots = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es2
      forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. AdaPots -> ConwayNewEpochEvent era
TotalAdaPotsEvent AdaPots
adaPots
      let pd' :: PoolDistr
pd' = SnapShots -> PoolDistr
ssStakeMarkPoolDistr (forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es0)
      -- See `ShelleyNEWEPOCH` for details on the implementation
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        State (ConwayNEWEPOCH era)
nes
          { nesEL :: EpochNo
nesEL = Signal (ConwayNEWEPOCH era)
eNo
          , nesBprev :: BlocksMade
nesBprev = BlocksMade
bcur
          , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a. Monoid a => a
mempty
          , nesEs :: EpochState era
nesEs = EpochState era
es2
          , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. StrictMaybe a
SNothing
          , nesPd :: PoolDistr
nesPd = PoolDistr
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)) | forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking) (Set Reward)
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellReward ConwayNewEpochEvent era
x = forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent ConwayNewEpochEvent era
x

updateRewards ::
  EraGov era =>
  EpochState era ->
  EpochNo ->
  RewardUpdate ->
  Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards :: forall era.
EraGov 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 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) Map (Credential 'Staking) (Set Reward)
rs_
  forall t. Val t => t -> Bool
Val.isZero (DeltaCoin
dt forall a. Semigroup a => a -> a -> a
<> DeltaCoin
dr forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
totRs forall a. Semigroup a => a -> a -> a
<> DeltaCoin
df) forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! forall era. RewardUpdate -> ConwayNewEpochPredFailure era
CorruptRewardUpdate RewardUpdate
ru'
  let !(!EpochState era
es', FilteredRewards era
filtered) = forall era.
EraGov era =>
RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate
ru' EpochState era
es
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era.
EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> Set (Credential 'Staking)
-> ConwayNewEpochEvent era
RestrainedRewards EpochNo
e (forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frShelleyIgnored FilteredRewards era
filtered) (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).
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era.
EpochNo
-> Map (Credential 'Staking) (Set Reward)
-> ConwayNewEpochEvent era
TotalRewardEvent EpochNo
e (forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered FilteredRewards era
filtered)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es'

instance
  ( STS (ConwayNEWEPOCH era)
  , PredicateFailure (EraRule "NEWEPOCH" era) ~ ConwayNewEpochPredFailure era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  ) =>
  Embed (ConwayNEWEPOCH era) (ShelleyTICK era)
  where
  wrapFailed :: PredicateFailure (ConwayNEWEPOCH era)
-> PredicateFailure (ShelleyTICK era)
wrapFailed = forall era.
PredicateFailure (EraRule "NEWEPOCH" era)
-> ShelleyTickPredFailure era
NewEpochFailure
  wrapEvent :: Event (ConwayNEWEPOCH era) -> Event (ShelleyTICK era)
wrapEvent = 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 = forall era. Event (EraRule "EPOCH" era) -> ConwayNewEpochEvent era
EpochEvent