{-# 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,
 )
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.EpochBoundary (Stake (..), maxPool')
import Cardano.Ledger.PoolParams (PoolParams (..))
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
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. 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
$cto :: forall x. Rep StakeShare x -> StakeShare
$cfrom :: forall x. StakeShare -> Rep StakeShare x
Generic, Eq 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
min :: StakeShare -> StakeShare -> StakeShare
$cmin :: StakeShare -> StakeShare -> StakeShare
max :: StakeShare -> StakeShare -> StakeShare
$cmax :: StakeShare -> StakeShare -> StakeShare
>= :: StakeShare -> StakeShare -> Bool
$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
compare :: StakeShare -> StakeShare -> Ordering
$ccompare :: StakeShare -> StakeShare -> Ordering
Ord, StakeShare -> StakeShare -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StakeShare -> StakeShare -> Bool
$c/= :: StakeShare -> StakeShare -> Bool
== :: StakeShare -> StakeShare -> Bool
$c== :: StakeShare -> StakeShare -> Bool
Eq, Context -> StakeShare -> IO (Maybe ThunkInfo)
Proxy StakeShare -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy StakeShare -> String
$cshowTypeOf :: Proxy StakeShare -> String
wNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
noThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> StakeShare -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> StakeShare -> ShowS
[StakeShare] -> ShowS
StakeShare -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StakeShare] -> ShowS
$cshowList :: [StakeShare] -> ShowS
show :: StakeShare -> String
$cshow :: StakeShare -> String
showsPrec :: Int -> StakeShare -> ShowS
$cshowsPrec :: Int -> 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 forall a. Eq a => a -> a -> Bool
== Rational
0 = Rational
0
  | forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
d_ forall a. Ord a => a -> a -> Bool
< Rational
0.8 = Rational
beta forall a. Fractional a => a -> a -> a
/ Rational
sigma
  | Bool
otherwise = Rational
1
  where
    beta :: Rational
beta = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
blocksN forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 forall a. Ord a => a -> a -> Bool
<= Coin
c = Coin
f
  | Bool
otherwise =
      Coin
c
        forall a. Semigroup a => a -> a -> a
<> Rational -> Coin
rationalToCoinViaFloor
          (Coin -> Rational
coinToRational (Coin
f forall t. Val t => t -> t -> t
<-> Coin
c) forall a. Num a => a -> a -> a
* (Rational
m' forall a. Num a => a -> a -> a
+ (Rational
1 forall a. Num a => a -> a -> a
- Rational
m') forall a. Num a => a -> a -> a
* Rational
s 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' = 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' forall a. Ord a => a -> a -> Bool
<= Integer
c = forall a. Monoid a => a
mempty
  | Bool
otherwise =
      Rational -> Coin
rationalToCoinViaFloor forall a b. (a -> b) -> a -> b
$
        forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
f' forall a. Num a => a -> a -> a
- Integer
c) forall a. Num a => a -> a -> a
* (Rational
1 forall a. Num a => a -> a -> a
- Rational
m') forall a. Num a => a -> a -> a
* Rational
t 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' = 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 = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold 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, forall k a. Map k a
Map.empty)
    else
      let mp :: Map (Credential 'Staking) (Reward, Set Reward)
mp = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. Set a -> (a, Set a)
Set.deleteFindMin Map (Credential 'Staking) (Set Reward)
rewards
       in (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a. a -> Set a
Set.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Map (Credential 'Staking) (Reward, Set Reward)
mp, forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map 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 =
  forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Reward -> Coin
rewardAmount) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst 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 = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold 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 =
  forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (HasCallStack => Coin -> CompactForm Coin
compactCoinOrError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reward -> Coin
rewardAmount)) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c/= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
== :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$c== :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
Eq, Eq 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
min :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
$cmin :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
max :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
$cmax :: LeaderOnlyReward -> LeaderOnlyReward -> LeaderOnlyReward
>= :: LeaderOnlyReward -> LeaderOnlyReward -> Bool
$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
compare :: LeaderOnlyReward -> LeaderOnlyReward -> Ordering
$ccompare :: LeaderOnlyReward -> LeaderOnlyReward -> Ordering
Ord, Int -> LeaderOnlyReward -> ShowS
[LeaderOnlyReward] -> ShowS
LeaderOnlyReward -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LeaderOnlyReward] -> ShowS
$cshowList :: [LeaderOnlyReward] -> ShowS
show :: LeaderOnlyReward -> String
$cshow :: LeaderOnlyReward -> String
showsPrec :: Int -> LeaderOnlyReward -> ShowS
$cshowsPrec :: Int -> LeaderOnlyReward -> ShowS
Show, 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
$cto :: forall x. Rep LeaderOnlyReward x -> LeaderOnlyReward
$cfrom :: forall x. LeaderOnlyReward -> Rep LeaderOnlyReward x
Generic)

instance NoThunks LeaderOnlyReward

instance NFData LeaderOnlyReward

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

instance DecCBOR LeaderOnlyReward where
  decCBOR :: forall s. Decoder s LeaderOnlyReward
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t. t -> Decode ('Closed 'Dense) t
RecD KeyHash 'StakePool -> Coin -> LeaderOnlyReward
LeaderOnlyReward forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolRewardInfo] -> ShowS
$cshowList :: [PoolRewardInfo] -> ShowS
show :: PoolRewardInfo -> String
$cshow :: PoolRewardInfo -> String
showsPrec :: Int -> PoolRewardInfo -> ShowS
$cshowsPrec :: Int -> PoolRewardInfo -> ShowS
Show, PoolRewardInfo -> PoolRewardInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c/= :: PoolRewardInfo -> PoolRewardInfo -> Bool
== :: PoolRewardInfo -> PoolRewardInfo -> Bool
$c== :: PoolRewardInfo -> PoolRewardInfo -> Bool
Eq, Eq 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
min :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
$cmin :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
max :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
$cmax :: PoolRewardInfo -> PoolRewardInfo -> PoolRewardInfo
>= :: PoolRewardInfo -> PoolRewardInfo -> Bool
$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
compare :: PoolRewardInfo -> PoolRewardInfo -> Ordering
$ccompare :: PoolRewardInfo -> PoolRewardInfo -> Ordering
Ord, 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
$cto :: forall x. Rep PoolRewardInfo x -> PoolRewardInfo
$cfrom :: forall x. PoolRewardInfo -> Rep PoolRewardInfo x
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) =
      forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
        forall t. t -> Encode ('Closed 'Dense) t
