{-# 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.Keys (KeyRole (..))
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.Class (Default (..))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import GHC.Generics (Generic)
import Lens.Micro ((%~), (&), (^.))

newtype ConwayNewEpochPredFailure era
  = CorruptRewardUpdate
      (RewardUpdate (EraCrypto era)) -- 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 (EraCrypto era)) (Set (Reward (EraCrypto era))))
      !(Set (Credential 'Staking (EraCrypto era)))
  | TotalRewardEvent
      !EpochNo
      !(Map.Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era))))
  | 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 c) = ConwayNewEpochEvent (ConwayEra c)

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 (EraCrypto era)
  , 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 (EraCrypto era)
-> BlocksMade (EraCrypto era)
-> EpochState era
-> StrictMaybe (PulsingRewUpdate (EraCrypto era))
-> PoolDistr (EraCrypto era)
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
          (Word64 -> EpochNo
EpochNo Word64
0)
          (forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty)
          (forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty)
          forall a. Default a => a
def
          forall a. StrictMaybe a
SNothing
          (forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
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 (EraCrypto 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))) =>
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 (EraCrypto 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))
  ) =>
  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 (EraCrypto 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))) =>
TransitionRule (ConwayNEWEPOCH era)
newEpochTransition = do
  TRC
    ( Environment (ConwayNEWEPOCH era)
_
      , nes :: State (ConwayNEWEPOCH era)
nes@(NewEpochState EpochNo
eL BlocksMade (EraCrypto era)
_ BlocksMade (EraCrypto era)
bcur EpochState era
es0 StrictMaybe (PulsingRewUpdate (EraCrypto era))
ru PoolDistr (EraCrypto era)
_ 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 (EraCrypto era))
ru of -- Here is where we extract the result of Reward pulsing.
        StrictMaybe (PulsingRewUpdate (EraCrypto era))
SNothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es0
        SJust p :: PulsingRewUpdate (EraCrypto era)
p@(Pulsing RewardSnapShot (EraCrypto era)
_ Pulser (EraCrypto era)
_) -> do
          (RewardUpdate (EraCrypto era)
ans, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (forall c.
PulsingRewUpdate c -> ShelleyBase (RewardUpdate c, RewardEvent c)
completeRupd PulsingRewUpdate (EraCrypto era)
p)
          forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent (EraCrypto era)) =>
ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) rtype ()
tellReward (forall era. Event (EraRule "RUPD" era) -> ConwayNewEpochEvent era
DeltaRewardEvent (forall c.
EpochNo
-> Map (Credential 'Staking c) (Set (Reward c)) -> RupdEvent c
RupdEvent Signal (ConwayNEWEPOCH era)
eNo Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event))
          forall era.
EraGov era =>
EpochState era
-> EpochNo
-> RewardUpdate (EraCrypto era)
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 Signal (ConwayNEWEPOCH era)
eNo RewardUpdate (EraCrypto era)
ans
        SJust (Complete RewardUpdate (EraCrypto era)
ru') -> forall era.
EraGov era =>
EpochState era
-> EpochNo
-> RewardUpdate (EraCrypto era)
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es0 Signal (ConwayNEWEPOCH era)
eNo RewardUpdate (EraCrypto era)
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 (EraCrypto era)
pd' = forall c. SnapShots c -> PoolDistr c
ssStakeMarkPoolDistr (forall era. EpochState era -> SnapShots (EraCrypto era)
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 (EraCrypto era)
nesBprev = BlocksMade (EraCrypto era)
bcur
          , nesBcur :: BlocksMade (EraCrypto era)
nesBcur = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall a. Monoid a => a
mempty
          , nesEs :: EpochState era
nesEs = EpochState era
es2
          , nesRu :: StrictMaybe (PulsingRewUpdate (EraCrypto era))
nesRu = forall a. StrictMaybe a
SNothing
          , nesPd :: PoolDistr (EraCrypto era)
nesPd = PoolDistr (EraCrypto era)
pd'
          }

-- | tell a RupdEvent as a DeltaRewardEvent only if the map is non-empty
tellReward ::
  Event (EraRule "RUPD" era) ~ RupdEvent (EraCrypto era) =>
  ConwayNewEpochEvent era ->
  Rule (ConwayNEWEPOCH era) rtype ()
tellReward :: forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent (EraCrypto era)) =>
ConwayNewEpochEvent era -> Rule (ConwayNEWEPOCH era) rtype ()
tellReward (DeltaRewardEvent (RupdEvent EpochNo
_ Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
m)) | forall k a. Map k a -> Bool
Map.null Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
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 (EraCrypto era) ->
  Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards :: forall era.
EraGov era =>
EpochState era
-> EpochNo
-> RewardUpdate (EraCrypto era)
-> Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
updateRewards EpochState era
es EpochNo
e ru' :: RewardUpdate (EraCrypto era)
ru'@(RewardUpdate DeltaCoin
dt DeltaCoin
dr Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
rs_ DeltaCoin
df NonMyopic (EraCrypto era)
_) = do
  let totRs :: Coin
totRs = forall c.
ProtVer -> Map (Credential 'Staking c) (Set (Reward c)) -> 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 (EraCrypto era))
  (Set (Reward (EraCrypto era)))
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 (EraCrypto era) -> ConwayNewEpochPredFailure era
CorruptRewardUpdate RewardUpdate (EraCrypto era)
ru'
  let !(!EpochState era
es', FilteredRewards era
filtered) = forall era.
EraGov era =>
RewardUpdate (EraCrypto era)
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate (EraCrypto era)
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 (EraCrypto era))
     (Set (Reward (EraCrypto era)))
-> Set (Credential 'Staking (EraCrypto era))
-> ConwayNewEpochEvent era
RestrainedRewards EpochNo
e (forall era.
FilteredRewards era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
frShelleyIgnored FilteredRewards era
filtered) (forall era.
FilteredRewards era -> Set (Credential 'Staking (EraCrypto era))
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 (EraCrypto era))
     (Set (Reward (EraCrypto era)))
-> ConwayNewEpochEvent era
TotalRewardEvent EpochNo
e (forall era.
FilteredRewards era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
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