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

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

import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  BoundedRational (..),
  ProtVer,
  UnitInterval,
  nonZeroOr,
  (%?),
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm,
  coinToRational,
  rationalToCoinViaFloor,
 )
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.State (Stake (..), maxPool')
import Cardano.Ledger.UMap (compactCoinOrError)
import Cardano.Ledger.Val ((<->))
import Control.DeepSeq (NFData)
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 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocksN Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
1 Natural
blocksTotal)

-- | Calculate pool leader reward
leaderRew ::
  Coin ->
  PoolParams ->
  StakeShare ->
  StakeShare ->
  Coin
leaderRew :: Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
leaderRew Coin
f PoolParams
pool (StakeShare Rational
s) (StakeShare Rational
sigma)
  | Coin
f Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
c = Coin
f
  | Bool
otherwise =
      Coin
c
        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
c) 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
    c :: Coin
c = PoolParams -> Coin
ppCost PoolParams
pool
    m :: UnitInterval
m = PoolParams -> UnitInterval
ppMargin PoolParams
pool
    m' :: Rational
m' = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
m

-- | Calculate pool member reward
memberRew ::
  Coin ->
  PoolParams ->
  StakeShare ->
  StakeShare ->
  Coin
memberRew :: Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
memberRew (Coin Integer
f') PoolParams
pool (StakeShare Rational
t) (StakeShare Rational
sigma)
  | Integer
f' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c = 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
c) 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
    Coin Integer
c = PoolParams -> Coin
ppCost PoolParams
pool
    m :: UnitInterval
m = PoolParams -> UnitInterval
ppMargin PoolParams
pool
    m' :: Rational
m' = UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
m

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
HardForks.aggregatedRewards 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 Any) (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 Any) (KeyHash 'StakePool)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode ('Closed 'Dense) (Coin -> LeaderOnlyReward)
-> Decode ('Closed Any) 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 Any) 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 -> PoolParams
poolPs :: !PoolParams
  -- ^ The stake pool parameters
  , 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, Eq PoolRewardInfo
Eq PoolRewardInfo =>
(PoolRewardInfo -> PoolRewardInfo -> Ordering)
-> (PoolRewardInfo -> PoolRewardInfo -> Bool)
-> (PoolRewardInfo -> PoolRewardInfo -> Bool)
-> (PoolRewardInfo -> PoolRewardInfo -> Bool)
-> (PoolRewardInfo -> PoolRewardInfo -> Bool)
-> (PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo)
-> (PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo)
-> Ord PoolRewardInfo
PoolRewardInfo -> PoolRewardInfo -> Bool
PoolRewardInfo -> PoolRewardInfo -> Ordering
PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
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 :: PoolRewardInfo -> PoolRewardInfo -> Ordering
compare :: PoolRewardInfo -> PoolRewardInfo -> Ordering
$c< :: PoolRewardInfo -> PoolRewardInfo -> Bool
< :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c<= :: PoolRewardInfo -> PoolRewardInfo -> Bool
<= :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c> :: PoolRewardInfo -> PoolRewardInfo -> Bool
> :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c>= :: PoolRewardInfo -> PoolRewardInfo -> Bool
>= :: PoolRewardInfo -> PoolRewardInfo -> Bool
$cmax :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
max :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
$cmin :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
min :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
Ord, (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 PoolParams
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
 -> PoolParams
 -> Natural
 -> LeaderOnlyReward
 -> PoolRewardInfo)
-> Encode
     ('Closed 'Dense)
     (StakeShare
      -> Coin
      -> PoolParams
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall t. t -> Encode ('Closed 'Dense) t
Rec StakeShare
-> Coin
-> PoolParams
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          Encode
  ('Closed 'Dense)
  (StakeShare
   -> Coin
   -> PoolParams
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Encode ('Closed 'Dense) StakeShare
-> Encode
     ('Closed 'Dense)
     (Coin
      -> PoolParams -> 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
   -> PoolParams -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Encode ('Closed 'Dense) Coin
-> Encode
     ('Closed 'Dense)
     (PoolParams -> 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)
  (PoolParams -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Encode ('Closed 'Dense) PoolParams
-> Encode
     ('Closed 'Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PoolParams -> Encode ('Closed 'Dense) PoolParams
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PoolParams
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
 -> PoolParams
 -> Natural
 -> LeaderOnlyReward
 -> PoolRewardInfo)
-> Decode
     ('Closed 'Dense)
     (StakeShare
      -> Coin
      -> PoolParams
      -> Natural
      -> LeaderOnlyReward
      -> PoolRewardInfo)
forall t. t -> Decode ('Closed 'Dense) t
RecD StakeShare
-> Coin
-> PoolParams
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          Decode
  ('Closed 'Dense)
  (StakeShare
   -> Coin
   -> PoolParams
   -> Natural
   -> LeaderOnlyReward
   -> PoolRewardInfo)
-> Decode ('Closed 'Dense) StakeShare
-> Decode
     ('Closed 'Dense)
     (Coin
      -> PoolParams -> 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
   -> PoolParams -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Decode ('Closed Any) Coin
-> Decode
     ('Closed 'Dense)
     (PoolParams -> 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 Any) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          Decode
  ('Closed 'Dense)
  (PoolParams -> Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Decode ('Closed Any) PoolParams
-> 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
<! Decode ('Closed Any) PoolParams
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          Decode
  ('Closed 'Dense) (Natural -> LeaderOnlyReward -> PoolRewardInfo)
-> Decode ('Closed Any) 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 Any) Natural
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          Decode ('Closed 'Dense) (LeaderOnlyReward -> PoolRewardInfo)
-> Decode ('Closed Any) 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 Any) LeaderOnlyReward
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      )

notPoolOwner ::
  PoolParams ->
  Credential 'Staking ->
  Bool
notPoolOwner :: PoolParams -> Credential 'Staking -> Bool
notPoolOwner PoolParams
pps = \case
  KeyHashObj KeyHash 'Staking
hk -> KeyHash 'Staking
hk KeyHash 'Staking -> Set (KeyHash 'Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` PoolParams -> Set (KeyHash 'Staking)
ppOwners PoolParams
pps
  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
pp
  Coin
totalStake
  Set (Credential 'Staking)
addrsRew
  PoolRewardInfo
rewardInfo
  Credential 'Staking
hk
  (Coin Integer
c) =
    if Bool
prefilter Bool -> Bool -> Bool
&& PoolParams -> Credential 'Staking -> Bool
notPoolOwner (PoolRewardInfo -> PoolParams
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
HardForks.forgoRewardPrefilter ProtVer
pp 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
      pool :: PoolParams
pool = PoolRewardInfo -> PoolParams
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 -> PoolParams -> StakeShare -> StakeShare -> Coin
memberRew Coin
poolR PoolParams
pool 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) ->
  Map (KeyHash 'StakePool) Coin ->
  Coin ->
  Coin ->
  PoolParams ->
  Either StakeShare PoolRewardInfo
mkPoolRewardInfo :: forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade
-> Natural
-> Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) Coin
-> Coin
-> Coin
-> PoolParams
-> Either StakeShare PoolRewardInfo
mkPoolRewardInfo
  PParams era
pp
  Coin
r
  BlocksMade
blocks
  Natural
blocksTotal
  Stake
stake
  VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
  Map (KeyHash 'StakePool) Coin
stakePerPool
  Coin
totalStake
  Coin
activeStake
  PoolParams
pool = case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) Natural -> Maybe Natural
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) (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 no blocks, so we can proceed to calculate the
    -- intermediate values needed for the individual reward calculations.
    Just Natural
blocksN ->
      let Coin Integer
pledge = PoolParams -> Coin
ppPledge PoolParams
pool
          -- warning: totalStake could be zero!
          pledgeRelative :: Rational
pledgeRelative = Integer
pledge Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Coin -> Integer
unCoin Coin
totalStake
          sigmaA :: Rational
sigmaA = Integer
pstakeTot Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Coin -> Integer
unCoin Coin
activeStake
          Coin Integer
maxP =
            if Integer
pledge Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
ostake
              then NonNegativeInterval
-> NonZero Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
pp_a0 NonZero Word16
pp_nOpt Coin
r Rational
sigma Rational
pledgeRelative
              else Coin
forall a. Monoid a => a
mempty
          appPerf :: Rational
appPerf = UnitInterval -> Rational -> Natural -> Natural -> Rational
mkApparentPerformance UnitInterval
pp_d Rational
sigmaA Natural
blocksN 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)
          lreward :: Coin
lreward =
            Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
leaderRew
              Coin
poolR
              PoolParams
pool
              (Rational -> StakeShare
StakeShare (Rational -> StakeShare) -> Rational -> StakeShare
forall a b. (a -> b) -> a -> b
$ Integer
ostake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Coin -> Integer
unCoin Coin
totalStake)
              (Rational -> StakeShare
StakeShare Rational
sigma)
          rewardInfo :: PoolRewardInfo
rewardInfo =
            PoolRewardInfo
              { poolRelativeStake :: StakeShare
poolRelativeStake = Rational -> StakeShare
StakeShare Rational
sigma
              , poolPot :: Coin
poolPot = Coin
poolR
              , poolPs :: PoolParams
poolPs = PoolParams
pool
              , poolBlocks :: Natural
poolBlocks = Natural
blocksN
              , poolLeaderReward :: LeaderOnlyReward
poolLeaderReward = KeyHash 'StakePool -> Coin -> LeaderOnlyReward
LeaderOnlyReward (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) Coin
lreward
              }
       in 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
pstakeTot = Coin -> KeyHash 'StakePool -> Map (KeyHash 'StakePool) Coin -> Coin
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Coin
forall a. Monoid a => a
mempty (PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool) Map (KeyHash 'StakePool) Coin
stakePerPool
      accOwnerStake :: Coin -> KeyHash 'Staking -> Coin
accOwnerStake Coin
c KeyHash 'Staking
o = Coin -> (Coin -> Coin) -> Maybe Coin -> Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
c (Coin
c Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<>) (Maybe Coin -> Coin) -> Maybe Coin -> Coin
forall a b. (a -> b) -> a -> b
$ do
        KeyHash 'StakePool
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
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (KeyHash 'StakePool
hk KeyHash 'StakePool -> KeyHash 'StakePool -> Bool
forall a. Eq a => a -> a -> Bool
== PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool)
        CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> Maybe (CompactForm Coin) -> Maybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential 'Staking
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Maybe (CompactForm Coin)
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) (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake Stake
stake)
      Coin Integer
ostake = (Coin -> KeyHash 'Staking -> Coin)
-> Coin -> Set (KeyHash 'Staking) -> Coin
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Coin -> KeyHash 'Staking -> Coin
accOwnerStake Coin
forall a. Monoid a => a
mempty (PoolParams -> Set (KeyHash 'Staking)
ppOwners PoolParams
pool)
      sigma :: Rational
sigma = Integer
pstakeTot Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Coin -> Integer
unCoin Coin
totalStake