Rec StakeShare
-> Coin
-> PoolParams
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E (forall a. EncCBOR a => a -> Encoding
encCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeShare -> Rational
unStakeShare) StakeShare
a
          forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
b
          forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PoolParams
c
          forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Natural
d
          forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To LeaderOnlyReward
e

instance DecCBOR PoolRewardInfo where
  decCBOR :: forall s. Decoder s PoolRewardInfo
decCBOR =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode
      ( forall t. t -> Decode ('Closed 'Dense) t
RecD StakeShare
-> Coin
-> PoolParams
-> Natural
-> LeaderOnlyReward
-> PoolRewardInfo
PoolRewardInfo
          forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Rational -> StakeShare
StakeShare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR)
          forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
          forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! 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 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 Integer
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 forall a. Eq a => a -> a -> Bool
/= Integer -> Coin
Coin Integer
0
      then forall a. a -> Maybe a
Just Coin
r
      else forall a. Maybe a
Nothing
    where
      prefilter :: Bool
prefilter = ProtVer -> Bool
HardForks.forgoRewardPrefilter ProtVer
pp Bool -> Bool -> Bool
|| Credential 'Staking
hk 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
      r :: Coin
r = Coin -> PoolParams -> StakeShare -> StakeShare -> Coin
memberRew Coin
poolR PoolParams
pool (Rational -> StakeShare
StakeShare (Integer
c forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake)) 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 Integer
totalStake)
  (Coin Integer
activeStake)
  PoolParams
pool = case 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 -> forall a b. a -> Either a b
Left 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
          pledgeRelative :: Rational
pledgeRelative = Integer
pledge forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake
          sigmaA :: Rational
sigmaA = if Integer
activeStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else Integer
pstakeTot forall a. Integral a => a -> a -> Ratio a
% Integer
activeStake
          Coin Integer
maxP =
            if Integer
pledge forall a. Ord a => a -> a -> Bool
<= Integer
ostake
              then NonNegativeInterval
-> Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
pp_a0 Word16
pp_nOpt Coin
r Rational
sigma Rational
pledgeRelative
              else 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 forall a. Num a => a -> a -> a
* 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 forall a b. (a -> b) -> a -> b
$ if Integer
totalStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else Integer
ostake forall a. Integral a => a -> a -> Ratio a
% Integer
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 forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! PoolRewardInfo
rewardInfo
    where
      pp_d :: UnitInterval
pp_d = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
      pp_a0 :: NonNegativeInterval
pp_a0 = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L
      pp_nOpt :: Word16
pp_nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppNOptL
      Coin Integer
pstakeTot = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
c (Coin
c forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ do
        KeyHash 'StakePool
hk <- forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
o) VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (KeyHash 'StakePool
hk forall a. Eq a => a -> a -> Bool
== PoolParams -> KeyHash 'StakePool
ppId PoolParams
pool)
        forall a. Compactible a => CompactForm a -> a
fromCompact forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (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 = forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Coin -> KeyHash 'Staking -> Coin
accOwnerStake forall a. Monoid a => a
mempty (PoolParams -> Set (KeyHash 'Staking)
ppOwners PoolParams
pool)
      sigma :: Rational
sigma = if Integer
totalStake forall a. Eq a => a -> a -> Bool
== Integer
0 then Rational
0 else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pstakeTot forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
totalStake