{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Ledger.Shelley.Rewards (
  StakeShare (..),
  PoolRewardInfo (..),
  mkApparentPerformance,
  RewardType (..),
  Reward (..),
  calcStakePoolOperatorReward,
  calcStakePoolMemberReward,
  LeaderOnlyReward (..),
  leaderRewardToGeneral,
  leaderRew,
  memberRew,
  aggregateRewards,
  filterRewards,
  sumRewards,
  aggregateCompactRewards,
  sumCompactRewards,
  rewardOnePoolMember,
  mkPoolRewardInfo,
) where

import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  BoundedRational (..),
  NonZero,
  ProtVer,
  UnitInterval,
  nonZeroOr,
  (%.),
  (%?),
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decNoShareCBOR,
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm,
  coinToRational,
  compactCoinOrError,
  rationalToCoinViaFloor,
  unCoinNonZero,
 )
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Rewards (Reward (..), RewardType (..))
import Cardano.Ledger.Shelley.Era (
  hardforkAllegraAggregatedRewards,
  hardforkBabbageForgoRewardPrefilter,
 )
import Cardano.Ledger.State (Stake (..), StakePoolParams (..), StakePoolSnapShot (..), maxPool')
import Cardano.Ledger.Val ((<->))
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Control.Monad (guard)
import Data.Foldable (fold, foldMap')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.VMap as VMap
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)
import Quiet

-- | StakeShare type
newtype StakeShare = StakeShare {StakeShare -> Rational
unStakeShare :: Rational}
  deriving ((forall x. StakeShare -> Rep StakeShare x)
-> (forall x. Rep StakeShare x -> StakeShare) -> Generic StakeShare
forall x. Rep StakeShare x -> StakeShare
forall x. StakeShare -> Rep StakeShare x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StakeShare -> Rep StakeShare x
from :: forall x. StakeShare -> Rep StakeShare x
$cto :: forall x. Rep StakeShare x -> StakeShare
to :: forall x. Rep StakeShare x -> StakeShare
Generic, Eq StakeShare
Eq StakeShare =>
(StakeShare -> StakeShare -> Ordering)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> StakeShare)
-> (StakeShare -> StakeShare -> StakeShare)
-> Ord StakeShare
StakeShare -> StakeShare -> Bool
StakeShare -> StakeShare -> Ordering
StakeShare -> StakeShare -> StakeShare
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StakeShare -> StakeShare -> Ordering
compare :: StakeShare -> StakeShare -> Ordering
$c< :: StakeShare -> StakeShare -> Bool
< :: StakeShare -> StakeShare -> Bool
$c<= :: StakeShare -> StakeShare -> Bool
<= :: StakeShare -> StakeShare -> Bool
$c> :: StakeShare -> StakeShare -> Bool
> :: StakeShare -> StakeShare -> Bool
$c>= :: StakeShare -> StakeShare -> Bool
>= :: StakeShare -> StakeShare -> Bool
$cmax :: StakeShare -> StakeShare -> StakeShare
max :: StakeShare -> StakeShare -> StakeShare
$cmin :: StakeShare -> StakeShare -> StakeShare
min :: StakeShare -> StakeShare -> StakeShare
Ord, StakeShare -> StakeShare -> Bool
(StakeShare -> StakeShare -> Bool)
-> (StakeShare -> StakeShare -> Bool) -> Eq StakeShare
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StakeShare -> StakeShare -> Bool
== :: StakeShare -> StakeShare -> Bool
$c/= :: StakeShare -> StakeShare -> Bool
/= :: StakeShare -> StakeShare -> Bool
Eq, Context -> StakeShare -> IO (Maybe ThunkInfo)
Proxy StakeShare -> String
(Context -> StakeShare -> IO (Maybe ThunkInfo))
-> (Context -> StakeShare -> IO (Maybe ThunkInfo))
-> (Proxy StakeShare -> String)
-> NoThunks StakeShare
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
noThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy StakeShare -> String
showTypeOf :: Proxy StakeShare -> String
NoThunks)
  deriving (Int -> StakeShare -> ShowS
[StakeShare] -> ShowS
StakeShare -> String
(Int -> StakeShare -> ShowS)
-> (StakeShare -> String)
-> ([StakeShare] -> ShowS)
-> Show StakeShare
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StakeShare -> ShowS
showsPrec :: Int -> StakeShare -> ShowS
$cshow :: StakeShare -> String
show :: StakeShare -> String
$cshowList :: [StakeShare] -> ShowS
showList :: [StakeShare] -> ShowS
Show) via Quiet StakeShare

instance NFData StakeShare

-- | Calculate pool reward
mkApparentPerformance ::
  UnitInterval ->
  Rational ->
  Natural ->
  Natural ->
  Rational
mkApparentPerformance :: UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance UnitInterval
d_ Rational
sigma Natural
blocksN Natural
blocksTotal
  | Rational
sigma Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = Rational
0
  | UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
d_ Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0.8 = Rational
beta Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma
  | Bool
otherwise = Rational
1
  where
    beta :: Rational
beta = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
blocksN Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
1 Natural
blocksTotal)

-- | Calculate pool leader reward
leaderRew ::
  Coin ->
  StakePoolParams ->
  StakeShare ->
  StakeShare ->
  Coin
