{-# 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 qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.EpochBoundary (Stake (..), maxPool')
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
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 c ->
  StakeShare ->
  StakeShare ->
  Coin
leaderRew :: forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
leaderRew Coin
f PoolParams c
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 = forall c. PoolParams c -> Coin
ppCost PoolParams c
pool
    m :: UnitInterval
m = forall c. PoolParams c -> UnitInterval
ppMargin PoolParams c
pool
    m' :: Rational
m' = forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
m

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

sumRewards ::
  forall c.
  ProtVer ->
  Map (Credential 'Staking c) (Set (Reward c)) ->
  Coin
sumRewards :: forall c.
ProtVer -> Map (Credential 'Staking c) (Set (Reward c)) -> Coin
sumRewards ProtVer
protocolVersion Map (Credential 'Staking c) (Set (Reward c))
rs = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards ProtVer
protocolVersion Map (Credential 'Staking c) (Set (Reward c))
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 ::
  forall c.
  ProtVer ->
  Map (Credential 'Staking c) (Set (Reward c)) ->
  ( Map (Credential 'Staking c) (Set (Reward c)) -- delivered
  , Map (Credential 'Staking c) (Set (Reward c)) -- ignored in Shelley Era
  )
filterRewards :: forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> (Map (Credential 'Staking c) (Set (Reward c)),
    Map (Credential 'Staking c) (Set (Reward c)))
filterRewards ProtVer
pv Map (Credential 'Staking c) (Set (Reward c))
rewards =
  if ProtVer -> Bool
HardForks.aggregatedRewards ProtVer
pv
    then (Map (Credential 'Staking c) (Set (Reward c))
rewards, forall k a. Map k a
Map.empty)
    else
      let mp :: Map (Credential 'Staking c) (Reward c, Set (Reward c))
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 c) (Set (Reward c))
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 c) (Reward c, Set (Reward c))
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 c) (Reward c, Set (Reward c))
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 ::
  forall c.
  ProtVer ->
  Map (Credential 'Staking c) (Set (Reward c)) ->
  Map (Credential 'Staking c) Coin
aggregateRewards :: forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards ProtVer
pv Map (Credential 'Staking c) (Set (Reward c))
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' forall c. Reward c -> Coin
rewardAmount) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> (Map (Credential 'Staking c) (Set (Reward c)),
    Map (Credential 'Staking c) (Set (Reward c)))
filterRewards ProtVer
pv Map (Credential 'Staking c) (Set (Reward c))
rewards

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

sumCompactRewards ::
  ProtVer ->
  Map (Credential 'Staking c) (Set (Reward c)) ->
  CompactForm Coin
sumCompactRewards :: forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c)) -> CompactForm Coin
sumCompactRewards ProtVer
protocolVersion Map (Credential 'Staking c) (Set (Reward c))
rs = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) (CompactForm Coin)
aggregateCompactRewards ProtVer
protocolVersion Map (Credential 'Staking c) (Set (Reward c))
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 c) (Set (Reward c)) ->
  Map (Credential 'Staking c) (CompactForm Coin)
aggregateCompactRewards :: forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) (CompactForm Coin)
aggregateCompactRewards ProtVer
pv Map (Credential 'Staking c) (Set (Reward c))
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
. forall c. Reward c -> Coin
rewardAmount)) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> (Map (Credential 'Staking c) (Set (Reward c)),
    Map (Credential 'Staking c) (Set (Reward c)))
filterRewards ProtVer
pv Map (Credential 'Staking c) (Set (Reward c))
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 c = LeaderOnlyReward
  { forall c. LeaderOnlyReward c -> KeyHash 'StakePool c
lRewardPool :: !(KeyHash 'StakePool c)
  , forall c. LeaderOnlyReward c -> Coin
lRewardAmount :: !Coin
  }
  deriving (LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c/= :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
== :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c== :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
Eq, LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
LeaderOnlyReward c -> LeaderOnlyReward c -> Ordering
forall c. Eq (LeaderOnlyReward c)
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
forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Ordering
forall c.
LeaderOnlyReward c -> LeaderOnlyReward c -> LeaderOnlyReward c
min :: LeaderOnlyReward c -> LeaderOnlyReward c -> LeaderOnlyReward c
$cmin :: forall c.
LeaderOnlyReward c -> LeaderOnlyReward c -> LeaderOnlyReward c
max :: LeaderOnlyReward c -> LeaderOnlyReward c -> LeaderOnlyReward c
$cmax :: forall c.
LeaderOnlyReward c -> LeaderOnlyReward c -> LeaderOnlyReward c
>= :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c>= :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
> :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c> :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
<= :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c<= :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
< :: LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
$c< :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Bool
compare :: LeaderOnlyReward c -> LeaderOnlyReward c -> Ordering
$ccompare :: forall c. LeaderOnlyReward c -> LeaderOnlyReward c -> Ordering
Ord, Int -> LeaderOnlyReward c -> ShowS
forall c. Int -> LeaderOnlyReward c -> ShowS
forall c. [LeaderOnlyReward c] -> ShowS
forall c. LeaderOnlyReward c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LeaderOnlyReward c] -> ShowS
$cshowList :: forall c. [LeaderOnlyReward c] -> ShowS
show :: LeaderOnlyReward c -> String
$cshow :: forall c. LeaderOnlyReward c -> String
showsPrec :: Int -> LeaderOnlyReward c -> ShowS
$cshowsPrec :: forall c. Int -> LeaderOnlyReward c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (LeaderOnlyReward c) x -> LeaderOnlyReward c
forall c x. LeaderOnlyReward c -> Rep (LeaderOnlyReward c) x
$cto :: forall c x. Rep (LeaderOnlyReward c) x -> LeaderOnlyReward c
$cfrom :: forall c x. LeaderOnlyReward c -> Rep (LeaderOnlyReward c) x
Generic)

instance NoThunks (LeaderOnlyReward c)

instance NFData (LeaderOnlyReward c)

instance CC.Crypto c => EncCBOR (LeaderOnlyReward c) where
  encCBOR :: LeaderOnlyReward c -> Encoding
encCBOR (LeaderOnlyReward KeyHash 'StakePool c
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 forall c. KeyHash 'StakePool c -> Coin -> LeaderOnlyReward c
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 c
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 CC.Crypto c => DecCBOR (LeaderOnlyReward c) where
  decCBOR :: forall s. Decoder s (LeaderOnlyReward c)
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 forall c. KeyHash 'StakePool c -> Coin -> LeaderOnlyReward c
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 c -> Reward c
leaderRewardToGeneral :: forall c. LeaderOnlyReward c -> Reward c
leaderRewardToGeneral (LeaderOnlyReward KeyHash 'StakePool c
poolId Coin
r) = forall c. RewardType -> KeyHash 'StakePool c -> Coin -> Reward c
Reward RewardType
LeaderReward KeyHash 'StakePool c
poolId Coin
r

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

instance NoThunks (PoolRewardInfo c)

instance NFData (PoolRewardInfo c)

instance CC.Crypto c => EncCBOR (PoolRewardInfo c) where
  encCBOR :: PoolRewardInfo c -> Encoding
encCBOR
    (PoolRewardInfo StakeShare
a Coin
b PoolParams c
c Natural
d LeaderOnlyReward c
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 forall c.
StakeShare
-> Coin
-> PoolParams c
-> Natural
-> LeaderOnlyReward c
-> PoolRewardInfo c
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
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 c
e

instance CC.Crypto c => DecCBOR (PoolRewardInfo c) where
  decCBOR :: forall s. Decoder s (PoolRewardInfo c)
decCBOR =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode
      ( forall t. t -> Decode ('Closed 'Dense) t
RecD forall c.
StakeShare
-> Coin
-> PoolParams c
-> Natural
-> LeaderOnlyReward c
-> PoolRewardInfo c
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 c ->
  Credential 'Staking c ->
  Bool
notPoolOwner :: forall c. PoolParams c -> Credential 'Staking c -> Bool
notPoolOwner PoolParams c
pps = \case
  KeyHashObj KeyHash 'Staking c
hk -> KeyHash 'Staking c
hk forall a. Ord a => a -> Set a -> Bool
`Set.notMember` forall c. PoolParams c -> Set (KeyHash 'Staking c)
ppOwners PoolParams c
pps
  ScriptHashObj ScriptHash c
_ -> 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 c) ->
  -- | Stake pool specific intermediate values needed
  -- to compute member rewards.
  PoolRewardInfo c ->
  -- | The stake credential whose reward is being calculated.
  Credential 'Staking c ->
  -- | 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 :: forall c.
ProtVer
-> Coin
-> Set (Credential 'Staking c)
-> PoolRewardInfo c
-> Credential 'Staking c
-> Coin
-> Maybe Coin
rewardOnePoolMember
  ProtVer
pp
  (Coin Integer
totalStake)
  Set (Credential 'Staking c)
addrsRew
  PoolRewardInfo c
rewardInfo
  Credential 'Staking c
hk
  (Coin Integer
c) =
    if Bool
prefilter Bool -> Bool -> Bool
&& forall c. PoolParams c -> Credential 'Staking c -> Bool
notPoolOwner (forall c. PoolRewardInfo c -> PoolParams c
poolPs PoolRewardInfo c
rewardInfo) Credential 'Staking c
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 c
hk forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Credential 'Staking c)
addrsRew
      pool :: PoolParams c
pool = forall c. PoolRewardInfo c -> PoolParams c
poolPs PoolRewardInfo c
rewardInfo
      sigma :: StakeShare
sigma = forall c. PoolRewardInfo c -> StakeShare
poolRelativeStake PoolRewardInfo c
rewardInfo
      poolR :: Coin
poolR = forall c. PoolRewardInfo c -> Coin
poolPot PoolRewardInfo c
rewardInfo
      r :: Coin
r = forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
memberRew Coin
poolR PoolParams c
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 (EraCrypto era) ->
  Natural ->
  Stake (EraCrypto era) ->
  VMap.VMap VMap.VB VMap.VB (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era)) ->
  Map (KeyHash 'StakePool (EraCrypto era)) Coin ->
  Coin ->
  Coin ->
  PoolParams (EraCrypto era) ->
  Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo :: forall era.
EraPParams era =>
PParams era
-> Coin
-> BlocksMade (EraCrypto era)
-> Natural
-> Stake (EraCrypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) Coin
-> Coin
-> Coin
-> PoolParams (EraCrypto era)
-> Either StakeShare (PoolRewardInfo (EraCrypto era))
mkPoolRewardInfo
  PParams era
pp
  Coin
r
  BlocksMade (EraCrypto era)
blocks
  Natural
blocksTotal
  Stake (EraCrypto era)
stake
  VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
  Map (KeyHash 'StakePool (EraCrypto era)) Coin
stakePerPool
  (Coin Integer
totalStake)
  (Coin Integer
activeStake)
  PoolParams (EraCrypto era)
pool = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
pool) (forall c. BlocksMade c -> Map (KeyHash 'StakePool c) Natural
unBlocksMade BlocksMade (EraCrypto era)
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 = forall c. PoolParams c -> Coin
ppPledge PoolParams (EraCrypto era)
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
-> Natural -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
pp_a0 Natural
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 =
            forall c. Coin -> PoolParams c -> StakeShare -> StakeShare -> Coin
leaderRew
              Coin
poolR
              PoolParams (EraCrypto era)
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 (EraCrypto era)
rewardInfo =
            PoolRewardInfo
              { poolRelativeStake :: StakeShare
poolRelativeStake = Rational -> StakeShare
StakeShare Rational
sigma
              , poolPot :: Coin
poolPot = Coin
poolR
              , poolPs :: PoolParams (EraCrypto era)
poolPs = PoolParams (EraCrypto era)
pool
              , poolBlocks :: Natural
poolBlocks = Natural
blocksN
              , poolLeaderReward :: LeaderOnlyReward (EraCrypto era)
poolLeaderReward = forall c. KeyHash 'StakePool c -> Coin -> LeaderOnlyReward c
LeaderOnlyReward (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
pool) Coin
lreward
              }
       in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! PoolRewardInfo (EraCrypto era)
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 :: Natural
pp_nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL
      Coin Integer
pstakeTot = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty (forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
pool) Map (KeyHash 'StakePool (EraCrypto era)) Coin
stakePerPool
      accOwnerStake :: Coin -> KeyHash 'Staking (EraCrypto era) -> Coin
accOwnerStake Coin
c KeyHash 'Staking (EraCrypto era)
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 (EraCrypto era)
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) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
o) VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (KeyHash 'StakePool (EraCrypto era)
hk forall a. Eq a => a -> a -> Bool
== forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams (EraCrypto era)
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) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
o) (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake Stake (EraCrypto era)
stake)
      Coin Integer
ostake = forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Coin -> KeyHash 'Staking (EraCrypto era) -> Coin
accOwnerStake forall a. Monoid a => a
mempty (forall c. PoolParams c -> Set (KeyHash 'Staking c)
ppOwners PoolParams (EraCrypto era)
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