{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Shelley.Rules.NewEpoch
  ( NEWEPOCH,
    NewEpochPredicateFailure (..),
    NewEpochEvent (..),
    PredicateFailure,
    calculatePoolDistr,
  )
where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Keys (KeyRole (Staking))
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.Shelley.AdaPots (AdaPots, totalAdaPotsES)
import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue)
import Cardano.Ledger.Shelley.EpochBoundary
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rewards (Reward, sumRewards)
import Cardano.Ledger.Shelley.Rules.Epoch
import Cardano.Ledger.Shelley.Rules.Mir
import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..))
import Cardano.Ledger.Shelley.TxBody
import Cardano.Ledger.Slot
import qualified Cardano.Ledger.Val as Val
import Control.Provenance (runProvM)
import Control.State.Transition
import Data.Default.Class (Default, def)
import qualified Data.Map.Strict as Map
import Data.Ratio
import Data.Set (Set)
import Data.VMap as VMap
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks (..))

data NEWEPOCH era

data NewEpochPredicateFailure era
  = EpochFailure (PredicateFailure (Core.EraRule "EPOCH" era)) -- Subtransition Failures
  | CorruptRewardUpdate
      !(RewardUpdate (Crypto era)) -- The reward update which violates an invariant
  | MirFailure (PredicateFailure (Core.EraRule "MIR" era)) -- Subtransition Failures
  deriving ((forall x.
 NewEpochPredicateFailure era
 -> Rep (NewEpochPredicateFailure era) x)
-> (forall x.
    Rep (NewEpochPredicateFailure era) x
    -> NewEpochPredicateFailure era)
-> Generic (NewEpochPredicateFailure era)
forall x.
Rep (NewEpochPredicateFailure era) x
-> NewEpochPredicateFailure era
forall x.
NewEpochPredicateFailure era
-> Rep (NewEpochPredicateFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (NewEpochPredicateFailure era) x
-> NewEpochPredicateFailure era
forall era x.
NewEpochPredicateFailure era
-> Rep (NewEpochPredicateFailure era) x
$cto :: forall era x.
Rep (NewEpochPredicateFailure era) x
-> NewEpochPredicateFailure era
$cfrom :: forall era x.
NewEpochPredicateFailure era
-> Rep (NewEpochPredicateFailure era) x
Generic)

deriving stock instance
  ( Show (PredicateFailure (Core.EraRule "EPOCH" era)),
    Show (PredicateFailure (Core.EraRule "MIR" era))
  ) =>
  Show (NewEpochPredicateFailure era)

deriving stock instance
  ( Eq (PredicateFailure (Core.EraRule "EPOCH" era)),
    Eq (PredicateFailure (Core.EraRule "MIR" era))
  ) =>
  Eq (NewEpochPredicateFailure era)

instance
  ( NoThunks (PredicateFailure (Core.EraRule "EPOCH" era)),
    NoThunks (PredicateFailure (Core.EraRule "MIR" era))
  ) =>
  NoThunks (NewEpochPredicateFailure era)

data NewEpochEvent era
  = DeltaRewardEvent (Event (Core.EraRule "RUPD" era))
  | RestrainedRewards EpochNo (Map.Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))) (Set (Credential 'Staking (Crypto era)))
  | TotalRewardEvent EpochNo (Map.Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
  | EpochEvent (Event (Core.EraRule "EPOCH" era))
  | MirEvent (Event (Core.EraRule "MIR" era))
  | TotalAdaPotsEvent AdaPots

instance
  ( UsesTxOut era,
    UsesValue era,
    Embed (Core.EraRule "MIR" era) (NEWEPOCH era),
    Embed (Core.EraRule "EPOCH" era) (NEWEPOCH era),
    Environment (Core.EraRule "MIR" era) ~ (),
    State (Core.EraRule "MIR" era) ~ EpochState era,
    Signal (Core.EraRule "MIR" era) ~ (),
    Event (Core.EraRule "RUPD" era) ~ RupdEvent (Crypto era),
    Environment (Core.EraRule "EPOCH" era) ~ (),
    State (Core.EraRule "EPOCH" era) ~ EpochState era,
    Signal (Core.EraRule "EPOCH" era) ~ EpochNo,
    Default (EpochState era),
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    Default (State (Core.EraRule "PPUP" era)),
    Default (Core.PParams era),
    Default (StashedAVVMAddresses 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) = NewEpochPredicateFailure era
  type Event (NEWEPOCH era) = NewEpochEvent era

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

  transitionRules :: [TransitionRule (NEWEPOCH era)]
transitionRules = [TransitionRule (NEWEPOCH era)
forall era.
(Embed (EraRule "MIR" era) (NEWEPOCH era),
 Embed (EraRule "EPOCH" era) (NEWEPOCH era),
 Event (EraRule "RUPD" era) ~ RupdEvent (Crypto era),
 Environment (EraRule "MIR" era) ~ (),
 State (EraRule "MIR" era) ~ EpochState era,
 Signal (EraRule "MIR" era) ~ (),
 Environment (EraRule "EPOCH" era) ~ (),
 State (EraRule "EPOCH" era) ~ EpochState era,
 Signal (EraRule "EPOCH" era) ~ EpochNo,
 HasField "_protocolVersion" (PParams era) ProtVer, UsesTxOut era,
 UsesValue era, Default (State (EraRule "PPUP" era)),
 Default (PParams era), Default (StashedAVVMAddresses era),
 Event (EraRule "RUPD" era) ~ RupdEvent (Crypto era)) =>
TransitionRule (NEWEPOCH era)
newEpochTransition]

newEpochTransition ::
  forall era.
  ( Embed (Core.EraRule "MIR" era) (NEWEPOCH era),
    Embed (Core.EraRule "EPOCH" era) (NEWEPOCH era),
    Event (Core.EraRule "RUPD" era) ~ RupdEvent (Crypto era),
    Environment (Core.EraRule "MIR" era) ~ (),
    State (Core.EraRule "MIR" era) ~ EpochState era,
    Signal (Core.EraRule "MIR" era) ~ (),
    Environment (Core.EraRule "EPOCH" era) ~ (),
    State (Core.EraRule "EPOCH" era) ~ EpochState era,
    Signal (Core.EraRule "EPOCH" era) ~ EpochNo,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    UsesTxOut era,
    UsesValue era,
    Default (State (Core.EraRule "PPUP" era)),
    Default (Core.PParams era),
    Default (StashedAVVMAddresses era),
    Event (Core.EraRule "RUPD" era) ~ RupdEvent (Crypto era)
  ) =>
  TransitionRule (NEWEPOCH era)
newEpochTransition :: TransitionRule (NEWEPOCH era)
newEpochTransition = do
  TRC
    ( Environment (NEWEPOCH era)
_,
      src :: State (NEWEPOCH era)
src@(NewEpochState (EpochNo eL) _ bcur es ru _pd _),
      e :: Signal (NEWEPOCH era)
e@(EpochNo e_)
      ) <-
    F (Clause (NEWEPOCH era) 'Transition) (TRC (NEWEPOCH era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  if Word64
e_ Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
eL Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
    then NewEpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (NewEpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure State (NEWEPOCH era)
NewEpochState era
src
    else do
      let updateRewards :: RewardUpdate (Crypto era)
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
updateRewards ru' :: RewardUpdate (Crypto era)
ru'@(RewardUpdate DeltaCoin
dt DeltaCoin
dr Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
rs_ DeltaCoin
df NonMyopic (Crypto era)
_) = do
            let totRs :: Coin
totRs = PParams era
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Coin
forall crypto pp.
HasField "_protocolVersion" pp ProtVer =>
pp
-> Map (Credential 'Staking crypto) (Set (Reward crypto)) -> Coin
sumRewards (EpochState era -> PParams era
forall era. EpochState era -> PParams era
esPrevPp EpochState era
es) Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
rs_
            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)) Bool
-> PredicateFailure (NEWEPOCH era)
-> Rule (NEWEPOCH era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! RewardUpdate (Crypto era) -> NewEpochPredicateFailure era
forall era.
RewardUpdate (Crypto era) -> NewEpochPredicateFailure era
CorruptRewardUpdate RewardUpdate (Crypto era)
ru'
            let (EpochState era
es', Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
regRU, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored, Set (Credential 'Staking (Crypto era))
unregistered) = RewardUpdate (Crypto era)
-> EpochState era
-> (EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)))
forall era.
HasField "_protocolVersion" (PParams era) ProtVer =>
RewardUpdate (Crypto era)
-> EpochState era
-> (EpochState era,
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))),
    Set (Credential 'Staking (Crypto era)))
applyRUpd' RewardUpdate (Crypto era)
ru' EpochState era
es
            Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ())
-> Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Set (Credential 'Staking (Crypto era))
-> NewEpochEvent era
forall era.
EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Set (Credential 'Staking (Crypto era))
-> NewEpochEvent era
RestrainedRewards EpochNo
Signal (NEWEPOCH era)
e Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
eraIgnored Set (Credential 'Staking (Crypto era))
unregistered
            -- 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) -> Rule (NEWEPOCH era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ())
-> Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> NewEpochEvent era
forall era.
EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> NewEpochEvent era
TotalRewardEvent EpochNo
Signal (NEWEPOCH era)
e Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
regRU
            EpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es'
      EpochState era
es' <- case StrictMaybe (PulsingRewUpdate (Crypto era))
ru of
        StrictMaybe (PulsingRewUpdate (Crypto era))
SNothing -> EpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochState era
es
        SJust p :: PulsingRewUpdate (Crypto era)
p@(Pulsing RewardSnapShot (Crypto era)
_ Pulser (Crypto era)
_) -> do
          (RewardUpdate (Crypto era)
ans, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event) <- BaseM
  (NEWEPOCH era)
  (RewardUpdate (Crypto era),
   Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Rule
     (NEWEPOCH era)
     'Transition
     (RewardUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (ProvM
  (RewardProvenance (Crypto era))
  ShelleyBase
  (RewardUpdate (Crypto era),
   Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> ShelleyBase
     (RewardUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall (m :: * -> *) s b. Monad m => ProvM s m b -> m b
runProvM (ProvM
   (RewardProvenance (Crypto era))
   ShelleyBase
   (RewardUpdate (Crypto era),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
 -> ShelleyBase
      (RewardUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> ShelleyBase
     (RewardUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate (Crypto era)
-> ProvM
     (RewardProvenance (Crypto era))
     ShelleyBase
     (RewardUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall crypto.
PulsingRewUpdate crypto
-> ProvM
     (RewardProvenance crypto)
     ShelleyBase
     (RewardUpdate crypto, RewardEvent crypto)
completeRupd PulsingRewUpdate (Crypto era)
p)
          NewEpochEvent era -> Rule (NEWEPOCH era) 'Transition ()
forall era (rtype :: RuleType).
(Event (EraRule "RUPD" era) ~ RupdEvent (Crypto era)) =>
NewEpochEvent era -> Rule (NEWEPOCH era) rtype ()
tellReward (Event (EraRule "RUPD" era) -> NewEpochEvent era
forall era. Event (EraRule "RUPD" era) -> NewEpochEvent era
DeltaRewardEvent (EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> RupdEvent (Crypto era)
forall crypto.
EpochNo
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> RupdEvent crypto
RupdEvent EpochNo
Signal (NEWEPOCH era)
e Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event))
          RewardUpdate (Crypto era)
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
updateRewards RewardUpdate (Crypto era)
ans
        SJust (Complete RewardUpdate (Crypto era)
ru') -> RewardUpdate (Crypto era)
-> F (Clause (NEWEPOCH era) 'Transition) (EpochState era)
updateRewards RewardUpdate (Crypto era)
ru'
      EpochState era
es'' <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "MIR" era) super =>
RuleContext rtype (EraRule "MIR" era)
-> Rule super rtype (State (EraRule "MIR" era))
trans @(Core.EraRule "MIR" era) (RuleContext 'Transition (EraRule "MIR" era)
 -> Rule (NEWEPOCH era) 'Transition (State (EraRule "MIR" era)))
-> RuleContext 'Transition (EraRule "MIR" era)
-> Rule (NEWEPOCH era) 'Transition (State (EraRule "MIR" era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "MIR" era), State (EraRule "MIR" era),
 Signal (EraRule "MIR" era))
-> TRC (EraRule "MIR" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "MIR" era)
EpochState era
es', ())
      EpochState era
es''' <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "EPOCH" era) super =>
RuleContext rtype (EraRule "EPOCH" era)
-> Rule super rtype (State (EraRule "EPOCH" era))
trans @(Core.EraRule "EPOCH" era) (RuleContext 'Transition (EraRule "EPOCH" era)
 -> Rule (NEWEPOCH era) 'Transition (State (EraRule "EPOCH" era)))
-> RuleContext 'Transition (EraRule "EPOCH" era)
-> Rule (NEWEPOCH 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
es'', Signal (EraRule "EPOCH" era)
Signal (NEWEPOCH era)
e)
      let adaPots :: AdaPots
adaPots = EpochState era -> AdaPots
forall era. UsesValue era => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es'''
      Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ())
-> Event (NEWEPOCH era) -> Rule (NEWEPOCH era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ AdaPots -> NewEpochEvent era
forall era. AdaPots -> NewEpochEvent era
TotalAdaPotsEvent AdaPots
adaPots
      let ss :: SnapShots (Crypto era)
ss = EpochState era -> SnapShots (Crypto era)
forall era. EpochState era -> SnapShots (Crypto era)
esSnapshots EpochState era
es'''
          pd' :: PoolDistr (Crypto era)
pd' = SnapShot (Crypto era) -> PoolDistr (Crypto era)
forall crypto. SnapShot crypto -> PoolDistr crypto
calculatePoolDistr (SnapShots (Crypto era) -> SnapShot (Crypto era)
forall crypto. SnapShots crypto -> SnapShot crypto
_pstakeSet SnapShots (Crypto era)
ss)
      NewEpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (NewEpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era
 -> F (Clause (NEWEPOCH era) 'Transition) (NewEpochState era))
-> NewEpochState era
-> F (Clause (NEWEPOCH era) 'Transition) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
        State (NEWEPOCH era)
NewEpochState era
src
          { nesEL :: EpochNo
nesEL = EpochNo
Signal (NEWEPOCH era)
e,
            nesBprev :: BlocksMade (Crypto era)
nesBprev = BlocksMade (Crypto era)
bcur,
            nesBcur :: BlocksMade (Crypto era)
nesBcur = Map (KeyHash 'StakePool (Crypto era)) Natural
-> BlocksMade (Crypto era)
forall crypto.
Map (KeyHash 'StakePool crypto) Natural -> BlocksMade crypto
BlocksMade Map (KeyHash 'StakePool (Crypto era)) Natural
forall a. Monoid a => a
mempty,
            nesEs :: EpochState era
nesEs = EpochState era
es''',
            nesRu :: StrictMaybe (PulsingRewUpdate (Crypto era))
nesRu = StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. StrictMaybe a
SNothing,
            nesPd :: PoolDistr (Crypto era)
nesPd = PoolDistr (Crypto era)
pd'
          }

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

calculatePoolDistr :: SnapShot crypto -> PoolDistr crypto
calculatePoolDistr :: SnapShot crypto -> PoolDistr crypto
calculatePoolDistr (SnapShot Stake crypto
stake VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegs VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
poolParams) =
  let Coin Integer
total = Stake crypto -> Coin
forall crypto. Stake crypto -> Coin
sumAllStake Stake crypto
stake
      -- total could be zero (in particular when shrinking)
      nonZeroTotal :: Integer
nonZeroTotal = if Integer
total Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Integer
1 else Integer
total
      sd :: Map (KeyHash 'StakePool crypto) (Ratio Integer)
sd =
        (Ratio Integer -> Ratio Integer -> Ratio Integer)
-> [(KeyHash 'StakePool crypto, Ratio Integer)]
-> Map (KeyHash 'StakePool crypto) (Ratio Integer)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
(+) ([(KeyHash 'StakePool crypto, Ratio Integer)]
 -> Map (KeyHash 'StakePool crypto) (Ratio Integer))
-> [(KeyHash 'StakePool crypto, Ratio Integer)]
-> Map (KeyHash 'StakePool crypto) (Ratio Integer)
forall a b. (a -> b) -> a -> b
$
          [ (KeyHash 'StakePool crypto
d, Integer
c Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
nonZeroTotal)
            | (Credential 'Staking crypto
hk, CompactForm Coin
compactCoin) <- VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> [(Credential 'Staking crypto, CompactForm Coin)]
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList (Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
forall crypto.
Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
unStake Stake crypto
stake),
              let Coin Integer
c = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
compactCoin,
              Just KeyHash 'StakePool crypto
d <- [Credential 'Staking crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Maybe (KeyHash 'StakePool crypto)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential 'Staking crypto
hk VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
delegs]
          ]
   in Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
PoolDistr (Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
 -> PoolDistr crypto)
-> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
forall a b. (a -> b) -> a -> b
$
        (Ratio Integer
 -> Hash (HASH crypto) (VerKeyVRF (VRF crypto))
 -> IndividualPoolStake crypto)
-> Map (KeyHash 'StakePool crypto) (Ratio Integer)
-> Map
     (KeyHash 'StakePool crypto)
     (Hash (HASH crypto) (VerKeyVRF (VRF crypto)))
-> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith
          Ratio Integer
-> Hash (HASH crypto) (VerKeyVRF (VRF crypto))
-> IndividualPoolStake crypto
forall crypto.
Ratio Integer
-> Hash crypto (VerKeyVRF crypto) -> IndividualPoolStake crypto
IndividualPoolStake
          Map (KeyHash 'StakePool crypto) (Ratio Integer)
sd
          (VMap
  VB
  VB
  (KeyHash 'StakePool crypto)
  (Hash (HASH crypto) (VerKeyVRF (VRF crypto)))
-> Map
     (KeyHash 'StakePool crypto)
     (Hash (HASH crypto) (VerKeyVRF (VRF crypto)))
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
toMap ((PoolParams crypto -> Hash (HASH crypto) (VerKeyVRF (VRF crypto)))
-> VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
-> VMap
     VB
     VB
     (KeyHash 'StakePool crypto)
     (Hash (HASH crypto) (VerKeyVRF (VRF crypto)))
forall (vv :: * -> *) a b (kv :: * -> *) k.
(Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map PoolParams crypto -> Hash (HASH crypto) (VerKeyVRF (VRF crypto))
forall crypto. PoolParams crypto -> Hash crypto (VerKeyVRF crypto)
_poolVrf VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
poolParams))

instance
  ( UsesTxOut era,
    UsesValue era,
    STS (EPOCH era),
    PredicateFailure (Core.EraRule "EPOCH" era) ~ EpochPredicateFailure era,
    Event (Core.EraRule "EPOCH" era) ~ EpochEvent era
  ) =>
  Embed (EPOCH era) (NEWEPOCH era)
  where
  wrapFailed :: PredicateFailure (EPOCH era) -> PredicateFailure (NEWEPOCH era)
wrapFailed = PredicateFailure (EPOCH era) -> PredicateFailure (NEWEPOCH era)
forall era.
PredicateFailure (EraRule "EPOCH" era)
-> NewEpochPredicateFailure era
EpochFailure
  wrapEvent :: Event (EPOCH era) -> Event (NEWEPOCH era)
wrapEvent = Event (EPOCH era) -> Event (NEWEPOCH era)
forall era. Event (EraRule "EPOCH" era) -> NewEpochEvent era
EpochEvent

instance
  ( Era era,
    Default (EpochState era),
    PredicateFailure (Core.EraRule "MIR" era) ~ MirPredicateFailure era,
    Event (Core.EraRule "MIR" era) ~ MirEvent era
  ) =>
  Embed (MIR era) (NEWEPOCH era)
  where
  wrapFailed :: PredicateFailure (MIR era) -> PredicateFailure (NEWEPOCH era)
wrapFailed = PredicateFailure (MIR era) -> PredicateFailure (NEWEPOCH era)
forall era.
PredicateFailure (EraRule "MIR" era)
-> NewEpochPredicateFailure era
MirFailure
  wrapEvent :: Event (MIR era) -> Event (NEWEPOCH era)
wrapEvent = Event (MIR era) -> Event (NEWEPOCH era)
forall era. Event (EraRule "MIR" era) -> NewEpochEvent era
MirEvent