leaderRew :: Coin -> StakePoolParams -> StakeShare -> StakeShare -> Coin
leaderRew Coin
f StakePoolParams
pool = Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolOperatorReward Coin
f (StakePoolParams -> Coin
sppCost StakePoolParams
pool) (StakePoolParams -> UnitInterval
sppMargin StakePoolParams
pool)
{-# DEPRECATED leaderRew "In favor of `calcStakePoolOperatorReward`" #-}

-- | See section "5.5.4.1 Pool Operator Reward" in [Design Specification for Delegation and Incentives in Cardano](https://github.com/intersectmbo/cardano-ledger/releases/latest/download/shelley-delegation.pdf)
calcStakePoolOperatorReward ::
  -- | Total Pool Rewards
  Coin ->
  -- | Stake Pool Cost
  Coin ->
  -- | Stake Pool Margin
  UnitInterval ->
  -- | Stake delegated to the pool by its owner(s)
  StakeShare ->
  -- | The relative stake of the pool.
  StakeShare ->
  Coin
calcStakePoolOperatorReward :: Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolOperatorReward Coin
f Coin
cost UnitInterval
margin (StakeShare Rational
s) (StakeShare Rational
sigma)
  | Coin
f Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
cost = Coin
f
  | Bool
otherwise =
      Coin
cost Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Rational -> Coin
rationalToCoinViaFloor (Coin -> Rational
coinToRational (Coin
f Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
cost) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
m Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
m) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
s Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma))
  where
    m :: Rational
m = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
margin

-- | Calculate pool member reward
memberRew ::
  Coin ->
  StakePoolParams ->
  StakeShare ->
  StakeShare ->
  Coin
memberRew :: Coin -> StakePoolParams -> StakeShare -> StakeShare -> Coin
memberRew Coin
f StakePoolParams
pool = Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolMemberReward Coin
f (StakePoolParams -> Coin
sppCost StakePoolParams
pool) (StakePoolParams -> UnitInterval
sppMargin StakePoolParams
pool)
{-# DEPRECATED memberRew "In favor of `calcStakePoolMemberReward`" #-}

-- | See section "5.5.4.2 Pool Member Reward" in [Design Specification for Delegation and Incentives in Cardano](https://github.com/intersectmbo/cardano-ledger/releases/latest/download/shelley-delegation.pdf)
calcStakePoolMemberReward ::
  -- | Total Pool Rewards
  Coin ->
  -- | Stake Pool Cost
  Coin ->
  -- | Stake Pool Margin
  UnitInterval ->
  -- | Member stake share
  StakeShare ->
  -- | The relative stake of the pool.
  StakeShare ->
  Coin
calcStakePoolMemberReward :: Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolMemberReward (Coin Integer
f) (Coin Integer
cost) UnitInterval
margin (StakeShare Rational
t) (StakeShare Rational
sigma)
  | Integer
f Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
cost = Coin
forall a. Monoid a => a
mempty
  | Bool
otherwise =
      Rational -> Coin
rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
f Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
cost) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
m) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
t Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
sigma
  where
    m :: Rational
m = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
margin

sumRewards ::
  ProtVer ->
  Map (Credential Staking) (Set Reward) ->
  Coin
sumRewards :: ProtVer -> Map (Credential Staking) (Set Reward) -> Coin
sumRewards ProtVer
protocolVersion Map (Credential Staking) (Set Reward)
rs = Map (Credential Staking) Coin -> Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential Staking) Coin -> Coin)
-> Map (Credential Staking) Coin -> Coin
forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) Coin
aggregateRewards ProtVer
protocolVersion Map (Credential Staking) (Set Reward)
rs

-- | Filter the reward payments to those that will actually be delivered. This
-- function exists since in Shelley, a stake credential earning rewards from
-- multiple sources would only receive one reward. So some of the coins are ignored,
-- because of this backward compatibility issue in early protocolVersions. Note that
-- both of the domains of the returned maps are a subset of the the domain of the input map 'rewards'
filterRewards ::
  ProtVer ->
  Map (Credential Staking) (Set Reward) ->
  ( Map (Credential Staking) (Set Reward) -- delivered
  , Map (Credential Staking) (Set Reward) -- ignored in Shelley Era
  )
filterRewards :: ProtVer
-> Map (Credential Staking) (Set Reward)
-> (Map (Credential Staking) (Set Reward),
    Map (Credential Staking) (Set Reward))
filterRewards ProtVer
pv Map (Credential Staking) (Set Reward)
rewards =
  if ProtVer -> Bool
hardforkAllegraAggregatedRewards ProtVer
pv
    then (Map (Credential Staking) (Set Reward)
rewards, Map (Credential Staking) (Set Reward)
forall k a. Map k a
Map.empty)
    else
      let mp :: Map (Credential Staking) (Reward, Set Reward)
mp = (Set Reward -> (Reward, Set Reward))
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (Reward, Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Set Reward -> (Reward, Set Reward)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Map (Credential Staking) (Set Reward)
rewards
       in (((Reward, Set Reward) -> Set Reward)
-> Map (Credential Staking) (Reward, Set Reward)
-> Map (Credential Staking) (Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Reward -> Set Reward
forall a. a -> Set a
Set.singleton (Reward -> Set Reward)
-> ((Reward, Set Reward) -> Reward)
-> (Reward, Set Reward)
-> Set Reward
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reward, Set Reward) -> Reward
forall a b. (a, b) -> a
fst) Map (Credential Staking) (Reward, Set Reward)
mp, (Set Reward -> Bool)
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (Set Reward)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Set Reward -> Bool) -> Set Reward -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Reward -> Bool
forall a. Set a -> Bool
Set.null) (Map (Credential Staking) (Set Reward)
 -> Map (Credential Staking) (Set Reward))
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (Set Reward)
forall a b. (a -> b) -> a -> b
$ ((Reward, Set Reward) -> Set Reward)
-> Map (Credential Staking) (Reward, Set Reward)
-> Map (Credential Staking) (Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Reward, Set Reward) -> Set Reward
forall a b. (a, b) -> b
snd Map (Credential Staking) (Reward, Set Reward)
mp)

-- | for each (Set (Reward c)) entry in the map, sum up the coin. In the ShelleyEra
--   some of the coins are ignored (because of backward compatibility) see 'filterRewards'
--   Note that domain of the returned map is a subset of the input map 'rewards'
aggregateRewards ::
  ProtVer ->
  Map (Credential Staking) (Set Reward) ->
  Map (Credential Staking) Coin
aggregateRewards :: ProtVer
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) Coin
aggregateRewards ProtVer
pv Map (Credential Staking) (Set Reward)
rewards =
  (Set Reward -> Coin)
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Reward -> Coin) -> Set Reward -> Coin
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Reward -> Coin
rewardAmount) (Map (Credential Staking) (Set Reward)
 -> Map (Credential Staking) Coin)
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) Coin
forall a b. (a -> b) -> a -> b
$ (Map (Credential Staking) (Set Reward),
 Map (Credential Staking) (Set Reward))
-> Map (Credential Staking) (Set Reward)
forall a b. (a, b) -> a
fst ((Map (Credential Staking) (Set Reward),
  Map (Credential Staking) (Set Reward))
 -> Map (Credential Staking) (Set Reward))
-> (Map (Credential Staking) (Set Reward),
    Map (Credential Staking) (Set Reward))
-> Map (Credential Staking) (Set Reward)
forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential Staking) (Set Reward)
-> (Map (Credential Staking) (Set Reward),
    Map (Credential Staking) (Set Reward))
filterRewards ProtVer
pv Map (Credential Staking) (Set Reward)
rewards

-- ================================================
-- Compact Coin versions of sumRewards and aggregateCompactRewards

sumCompactRewards ::
  ProtVer ->
  Map (Credential Staking) (Set Reward) ->
  CompactForm Coin
sumCompactRewards :: ProtVer
-> Map (Credential Staking) (Set Reward) -> CompactForm Coin
sumCompactRewards ProtVer
protocolVersion Map (Credential Staking) (Set Reward)
rs = Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (CompactForm Coin)
aggregateCompactRewards ProtVer
protocolVersion Map (Credential Staking) (Set Reward)
rs

-- | for each (Set (Reward c)) entry in the map, sum up the coin. In the ShelleyEra
--   some of the coins are ignored (because of backward compatibility) see 'filterRewards'
--   Note that the domain of the output map is a subset of the domain of the input rewards.
aggregateCompactRewards ::
  ProtVer ->
  Map (Credential Staking) (Set Reward) ->
  Map (Credential Staking) (CompactForm Coin)
aggregateCompactRewards :: ProtVer
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (CompactForm Coin)
aggregateCompactRewards ProtVer
pv Map (Credential Staking) (Set Reward)
rewards =
  (Set Reward -> CompactForm Coin)
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (CompactForm Coin)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Reward -> CompactForm Coin) -> Set Reward -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError (Coin -> CompactForm Coin)
-> (Reward -> Coin) -> Reward -> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reward -> Coin
rewardAmount)) (Map (Credential Staking) (Set Reward)
 -> Map (Credential Staking) (CompactForm Coin))
-> Map (Credential Staking) (Set Reward)
-> Map (Credential Staking) (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$ (Map (Credential Staking) (Set Reward),
 Map (Credential Staking) (Set Reward))
-> Map (Credential Staking) (Set Reward)
forall a b. (a, b) -> a
fst ((Map (Credential Staking) (Set Reward),
  Map (Credential Staking) (Set Reward))
 -> Map (Credential Staking) (Set Reward))
-> (Map (Credential Staking) (Set Reward),
    Map (Credential Staking) (Set Reward))
-> Map (Credential Staking) (Set Reward)
forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential Staking) (Set Reward)
-> (Map (Credential Staking) (Set Reward),
    Map (Credential Staking) (Set Reward))
filterRewards ProtVer
pv Map (Credential Staking) (Set Reward)
rewards

-- We argue that the call to 'compactCoinOrError' will never return error.
-- The Reward is stored in the LedgerState, and we know the sum of all Ada in the LedgerState cannot
-- exceed (maxBound :: Word64), So if the sum cannot exceed it, neither can any component of the sum.
-- We need a (CompactForm Coin) because the reward map is stored in the UMap, which stores rewards
-- as (CompactForm Coin). And aggregateRewards is used to update that part of the UMap.
-- See  Cardano.Ledger.Shelley.LedgerState.IncrementalStake(applyRUpdFiltered)

-- =====================================================

data LeaderOnlyReward = LeaderOnlyReward
  { LeaderOnlyReward -> KeyHash StakePool
lRewardPool :: !(KeyHash StakePool)
  , LeaderOnlyReward -> Coin
lRewardAmount :: !Coin
  }
  deriving (LeaderOnlyReward -> LeaderOnlyReward -> Bool
(LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> (LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> Eq LeaderOnlyReward
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
== :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c/= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
/= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
Eq, Eq LeaderOnlyReward
Eq LeaderOnlyReward =>
(LeaderOnlyReward -> LeaderOnlyReward -> Ordering)
-> (LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> (LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> (LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> (LeaderOnlyReward -> LeaderOnlyReward -> Bool)
-> (LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward)
-> (LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward)
-> Ord LeaderOnlyReward
LeaderOnlyReward -> LeaderOnlyReward -> Bool
LeaderOnlyReward -> LeaderOnlyReward -> Ordering
LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LeaderOnlyReward -> LeaderOnlyReward -> Ordering
compare :: LeaderOnlyReward -> LeaderOnlyReward -> Ordering
$c< :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
< :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c<= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
<= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c> :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
> :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c>= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
>= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$cmax :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
max :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
$cmin :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
min :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
Ord, Int -> LeaderOnlyReward -> ShowS
[LeaderOnlyReward] -> ShowS
LeaderOnlyReward -> String
(Int -> LeaderOnlyReward -> ShowS)
-> (LeaderOnlyReward -> String)
-> ([LeaderOnlyReward] -> ShowS)
-> Show LeaderOnlyReward
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeaderOnlyReward -> ShowS
showsPrec :: Int -> LeaderOnlyReward -> ShowS
$cshow :: LeaderOnlyReward -> String
show :: LeaderOnlyReward -> String
$cshowList :: [LeaderOnlyReward] -> ShowS
showList :: [LeaderOnlyReward] -> ShowS
Show, (forall x. LeaderOnlyReward -> Rep LeaderOnlyReward x)
-> (forall x. Rep LeaderOnlyReward x -> LeaderOnlyReward)
-> Generic LeaderOnlyReward
forall x. Rep LeaderOnlyReward x -> LeaderOnlyReward
forall x. LeaderOnlyReward -> Rep LeaderOnlyReward x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeaderOnlyReward -> Rep LeaderOnlyReward x
from :: forall x. LeaderOnlyReward -> Rep LeaderOnlyReward x
$cto :: forall x. Rep LeaderOnlyReward x -> LeaderOnlyReward
to :: forall x. Rep LeaderOnlyReward x -> LeaderOnlyReward
Generic)

instance NoThunks LeaderOnlyReward

instance NFData LeaderOnlyReward

instance EncCBOR LeaderOnlyReward where
  encCBOR :: LeaderOnlyReward -> Encoding
encCBOR (LeaderOnlyReward KeyHash StakePool
pool Coin
c) = Encode (Closed Dense) LeaderOnlyReward -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode (Closed Dense) LeaderOnlyReward -> Encoding)
-> Encode (Closed Dense) LeaderOnlyReward -> Encoding
forall a b. (a -> b) -> a -> b
$ (KeyHash StakePool -> Coin -> LeaderOnlyReward)
-> Encode
     (Closed Dense) (KeyHash StakePool -> Coin -> LeaderOnlyReward)
forall t. t -> Encode (Closed Dense) t
Rec KeyHash StakePool -> Coin -> LeaderOnlyReward
LeaderOnlyReward Encode
  (Closed Dense) (KeyHash StakePool -> Coin -> LeaderOnlyReward)
-> Encode (Closed Dense) (KeyHash StakePool)
-> Encode (Closed Dense) (Coin -> LeaderOnlyReward)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> KeyHash StakePool -> Encode (Closed Dense) (KeyHash StakePool)
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To KeyHash StakePool
pool Encode (Closed Dense) (Coin -> LeaderOnlyReward)
-> Encode (Closed Dense) Coin
-> Encode (Closed Dense) LeaderOnlyReward
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Coin -> Encode (Closed Dense) Coin
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Coin
c

instance DecCBOR LeaderOnlyReward where
  decCBOR :: forall s. Decoder s LeaderOnlyReward
decCBOR = Decode (Closed Dense) LeaderOnlyReward
-> Decoder s LeaderOnlyReward
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode (Closed Dense) LeaderOnlyReward
 -> Decoder s LeaderOnlyReward)
-> Decode (Closed Dense) LeaderOnlyReward
-> Decoder s LeaderOnlyReward
forall a b. (a -> b) -> a -> b
$ (KeyHash StakePool -> Coin -> LeaderOnlyReward)
-> Decode
     (Closed Dense) (KeyHash StakePool -> Coin -> LeaderOnlyReward)
forall t. t -> Decode (Closed Dense) t
RecD KeyHash StakePool -> Coin -> LeaderOnlyReward
LeaderOnlyReward Decode
  (Closed Dense) (KeyHash StakePool -> Coin -> LeaderOnlyReward)
-> Decode (Closed (ZonkAny 4)) (KeyHash StakePool)
-> Decode (Closed Dense) (Coin -> LeaderOnlyReward)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 4)) (KeyHash StakePool)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode (Closed Dense) (Coin -> LeaderOnlyReward)
-> Decode (Closed (ZonkAny 3)) Coin
-> Decode (Closed Dense) LeaderOnlyReward
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 3)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From

leaderRewardToGeneral :: LeaderOnlyReward -> Reward
leaderRewardToGeneral :: LeaderOnlyReward -> Reward
leaderRewardToGeneral (LeaderOnlyReward KeyHash StakePool
poolId Coin
r) = RewardType -> KeyHash StakePool -> Coin -> Reward
Reward RewardType
LeaderReward KeyHash StakePool
poolId Coin
r

-- | Stake Pool specific information needed to compute the rewards
-- for its members.
data PoolRewardInfo = PoolRewardInfo
  { PoolRewardInfo -> StakeShare
poolRelativeStake :: !StakeShare
  -- ^ The stake pool's stake divided by the total stake
  , PoolRewardInfo -> Coin
poolPot :: !Coin
  -- ^ The maximum rewards available for the entire pool
  , PoolRewardInfo -> StakePoolSnapShot
poolPs :: !StakePoolSnapShot
  -- ^ The snapshot from stake pool state
  , PoolRewardInfo -> Natural
poolBlocks :: !Natural
  -- ^ The number of blocks the stake pool produced
  , PoolRewardInfo -> LeaderOnlyReward
poolLeaderReward :: !LeaderOnlyReward
  -- ^ The leader reward
  }
  deriving (Int -> PoolRewardInfo -> ShowS
[PoolRewardInfo] -> ShowS
PoolRewardInfo -> String
(Int -> PoolRewardInfo -> ShowS)
-> (PoolRewardInfo -> String)
-> ([PoolRewardInfo] -> ShowS)
-> Show PoolRewardInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PoolRewardInfo -> ShowS
showsPrec :: Int -> PoolRewardInfo -> ShowS
$cshow :: PoolRewardInfo -> String
show :: PoolRewardInfo -> String
$cshowList :: [PoolRewardInfo] -> ShowS
showList :: [PoolRewardInfo] -> ShowS
Show, PoolRewardInfo -> PoolRewardInfo -> Bool
(PoolRewardInfo -> PoolRewardInfo -> Bool)
-> (PoolRewardInfo -> PoolRewardInfo -> Bool) -> Eq PoolRewardInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PoolRewardInfo -> PoolRewardInfo -> Bool
== :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c/= :: PoolRewardInfo -> PoolRewardInfo -> Bool
/= :: PoolRewardInfo -> PoolRewardInfo -> Bool
Eq, (forall x. PoolRewardInfo -> Rep PoolRewardInfo x)
-> (forall x. Rep PoolRewardInfo x -> PoolRewardInfo)
-> Generic PoolRewardInfo
forall x. Rep PoolRewardInfo x -> PoolRewardInfo
forall x. PoolRewardInfo -> Rep PoolRewardInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PoolRewardInfo -> Rep PoolRewardInfo x
from :: forall x. PoolRewardInfo -> Rep PoolRewardInfo x
$cto :: forall x. Rep PoolRewardInfo x -> PoolRewardInfo
to :: forall x. Rep PoolRewardInfo x -> PoolRewardInfo
Generic)

instance NoThunks PoolRewardInfo

instance NFData PoolRewardInfo

instance EncCBOR PoolRewardInfo where
  encCBOR :: PoolRewardInfo -> Encoding
encCBOR
    (PoolRewardInfo StakeShare
a Coin
b StakePoolSnapShot
c Natural
d LeaderOnlyReward
e) =
      Encode (Closed Dense) PoolRewardInfo -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode (Closed Dense) PoolRewardInfo -> Encoding)
-> Encode (Closed Dense) PoolRewardInfo -> Encoding
forall a b. (a -> b) -> a -> b
$
        (StakeShare
 -> Coin
 -> StakePoolSnapShot
 -> Natural
 -> LeaderOnlyReward
 -> PoolRewardInfo)
-> Encode
     (Closed Dense)
     (StakeShare
      -> Coin
      -> StakePoolSnapShot
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall t. t -> Encode (Closed Dense) t
Rec StakeShare
-> Coin
-> StakePoolSnapShot
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          Encode
  (Closed Dense)
  (StakeShare
   -> Coin
   -> StakePoolSnapShot
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Encode (Closed Dense) StakeShare
-> Encode
     (Closed Dense)
     (Coin
      -> StakePoolSnapShot
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> (StakeShare -> Encoding)
-> StakeShare -> Encode (Closed Dense) StakeShare
forall t. (t -> Encoding) -> t -> Encode (Closed Dense) t
E (Rational -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Rational -> Encoding)
-> (StakeShare -> Rational) -> StakeShare -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeShare -> Rational
unStakeShare) StakeShare
a
          Encode
  (Closed Dense)
  (Coin
   -> StakePoolSnapShot
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Encode (Closed Dense) Coin
-> Encode
     (Closed Dense)
     (StakePoolSnapShot
      -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Coin -> Encode (Closed Dense) Coin
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Coin
b
          Encode
  (Closed Dense)
  (StakePoolSnapShot
   -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Encode (Closed Dense) StakePoolSnapShot
-> Encode
     (Closed Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> StakePoolSnapShot -> Encode (Closed Dense) StakePoolSnapShot
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To StakePoolSnapShot
c
          Encode
  (Closed Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Encode (Closed Dense) Natural
-> Encode (Closed Dense) (LeaderOnlyReward -> PoolRewardInfo)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Natural -> Encode (Closed Dense) Natural
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Natural
d
          Encode (Closed Dense) (LeaderOnlyReward -> PoolRewardInfo)
-> Encode (Closed Dense) LeaderOnlyReward
-> Encode (Closed Dense) PoolRewardInfo
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> LeaderOnlyReward -> Encode (Closed Dense) LeaderOnlyReward
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To LeaderOnlyReward
e

instance DecCBOR PoolRewardInfo where
  decCBOR :: forall s. Decoder s PoolRewardInfo
decCBOR =
    Decode (Closed Dense) PoolRewardInfo -> Decoder s PoolRewardInfo
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode
      ( (StakeShare
 -> Coin
 -> StakePoolSnapShot
 -> Natural
 -> LeaderOnlyReward
 -> PoolRewardInfo)
-> Decode
     (Closed Dense)
     (StakeShare
      -> Coin
      -> StakePoolSnapShot
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall t. t -> Decode (Closed Dense) t
RecD StakeShare
-> Coin
-> StakePoolSnapShot
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          Decode
  (Closed Dense)
  (StakeShare
   -> Coin
   -> StakePoolSnapShot
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Decode (Closed Dense) StakeShare
-> Decode
     (Closed Dense)
     (Coin
      -> StakePoolSnapShot
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! (forall s. Decoder s StakeShare)
-> Decode (Closed Dense) StakeShare
forall t. (forall s. Decoder s t) -> Decode (Closed Dense) t
D (Rational -> StakeShare
StakeShare (Rational -> StakeShare)
-> Decoder s Rational -> Decoder s StakeShare
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Rational
forall s. Decoder s Rational
forall a s. DecCBOR a => Decoder s a
decCBOR)
          Decode
  (Closed Dense)
  (Coin
   -> StakePoolSnapShot
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Decode (Closed (ZonkAny 2)) Coin
-> Decode
     (Closed Dense)
     (StakePoolSnapShot
      -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 2)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          Decode
  (Closed Dense)
  (StakePoolSnapShot
   -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Decode (Closed Dense) StakePoolSnapShot
-> Decode
     (Closed Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! (forall s. Decoder s StakePoolSnapShot)
-> Decode (Closed Dense) StakePoolSnapShot
forall t. (forall s. Decoder s t) -> Decode (Closed Dense) t
D Decoder s StakePoolSnapShot
forall s. Decoder s StakePoolSnapShot
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR
          Decode
  (Closed Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Decode (Closed (ZonkAny 1)) Natural
-> Decode (Closed Dense) (LeaderOnlyReward -> PoolRewardInfo)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 1)) Natural
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          Decode (Closed Dense) (LeaderOnlyReward -> PoolRewardInfo)
-> Decode (Closed (ZonkAny 0)) LeaderOnlyReward
-> Decode (Closed Dense) PoolRewardInfo
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 0)) LeaderOnlyReward
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      )

notPoolOwner ::
  Set (KeyHash Staking) ->
  Credential Staking ->
  Bool
notPoolOwner :: Set (KeyHash Staking) -> Credential Staking -> Bool
notPoolOwner Set (KeyHash Staking)
owners = \case
  KeyHashObj KeyHash Staking
hk -> KeyHash Staking
hk KeyHash Staking -> Set (KeyHash Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash Staking)
owners
  ScriptHashObj ScriptHash
_ -> Bool
True

-- | The stake pool member reward calculation
rewardOnePoolMember ::
  -- | The protocol version
  ProtVer ->
  -- | The total amount of stake in the system
  Coin ->
  -- | The set of registered stake credentials
  Set (Credential Staking) ->
  -- | Stake pool specific intermediate values needed
  -- to compute member rewards.
  PoolRewardInfo ->
  -- | The stake credential whose reward is being calculated.
  Credential Staking ->
  -- | The stake controlled by the stake credential
  -- in the previous parameter above.
  Coin ->
  -- | The reward for the given stake credential.
  -- This could be Nothing if the credential is no longer registered,
  -- if it is an owner, or if the reward is zero.
  Maybe Coin
rewardOnePoolMember :: ProtVer
-> Coin
-> Set (Credential Staking)
-> PoolRewardInfo
-> Credential Staking
-> Coin
-> Maybe Coin
rewardOnePoolMember ProtVer
pv Coin
totalStake Set (Credential Staking)
addrsRew PoolRewardInfo
rewardInfo Credential Staking
hk (Coin Integer
c) =
  if Bool
prefilter Bool -> Bool -> Bool
&& Set (KeyHash Staking) -> Credential Staking -> Bool
notPoolOwner (StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwners (PoolRewardInfo -> StakePoolSnapShot
poolPs PoolRewardInfo
rewardInfo)) Credential Staking
hk Bool -> Bool -> Bool
&& Coin
r Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0
    then Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
r
    else Maybe Coin
forall a. Maybe a
Nothing
  where
    prefilter :: Bool
prefilter = ProtVer -> Bool
hardforkBabbageForgoRewardPrefilter ProtVer
pv Bool -> Bool -> Bool
|| Credential Staking
hk Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Credential Staking)
addrsRew
    StakePoolSnapShot {Coin
spssCost :: Coin
spssCost :: StakePoolSnapShot -> Coin
spssCost, UnitInterval
spssMargin :: UnitInterval
spssMargin :: StakePoolSnapShot -> UnitInterval
spssMargin} = PoolRewardInfo -> StakePoolSnapShot
poolPs PoolRewardInfo
rewardInfo
    sigma :: StakeShare
sigma = PoolRewardInfo -> StakeShare
poolRelativeStake PoolRewardInfo
rewardInfo
    poolR :: Coin
poolR = PoolRewardInfo -> Coin
poolPot PoolRewardInfo
rewardInfo
    -- warning: totalStake could be zero!
    stakeShare :: StakeShare
stakeShare = Rational -> StakeShare
StakeShare (Rational -> StakeShare) -> Rational -> StakeShare
forall a b. (a -> b) -> a -> b
$ Integer
c Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Coin -> Integer
unCoin Coin
totalStake
    r :: Coin
r = Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolMemberReward Coin
poolR Coin
spssCost UnitInterval
spssMargin StakeShare
stakeShare StakeShare
sigma

-- | Calculate single stake pool specific values for the reward computation.
--
-- Note that if a stake pool has made no blocks in the given epoch, it will
-- get no rewards, and so we do not need to return 'PoolRewardInfo'. We do,
-- however, need to return the relative stake of the pool in order to
-- compute data for the stake pool ranking. Eventually we will remove
-- the ranking information out of the ledger code and into a separate service,
-- and at that point we can simplify this function to not care about ranking.
mkPoolRewardInfo ::
  EraPParams era =>
  PParams era ->
  Coin ->
  BlocksMade ->
  Natural ->
  Stake ->
  VMap.VMap VMap.VB VMap.VB (Credential Staking) (KeyHash StakePool) ->
  Coin ->
  NonZero Coin ->
  VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) StakePoolParams -> -- TODO: remove
  KeyHash StakePool ->
  StakePoolSnapShot ->
  Either StakeShare PoolRewardInfo
mkPoolRewardInfo :: forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Coin
-> NonZero Coin
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> KeyHash StakePool
-> StakePoolSnapShot
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
  PParams era
pp
  Coin
r
  BlocksMade
blocks
  Natural
blocksTotal
  Stake
stake
  VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
  (Coin Integer
totalStake)
  NonZero Coin
totalActiveStake
  VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools
  KeyHash StakePool
stakePoolId
  StakePoolSnapShot
stakePoolSnapShot =
    case KeyHash StakePool
-> Map (KeyHash StakePool) Natural -> Maybe Natural
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
stakePoolId (BlocksMade -> Map (KeyHash StakePool) Natural
unBlocksMade BlocksMade
blocks) of
      -- This pool made no blocks this epoch. For the purposes of stake pool
      -- ranking only, we return the relative stake of this pool so that we
      -- can judge how likely it was that this pool made no blocks.
      Maybe Natural
Nothing -> StakeShare -> Either StakeShare PoolRewardInfo
forall a b. a -> Either a b
Left (StakeShare -> Either StakeShare PoolRewardInfo)
-> StakeShare -> Either StakeShare PoolRewardInfo
forall a b. (a -> b) -> a -> b
$! Rational -> StakeShare
StakeShare Rational
sigma
      -- This pool made some blocks, so we can proceed to calculate the
      -- intermediate values needed for the individual reward calculations.
      Just Natural
numBlocksMade ->
        let Coin Integer
maxP =
              if Integer
pledge Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
selfDelegatedOwnersStake
                then NonNegativeInterval
-> NonZero Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
pp_a0 NonZero Word16
pp_nOpt Coin
r Rational
sigma Rational
poolRelativePledge
                else Coin
forall a. Monoid a => a
mempty
            appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance UnitInterval
pp_d Rational
sigmaA Natural
numBlocksMade Natural
blocksTotal
            poolR :: Coin
poolR = Rational -> Coin
rationalToCoinViaFloor (Rational
appPerf Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxP)
            stakePoolOperatorReward :: Coin
stakePoolOperatorReward =
              Coin -> Coin -> UnitInterval -> StakeShare -> StakeShare -> Coin
calcStakePoolOperatorReward
                Coin
poolR
                (StakePoolSnapShot -> Coin
spssCost StakePoolSnapShot
stakePoolSnapShot)
                (StakePoolSnapShot -> UnitInterval
spssMargin StakePoolSnapShot
stakePoolSnapShot)
                (Rational -> StakeShare
StakeShare Rational
poolOwnerRelativeStake)
                (Rational -> StakeShare
StakeShare Rational
sigma)
            rewardInfo :: PoolRewardInfo
rewardInfo =
              PoolRewardInfo
                { poolRelativeStake :: StakeShare
poolRelativeStake = Rational -> StakeShare
StakeShare Rational
sigma
                , poolPot :: Coin
poolPot = Coin
poolR
                , poolPs :: StakePoolSnapShot
poolPs = StakePoolSnapShot
stakePoolSnapShot
                , poolBlocks :: Natural
poolBlocks = Natural
numBlocksMade
                , poolLeaderReward :: LeaderOnlyReward
poolLeaderReward = KeyHash StakePool -> Coin -> LeaderOnlyReward
LeaderOnlyReward KeyHash StakePool
stakePoolId Coin
stakePoolOperatorReward
                }
            showFailure :: a
showFailure =
              String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
                String
"OwnerStake is not the same:\nOld OwnerStake:\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
selfDelegatedOwnersStake
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nNew wnerStake:\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
poolOwnerStakeOld
         in Bool
-> Either StakeShare PoolRewardInfo
-> Either StakeShare PoolRewardInfo
forall a. HasCallStack => Bool -> a -> a
assert (Integer
selfDelegatedOwnersStake Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
poolOwnerStakeOld Bool -> Bool -> Bool
|| Bool
forall {a}. a
showFailure) (PoolRewardInfo -> Either StakeShare PoolRewardInfo
forall a b. b -> Either a b
Right (PoolRewardInfo -> Either StakeShare PoolRewardInfo)
-> PoolRewardInfo -> Either StakeShare PoolRewardInfo
forall a b. (a -> b) -> a -> b
$! PoolRewardInfo
rewardInfo)
    where
      pp_d :: UnitInterval
pp_d = PParams era
pp PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG
      pp_a0 :: NonNegativeInterval
pp_a0 = PParams era
pp PParams era
-> Getting NonNegativeInterval (PParams era) NonNegativeInterval
-> NonNegativeInterval
forall s a. s -> Getting a s a -> a
^. Getting NonNegativeInterval (PParams era) NonNegativeInterval
forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams era) NonNegativeInterval
ppA0L
      pp_nOpt :: NonZero Word16
pp_nOpt = (PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppNOptL) Word16 -> NonZero Word16 -> NonZero Word16
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` String -> NonZero Word16
forall a. HasCallStack => String -> a
error String
"nOpt is zero"
      Coin Integer
poolTotalStake = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (StakePoolSnapShot -> CompactForm Coin
spssStake StakePoolSnapShot
stakePoolSnapShot)
      accOwnerStake :: CompactForm Coin -> KeyHash Staking -> CompactForm Coin
accOwnerStake CompactForm Coin
c KeyHash Staking
o = CompactForm Coin
-> (CompactForm Coin -> CompactForm Coin)
-> Maybe (CompactForm Coin)
-> CompactForm Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CompactForm Coin
c (CompactForm Coin
c CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<>) (Maybe (CompactForm Coin) -> CompactForm Coin)
-> Maybe (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ do
        hk <- Credential Staking
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Maybe (KeyHash StakePool)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
o) VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
        guard (hk == stakePoolId)
        VMap.lookup (KeyHashObj o) (unStake stake)
      Coin Integer
poolOwnerStakeOld =
        case KeyHash StakePool
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> Maybe StakePoolParams
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup KeyHash StakePool
stakePoolId VMap VB VB (KeyHash StakePool) StakePoolParams
stakePools of
          Maybe StakePoolParams
Nothing ->
            String -> Coin
forall a. HasCallStack => String -> a
error (String -> Coin) -> String -> Coin
forall a b. (a -> b) -> a -> b
$ String
"Impossible: Transition to StakePoolSnapShot is missing relevant pool: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KeyHash StakePool -> String
forall a. Show a => a -> String
show KeyHash StakePool
stakePoolId
          Just StakePoolParams
pool ->
            CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (CompactForm Coin -> KeyHash Staking -> CompactForm Coin)
-> CompactForm Coin -> Set (KeyHash Staking) -> CompactForm Coin
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' CompactForm Coin -> KeyHash Staking -> CompactForm Coin
accOwnerStake CompactForm Coin
forall a. Monoid a => a
mempty (StakePoolParams -> Set (KeyHash Staking)
sppOwners StakePoolParams
pool)
      Coin Integer
selfDelegatedOwnersStake = StakePoolSnapShot -> Coin
spssSelfDelegatedOwnersStake StakePoolSnapShot
stakePoolSnapShot
      Coin Integer
pledge = StakePoolSnapShot -> Coin
spssPledge StakePoolSnapShot
stakePoolSnapShot
      -- warning: In theory `totalStake` and `totalActiveStake` could be zero, but that would imply no
      -- active stake pools and no delegators, which would mean PoS would be dead!
      poolRelativePledge :: Rational
poolRelativePledge = Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake
      poolOwnerRelativeStake :: Rational
poolOwnerRelativeStake = Integer
selfDelegatedOwnersStake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Integer
totalStake
      sigma :: Rational
sigma = Integer
poolTotalStake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Integer
totalStake
      sigmaA :: Rational
sigmaA = Integer
poolTotalStake Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. NonZero Coin -> NonZero Integer
unCoinNonZero NonZero Coin
totalActiveStake