{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- FIXME: use better names for record names
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Cardano.Ledger.Shelley.API.Wallet (
  -- * UTxOs
  getUTxO,
  getUTxOSubset,
  getFilteredUTxO,

  -- * Stake Pools
  getPools,
  getTotalStake,
  poolsByTotalStakeFraction,
  RewardInfoPool (..),
  RewardParams (..),
  getRewardInfoPools,
  getRewardProvenance,
  getNonMyopicMemberRewards,

  -- * Transaction helpers
  addKeyWitnesses,

  -- * Ada pots
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
  getStakePools,
) where

import Cardano.Ledger.Address (Addr (..), compactAddr)
import Cardano.Ledger.BaseTypes (
  Globals (..),
  NonNegativeInterval,
  UnitInterval,
  epochInfoPure,
  (%?),
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decodeDouble,
  encodeDouble,
 )
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Keys (WitVKey (..))
import Cardano.Ledger.Shelley.AdaPots (
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  RewardUpdate,
  UTxOState (..),
  circulation,
  createRUpd,
  curPParamsEpochStateL,
  esLStateL,
  lsCertStateL,
  nesEsL,
 )
import Cardano.Ledger.Shelley.PoolRank (
  NonMyopic (..),
  PerformanceEstimate (..),
  getTopRankedPoolsVMap,
  nonMyopicMemberRew,
  percentile',
 )
import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance)
import Cardano.Ledger.Shelley.Rewards (StakeShare (..))
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Slot (epochInfoSize)
import qualified Cardano.Ledger.State as EB
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Slotting.Slot (EpochSize)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (runReader)
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (Default (def))
import Data.Foldable (foldMap')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.VMap as VMap
import Data.Word (Word16)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

--------------------------------------------------------------------------------
-- UTxOs
--------------------------------------------------------------------------------

-- | Get the full UTxO.
getUTxO ::
  NewEpochState era ->
  UTxO era
getUTxO :: forall era. NewEpochState era -> UTxO era
getUTxO = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
utxosUtxo (UTxOState era -> UTxO era)
-> (NewEpochState era -> UTxOState era)
-> NewEpochState era
-> UTxO era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState (LedgerState era -> UTxOState era)
-> (NewEpochState era -> LedgerState era)
-> NewEpochState era
-> UTxOState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState (EpochState era -> LedgerState era)
-> (NewEpochState era -> EpochState era)
-> NewEpochState era
-> LedgerState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs

-- | Get the UTxO filtered by address.
getFilteredUTxO ::
  EraTxOut era =>
  NewEpochState era ->
  Set Addr ->
  UTxO era
getFilteredUTxO :: forall era.
EraTxOut era =>
NewEpochState era -> Set Addr -> UTxO era
getFilteredUTxO NewEpochState era
ss Set Addr
addrSet =
  Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ (TxOut era -> Bool) -> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter TxOut era -> Bool
checkAddr Map TxIn (TxOut era)
fullUTxO
  where
    UTxO Map TxIn (TxOut era)
fullUTxO = NewEpochState era -> UTxO era
forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
ss
    compactAddrSet :: Set CompactAddr
compactAddrSet = (Addr -> CompactAddr) -> Set Addr -> Set CompactAddr
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Addr -> CompactAddr
compactAddr Set Addr
addrSet
    checkAddr :: TxOut era -> Bool
checkAddr TxOut era
out =
      case TxOut era
out TxOut era
-> Getting
     (Either Addr CompactAddr) (TxOut era) (Either Addr CompactAddr)
-> Either Addr CompactAddr
forall s a. s -> Getting a s a -> a
^. Getting
  (Either Addr CompactAddr) (TxOut era) (Either Addr CompactAddr)
forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL of
        Left Addr
addr -> Addr
addr Addr -> Set Addr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Addr
addrSet
        Right CompactAddr
cAddr -> CompactAddr
cAddr CompactAddr -> Set CompactAddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CompactAddr
compactAddrSet
{-# INLINEABLE getFilteredUTxO #-}

getUTxOSubset ::
  NewEpochState era ->
  Set TxIn ->
  UTxO era
getUTxOSubset :: forall era. NewEpochState era -> Set TxIn -> UTxO era
getUTxOSubset NewEpochState era
nes = UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter (NewEpochState era -> UTxO era
forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
nes)

--------------------------------------------------------------------------------
-- Stake pools and pool rewards
--------------------------------------------------------------------------------

-- | Get the /current/ registered stake pools.
getPools ::
  EraCertState era =>
  NewEpochState era ->
  Set (KeyHash StakePool)
getPools :: forall era.
EraCertState era =>
NewEpochState era -> Set (KeyHash StakePool)
getPools = Map (KeyHash StakePool) StakePoolState -> Set (KeyHash StakePool)
forall k a. Map k a -> Set k
Map.keysSet (Map (KeyHash StakePool) StakePoolState -> Set (KeyHash StakePool))
-> (NewEpochState era -> Map (KeyHash StakePool) StakePoolState)
-> NewEpochState era
-> Set (KeyHash StakePool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> Map (KeyHash StakePool) StakePoolState
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
NewEpochState era -> Map (KeyHash StakePool) StakePoolState
f
  where
    f :: NewEpochState era -> Map (KeyHash StakePool) StakePoolState
f NewEpochState era
nes = NewEpochState era
nes NewEpochState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> NewEpochState era
-> Const
     (Map (KeyHash StakePool) StakePoolState) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
 -> NewEpochState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era
  -> Const
       (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
 -> EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era
    -> Const
         (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
 -> LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> CertState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL

-- | Get the /current/ registered stake pool state for a given set of
-- stake pools. The result map will contain entries for all the given stake
-- pools that are currently registered.
getStakePools ::
  EraCertState era =>
  NewEpochState era ->
  Set (KeyHash StakePool) ->
  Map (KeyHash StakePool) StakePoolState
getStakePools :: forall era.
EraCertState era =>
NewEpochState era
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
getStakePools = Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (Map (KeyHash StakePool) StakePoolState
 -> Set (KeyHash StakePool)
 -> Map (KeyHash StakePool) StakePoolState)
-> (NewEpochState era -> Map (KeyHash StakePool) StakePoolState)
-> NewEpochState era
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> Map (KeyHash StakePool) StakePoolState
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
NewEpochState era -> Map (KeyHash StakePool) StakePoolState
f
  where
    f :: NewEpochState era -> Map (KeyHash StakePool) StakePoolState
f NewEpochState era
nes = NewEpochState era
nes NewEpochState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> NewEpochState era
-> Const
     (Map (KeyHash StakePool) StakePoolState) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
 -> NewEpochState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era
  -> Const
       (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
 -> EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era
    -> Const
         (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
 -> LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> CertState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL

-- | Get pool sizes, but in terms of total stake
--
-- The stake distribution uses active stake (so that the leader schedule is not
-- affected by undelegated stake), but the wallet wants to display pool
-- saturation for rewards purposes. For that, it needs the fraction of total
-- stake.
--
-- The fields `individualTotalPoolStake` and `pdTotalActiveStake` continue to
-- remain based on active stake and not total stake.
--
-- This is not based on any snapshot, but uses the current ledger state.
poolsByTotalStakeFraction ::
  (EraGov era, EraStake era, EraCertState era) =>
  Globals ->
  NewEpochState era ->
  PoolDistr
poolsByTotalStakeFraction :: forall era.
(EraGov era, EraStake era, EraCertState era) =>
Globals -> NewEpochState era -> PoolDistr
poolsByTotalStakeFraction Globals
globals NewEpochState era
ss =
  Map (KeyHash StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr Map (KeyHash StakePool) IndividualPoolStake
poolsByTotalStake CompactForm Coin
totalActiveStake
  where
    snap :: SnapShot
snap = NewEpochState era -> SnapShot
forall era.
(EraGov era, EraStake era, EraCertState era) =>
NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss
    Coin Integer
totalStake = Globals -> NewEpochState era -> Coin
forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
    stakeRatio :: Rational
stakeRatio = Coin -> Integer
unCoin (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
totalActiveStake) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Integer
totalStake
    PoolDistr Map (KeyHash StakePool) IndividualPoolStake
poolsByActiveStake CompactForm Coin
totalActiveStake = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
snap
    poolsByTotalStake :: Map (KeyHash StakePool) IndividualPoolStake
poolsByTotalStake = (IndividualPoolStake -> IndividualPoolStake)
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash StakePool) IndividualPoolStake
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map IndividualPoolStake -> IndividualPoolStake
toTotalStakeFrac Map (KeyHash StakePool) IndividualPoolStake
poolsByActiveStake
    toTotalStakeFrac ::
      IndividualPoolStake ->
      IndividualPoolStake
    toTotalStakeFrac :: IndividualPoolStake -> IndividualPoolStake
toTotalStakeFrac (IndividualPoolStake Rational
s CompactForm Coin
c VRFVerKeyHash StakePoolVRF
vrf) =
      Rational
-> CompactForm Coin
-> VRFVerKeyHash StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake (Rational
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
stakeRatio) CompactForm Coin
c VRFVerKeyHash StakePoolVRF
vrf

-- | Calculate the current total stake.
getTotalStake :: Globals -> NewEpochState era -> Coin
getTotalStake :: forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss =
  let supply :: Coin
supply = Integer -> Coin
Coin (Integer -> Coin) -> (Word64 -> Integer) -> Word64 -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Coin) -> Word64 -> Coin
forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
      es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
   in EpochState era -> Coin -> Coin
forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
supply

-- | Calculate the Non-Myopic Pool Member Rewards for a set of credentials.
-- For each given credential, this function returns a map from each stake
-- pool (identified by the key hash of the pool operator) to the
-- non-myopic pool member reward for that stake pool.
--
-- This is not based on any snapshot, but uses the current ledger state.
getNonMyopicMemberRewards ::
  (EraGov era, EraStake era, EraCertState era) =>
  Globals ->
  NewEpochState era ->
  Set (Either Coin (Credential Staking)) ->
  Map
    (Either Coin (Credential Staking))
    (Map (KeyHash StakePool) Coin)
getNonMyopicMemberRewards :: forall era.
(EraGov era, EraStake era, EraCertState era) =>
Globals
-> NewEpochState era
-> Set (Either Coin (Credential Staking))
-> Map
     (Either Coin (Credential Staking)) (Map (KeyHash StakePool) Coin)
getNonMyopicMemberRewards Globals
globals NewEpochState era
ss =
  (Either Coin (Credential Staking) -> Map (KeyHash StakePool) Coin)
-> Set (Either Coin (Credential Staking))
-> Map
     (Either Coin (Credential Staking)) (Map (KeyHash StakePool) Coin)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\Either Coin (Credential Staking)
cred -> ((PerformanceEstimate, StakePoolParams, StakeShare) -> Coin)
-> Map
     (KeyHash StakePool)
     (PerformanceEstimate, StakePoolParams, StakeShare)
-> Map (KeyHash StakePool) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (StakeShare
-> (PerformanceEstimate, StakePoolParams, StakeShare) -> Coin
mkNMMRewards (StakeShare
 -> (PerformanceEstimate, StakePoolParams, StakeShare) -> Coin)
-> StakeShare
-> (PerformanceEstimate, StakePoolParams, StakeShare)
-> Coin
forall a b. (a -> b) -> a -> b
$ Either Coin (Credential Staking) -> StakeShare
memShare Either Coin (Credential Staking)
cred) Map
  (KeyHash StakePool)
  (PerformanceEstimate, StakePoolParams, StakeShare)
poolData)
  where
    maxSupply :: Coin
maxSupply = Integer -> Coin
Coin (Integer -> Coin) -> (Word64 -> Integer) -> Word64 -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Coin) -> Word64 -> Coin
forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
    totalStakeCoin :: Coin
totalStakeCoin@(Coin Integer
totalStake) = EpochState era -> Coin -> Coin
forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    toShare :: Coin -> StakeShare
toShare (Coin Integer
x) = Rational -> StakeShare
StakeShare (Rational -> StakeShare) -> Rational -> StakeShare
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Integer
totalStake
    memShare :: Either Coin (Credential Staking) -> StakeShare
memShare (Right Credential Staking
cred) =
      Coin -> StakeShare
toShare (Coin -> StakeShare) -> Coin -> StakeShare
forall a b. (a -> b) -> a -> b
$ Coin
-> (CompactForm Coin -> Coin) -> Maybe (CompactForm Coin) -> Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
forall a. Monoid a => a
mempty CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Maybe (CompactForm Coin) -> Coin)
-> Maybe (CompactForm Coin) -> Coin
forall a b. (a -> b) -> a -> 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 Credential Staking
cred (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
EB.unStake Stake
stake)
    memShare (Left Coin
coin) = Coin -> StakeShare
toShare Coin
coin
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    NonMyopic {likelihoodsNM :: NonMyopic -> Map (KeyHash StakePool) Likelihood
likelihoodsNM = Map (KeyHash StakePool) Likelihood
ls, rewardPotNM :: NonMyopic -> Coin
rewardPotNM = Coin
rPot} = EpochState era -> NonMyopic
forall era. EpochState era -> NonMyopic
esNonMyopic EpochState era
es
    EB.SnapShot Stake
stake VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams = NewEpochState era -> SnapShot
forall era.
(EraGov era, EraStake era, EraCertState era) =>
NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss
    poolData :: Map
  (KeyHash StakePool)
  (PerformanceEstimate, StakePoolParams, StakeShare)
poolData =
      [(KeyHash StakePool,
  (PerformanceEstimate, StakePoolParams, StakeShare))]
-> Map
     (KeyHash StakePool)
     (PerformanceEstimate, StakePoolParams, StakeShare)
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList
        [ ( KeyHash StakePool
k
          ,
            ( Likelihood -> PerformanceEstimate
percentile' (KeyHash StakePool -> Likelihood
histLookup KeyHash StakePool
k)
            , StakePoolParams
p
            , Coin -> StakeShare
toShare (Coin -> StakeShare) -> (Stake -> Coin) -> Stake -> StakeShare
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> Coin
EB.sumAllStake (Stake -> StakeShare) -> Stake -> StakeShare
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Stake
EB.poolStake KeyHash StakePool
k VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake
            )
          )
        | (KeyHash StakePool
k, StakePoolParams
p) <- VMap VB VB (KeyHash StakePool) StakePoolParams
-> [(KeyHash StakePool, StakePoolParams)]
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams
        ]
    histLookup :: KeyHash StakePool -> Likelihood
histLookup KeyHash StakePool
k = Likelihood
-> KeyHash StakePool
-> Map (KeyHash StakePool) Likelihood
-> Likelihood
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Likelihood
forall a. Monoid a => a
mempty KeyHash StakePool
k Map (KeyHash StakePool) Likelihood
ls
    topPools :: Set (KeyHash StakePool)
topPools =
      Coin
-> Coin
-> PParams era
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) PerformanceEstimate
-> Set (KeyHash StakePool)
forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) PerformanceEstimate
-> Set (KeyHash StakePool)
getTopRankedPoolsVMap
        Coin
rPot
        Coin
totalStakeCoin
        PParams era
pp
        VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams
        ((Likelihood -> PerformanceEstimate)
-> Map (KeyHash StakePool) Likelihood
-> Map (KeyHash StakePool) PerformanceEstimate
forall a b.
(a -> b) -> Map (KeyHash StakePool) a -> Map (KeyHash StakePool) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Likelihood -> PerformanceEstimate
percentile' Map (KeyHash StakePool) Likelihood
ls)
    mkNMMRewards :: StakeShare
-> (PerformanceEstimate, StakePoolParams, StakeShare) -> Coin
mkNMMRewards StakeShare
t (PerformanceEstimate
hitRateEst, StakePoolParams
poolp, StakeShare
sigma) =
      if StakePoolParams -> Bool
checkPledge StakePoolParams
poolp
        then PParams era
-> Coin
-> StakePoolParams
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash StakePool)
-> PerformanceEstimate
-> Coin
forall era.
EraPParams era =>
PParams era
-> Coin
-> StakePoolParams
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash StakePool)
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew PParams era
pp Coin
rPot StakePoolParams
poolp StakeShare
s StakeShare
sigma StakeShare
t Set (KeyHash StakePool)
topPools PerformanceEstimate
hitRateEst
        else Coin
forall a. Monoid a => a
mempty
      where
        s :: StakeShare
s = (Coin -> StakeShare
toShare (Coin -> StakeShare)
-> (StakePoolParams -> Coin) -> StakePoolParams -> StakeShare
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolParams -> Coin
sppPledge) StakePoolParams
poolp
        checkPledge :: StakePoolParams -> Bool
checkPledge StakePoolParams
pool =
          let ostake :: Coin
ostake = StakePoolParams -> Stake -> Coin
sumPoolOwnersStake StakePoolParams
pool Stake
stake
           in StakePoolParams -> Coin
sppPledge StakePoolParams
poolp Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
ostake

sumPoolOwnersStake :: StakePoolParams -> EB.Stake -> Coin
sumPoolOwnersStake :: StakePoolParams -> Stake -> Coin
sumPoolOwnersStake StakePoolParams
pool Stake
stake =
  let getStakeFor :: KeyHash Staking -> Coin
getStakeFor KeyHash Staking
o =
        Coin
-> (CompactForm Coin -> Coin) -> Maybe (CompactForm Coin) -> Coin
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Coin
forall a. Monoid a => a
mempty CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Maybe (CompactForm Coin) -> Coin)
-> Maybe (CompactForm Coin) -> Coin
forall a b. (a -> b) -> a -> 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)
EB.unStake Stake
stake)
   in (KeyHash Staking -> Coin) -> Set (KeyHash Staking) -> 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' KeyHash Staking -> Coin
getStakeFor (StakePoolParams -> Set (KeyHash Staking)
sppOwners StakePoolParams
pool)

-- | Create a current snapshot of the ledger state.
--
-- When ranking pools, and reporting their saturation level, in the wallet, we
-- do not want to use one of the regular snapshots, but rather the most recent
-- ledger state.
currentSnapshot :: (EraGov era, EraStake era, EraCertState era) => NewEpochState era -> EB.SnapShot
currentSnapshot :: forall era.
(EraGov era, EraStake era, EraCertState era) =>
NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss =
  InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake DState era
dstate PState era
pstate
  where
    _pp :: PParams era
_pp = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    ledgerState :: LedgerState era
ledgerState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    instantStake :: InstantStake era
instantStake = LedgerState era
ledgerState LedgerState era
-> Getting (InstantStake era) (LedgerState era) (InstantStake era)
-> InstantStake era
forall s a. s -> Getting a s a -> a
^. Getting (InstantStake era) (LedgerState era) (InstantStake era)
forall era. SimpleGetter (LedgerState era) (InstantStake era)
forall (t :: * -> *) era.
CanGetInstantStake t =>
SimpleGetter (t era) (InstantStake era)
instantStakeG
    dstate :: DState era
dstate = LedgerState era
ledgerState LedgerState era
-> Getting (DState era) (LedgerState era) (DState era)
-> DState era
forall s a. s -> Getting a s a -> a
^. (CertState era -> Const (DState era) (CertState era))
-> LedgerState era -> Const (DState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (DState era) (CertState era))
 -> LedgerState era -> Const (DState era) (LedgerState era))
-> ((DState era -> Const (DState era) (DState era))
    -> CertState era -> Const (DState era) (CertState era))
-> Getting (DState era) (LedgerState era) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (DState era) (DState era))
-> CertState era -> Const (DState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    pstate :: PState era
pstate = LedgerState era
ledgerState LedgerState era
-> Getting (PState era) (LedgerState era) (PState era)
-> PState era
forall s a. s -> Getting a s a -> a
^. (CertState era -> Const (PState era) (CertState era))
-> LedgerState era -> Const (PState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (PState era) (CertState era))
 -> LedgerState era -> Const (PState era) (LedgerState era))
-> ((PState era -> Const (PState era) (PState era))
    -> CertState era -> Const (PState era) (CertState era))
-> Getting (PState era) (LedgerState era) (PState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const (PState era) (PState era))
-> CertState era -> Const (PState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL

-- | Information about a stake pool
data RewardInfoPool = RewardInfoPool
  { RewardInfoPool -> Coin
stake :: Coin
  -- ^ Absolute stake delegated to this pool
  , RewardInfoPool -> Coin
ownerPledge :: Coin
  -- ^ Pledge of pool owner(s)
  , RewardInfoPool -> Coin
ownerStake :: Coin
  -- ^ Absolute stake delegated by pool owner(s)
  , RewardInfoPool -> Coin
cost :: Coin
  -- ^ Pool cost
  , RewardInfoPool -> UnitInterval
margin :: UnitInterval
  -- ^ Pool margin
  , RewardInfoPool -> Double
performanceEstimate :: Double
  -- ^ Number of blocks produced divided by expected number of blocks.
  -- Can be larger than @1.0@ for pool that gets lucky.
  -- (If some pools get unlucky, some pools must get lucky.)
  }
  deriving (RewardInfoPool -> RewardInfoPool -> Bool
(RewardInfoPool -> RewardInfoPool -> Bool)
-> (RewardInfoPool -> RewardInfoPool -> Bool) -> Eq RewardInfoPool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RewardInfoPool -> RewardInfoPool -> Bool
== :: RewardInfoPool -> RewardInfoPool -> Bool
$c/= :: RewardInfoPool -> RewardInfoPool -> Bool
/= :: RewardInfoPool -> RewardInfoPool -> Bool
Eq, Int -> RewardInfoPool -> ShowS
[RewardInfoPool] -> ShowS
RewardInfoPool -> String
(Int -> RewardInfoPool -> ShowS)
-> (RewardInfoPool -> String)
-> ([RewardInfoPool] -> ShowS)
-> Show RewardInfoPool
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RewardInfoPool -> ShowS
showsPrec :: Int -> RewardInfoPool -> ShowS
$cshow :: RewardInfoPool -> String
show :: RewardInfoPool -> String
$cshowList :: [RewardInfoPool] -> ShowS
showList :: [RewardInfoPool] -> ShowS
Show, (forall x. RewardInfoPool -> Rep RewardInfoPool x)
-> (forall x. Rep RewardInfoPool x -> RewardInfoPool)
-> Generic RewardInfoPool
forall x. Rep RewardInfoPool x -> RewardInfoPool
forall x. RewardInfoPool -> Rep RewardInfoPool x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RewardInfoPool -> Rep RewardInfoPool x
from :: forall x. RewardInfoPool -> Rep RewardInfoPool x
$cto :: forall x. Rep RewardInfoPool x -> RewardInfoPool
to :: forall x. Rep RewardInfoPool x -> RewardInfoPool
Generic)

instance NoThunks RewardInfoPool

instance NFData RewardInfoPool

deriving instance FromJSON RewardInfoPool

deriving instance ToJSON RewardInfoPool

-- | Global information that influences stake pool rewards
data RewardParams = RewardParams
  { RewardParams -> Word16
nOpt :: Word16
  -- ^ Desired number of stake pools
  , RewardParams -> NonNegativeInterval
a0 :: NonNegativeInterval
  -- ^ Influence of the pool owner's pledge on rewards
  , RewardParams -> Coin
rPot :: Coin
  -- ^ Total rewards available for the given epoch
  , RewardParams -> Coin
totalStake :: Coin
  -- ^ Maximum lovelace supply minus treasury
  }
  deriving (RewardParams -> RewardParams -> Bool
(RewardParams -> RewardParams -> Bool)
-> (RewardParams -> RewardParams -> Bool) -> Eq RewardParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RewardParams -> RewardParams -> Bool
== :: RewardParams -> RewardParams -> Bool
$c/= :: RewardParams -> RewardParams -> Bool
/= :: RewardParams -> RewardParams -> Bool
Eq, Int -> RewardParams -> ShowS
[RewardParams] -> ShowS
RewardParams -> String
(Int -> RewardParams -> ShowS)
-> (RewardParams -> String)
-> ([RewardParams] -> ShowS)
-> Show RewardParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RewardParams -> ShowS
showsPrec :: Int -> RewardParams -> ShowS
$cshow :: RewardParams -> String
show :: RewardParams -> String
$cshowList :: [RewardParams] -> ShowS
showList :: [RewardParams] -> ShowS
Show, (forall x. RewardParams -> Rep RewardParams x)
-> (forall x. Rep RewardParams x -> RewardParams)
-> Generic RewardParams
forall x. Rep RewardParams x -> RewardParams
forall x. RewardParams -> Rep RewardParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RewardParams -> Rep RewardParams x
from :: forall x. RewardParams -> Rep RewardParams x
$cto :: forall x. Rep RewardParams x -> RewardParams
to :: forall x. Rep RewardParams x -> RewardParams
Generic)

instance NoThunks RewardParams

instance NFData RewardParams

deriving instance FromJSON RewardParams

deriving instance ToJSON RewardParams

-- | Retrieve the information necessary to calculate stake pool member rewards
-- from the /current/ stake distribution.
--
-- This information includes the current stake distribution aggregated
-- by stake pools and pool owners,
-- the `current` pool costs and margins,
-- and performance estimates.
-- Also included are global information such as
-- the total stake or protocol parameters.
getRewardInfoPools ::
  (EraGov era, EraStake era, EraCertState era) =>
  Globals ->
  NewEpochState era ->
  (RewardParams, Map (KeyHash StakePool) RewardInfoPool)
getRewardInfoPools :: forall era.
(EraGov era, EraStake era, EraCertState era) =>
Globals
-> NewEpochState era
-> (RewardParams, Map (KeyHash StakePool) RewardInfoPool)
getRewardInfoPools Globals
globals NewEpochState era
ss =
  (RewardParams
mkRewardParams, VMap VB VB (KeyHash StakePool) RewardInfoPool
-> Map (KeyHash StakePool) RewardInfoPool
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap ((KeyHash StakePool -> StakePoolParams -> RewardInfoPool)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> VMap VB VB (KeyHash StakePool) RewardInfoPool
forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(k -> a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapWithKey KeyHash StakePool -> StakePoolParams -> RewardInfoPool
mkRewardInfoPool VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams))
  where
    es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    NonMyopic
      { likelihoodsNM :: NonMyopic -> Map (KeyHash StakePool) Likelihood
likelihoodsNM = Map (KeyHash StakePool) Likelihood
ls
      , rewardPotNM :: NonMyopic -> Coin
rewardPotNM = Coin
rPot
      } = EpochState era -> NonMyopic
forall era. EpochState era -> NonMyopic
esNonMyopic EpochState era
es
    histLookup :: KeyHash StakePool -> Likelihood
histLookup KeyHash StakePool
key = Likelihood
-> KeyHash StakePool
-> Map (KeyHash StakePool) Likelihood
-> Likelihood
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Likelihood
forall a. Monoid a => a
mempty KeyHash StakePool
key Map (KeyHash StakePool) Likelihood
ls

    EB.SnapShot Stake
stakes VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams = NewEpochState era -> SnapShot
forall era.
(EraGov era, EraStake era, EraCertState era) =>
NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss

    mkRewardParams :: RewardParams
mkRewardParams =
      RewardParams
        { a0 :: NonNegativeInterval
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
        , nOpt :: Word16
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
        , totalStake :: Coin
totalStake = Globals -> NewEpochState era -> Coin
forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
        , rPot :: Coin
rPot = Coin
rPot
        }
    mkRewardInfoPool :: KeyHash StakePool -> StakePoolParams -> RewardInfoPool
mkRewardInfoPool KeyHash StakePool
key StakePoolParams
poolp =
      RewardInfoPool
        { stake :: Coin
stake = Coin
pstake
        , ownerStake :: Coin
ownerStake = Coin
ostake
        , ownerPledge :: Coin
ownerPledge = StakePoolParams -> Coin
sppPledge StakePoolParams
poolp
        , margin :: UnitInterval
margin = StakePoolParams -> UnitInterval
sppMargin StakePoolParams
poolp
        , cost :: Coin
cost = StakePoolParams -> Coin
sppCost StakePoolParams
poolp
        , performanceEstimate :: Double
performanceEstimate =
            PerformanceEstimate -> Double
unPerformanceEstimate (PerformanceEstimate -> Double) -> PerformanceEstimate -> Double
forall a b. (a -> b) -> a -> b
$ Likelihood -> PerformanceEstimate
percentile' (Likelihood -> PerformanceEstimate)
-> Likelihood -> PerformanceEstimate
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> Likelihood
histLookup KeyHash StakePool
key
        }
      where
        pstake :: Coin
pstake = Stake -> Coin
EB.sumAllStake (Stake -> Coin) -> Stake -> Coin
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Stake
EB.poolStake KeyHash StakePool
key VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stakes
        ostake :: Coin
ostake = StakePoolParams -> Stake -> Coin
sumPoolOwnersStake StakePoolParams
poolp Stake
stakes

-- | Calculate stake pool rewards from the snapshot labeled `go`.
-- Also includes information on how the rewards were calculated
-- ('RewardProvenance').
--
-- For a calculation of rewards based on the current stake distribution,
-- see 'getRewardInfoPools'.
--
-- TODO: Deprecate 'getRewardProvenance', because wallets are more
-- likely to use 'getRewardInfoPools' for up-to-date information
-- on stake pool rewards.
getRewardProvenance ::
  forall era.
  (EraGov era, EraCertState era) =>
  Globals ->
  NewEpochState era ->
  (RewardUpdate, RewardProvenance)
getRewardProvenance :: forall era.
(EraGov era, EraCertState era) =>
Globals -> NewEpochState era -> (RewardUpdate, RewardProvenance)
getRewardProvenance Globals
globals NewEpochState era
newEpochState =
  ( Reader Globals RewardUpdate -> Globals -> RewardUpdate
forall r a. Reader r a -> r -> a
runReader
      (EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> NonZero Word64
-> Reader Globals RewardUpdate
forall era.
(EraGov era, EraCertState era) =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> NonZero Word64
-> Reader Globals RewardUpdate
createRUpd EpochSize
slotsPerEpoch BlocksMade
blocksMade EpochState era
epochState Coin
maxSupply ActiveSlotCoeff
asc NonZero Word64
secparam)
      Globals
globals
  , RewardProvenance
forall a. Default a => a
def
  )
  where
    epochState :: EpochState era
epochState = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
newEpochState
    maxSupply :: Coin
maxSupply = Integer -> Coin
Coin (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Globals -> Word64
maxLovelaceSupply Globals
globals))
    blocksMade :: BlocksMade
blocksMade = NewEpochState era -> BlocksMade
forall era. NewEpochState era -> BlocksMade
nesBprev NewEpochState era
newEpochState
    epochNo :: EpochNo
epochNo = NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
newEpochState
    slotsPerEpoch :: EpochSize
    slotsPerEpoch :: EpochSize
slotsPerEpoch = HasCallStack => EpochInfo Identity -> EpochNo -> EpochSize
EpochInfo Identity -> EpochNo -> EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo
    asc :: ActiveSlotCoeff
asc = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    secparam :: NonZero Word64
secparam = Globals -> NonZero Word64
securityParameter Globals
globals

--------------------------------------------------------------------------------
-- Transaction helpers
--------------------------------------------------------------------------------

addKeyWitnesses :: EraTx era => Tx t era -> Set (WitVKey Witness) -> Tx t era
addKeyWitnesses :: forall era (t :: TxLevel).
EraTx era =>
Tx t era -> Set (WitVKey Witness) -> Tx t era
addKeyWitnesses Tx t era
tx Set (WitVKey Witness)
newWits = Tx t era
tx Tx t era -> (Tx t era -> Tx t era) -> Tx t era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx t era -> Identity (Tx t era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx t era -> Identity (Tx t era))
-> ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> Tx t era
-> Identity (Tx t era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> Tx t era -> Identity (Tx t era))
-> (Set (WitVKey Witness) -> Set (WitVKey Witness))
-> Tx t era
-> Tx t era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Set (WitVKey Witness)
-> Set (WitVKey Witness) -> Set (WitVKey Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (WitVKey Witness)
newWits

--------------------------------------------------------------------------------
-- CBOR instances
--------------------------------------------------------------------------------

instance EncCBOR RewardParams where
  encCBOR :: RewardParams -> Encoding
encCBOR (RewardParams Word16
p1 NonNegativeInterval
p2 Coin
p3 Coin
p4) =
    Encode (Closed Dense) RewardParams -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode (Closed Dense) RewardParams -> Encoding)
-> Encode (Closed Dense) RewardParams -> Encoding
forall a b. (a -> b) -> a -> b
$
      (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Encode
     (Closed Dense)
     (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
forall t. t -> Encode (Closed Dense) t
Rec Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        Encode
  (Closed Dense)
  (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Encode (Closed Dense) Word16
-> Encode
     (Closed Dense)
     (NonNegativeInterval -> Coin -> Coin -> RewardParams)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Word16 -> Encode (Closed Dense) Word16
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Word16
p1
        Encode
  (Closed Dense)
  (NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Encode (Closed Dense) NonNegativeInterval
-> Encode (Closed Dense) (Coin -> Coin -> RewardParams)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> NonNegativeInterval -> Encode (Closed Dense) NonNegativeInterval
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To NonNegativeInterval
p2
        Encode (Closed Dense) (Coin -> Coin -> RewardParams)
-> Encode (Closed Dense) Coin
-> Encode (Closed Dense) (Coin -> RewardParams)
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
p3
        Encode (Closed Dense) (Coin -> RewardParams)
-> Encode (Closed Dense) Coin -> Encode (Closed Dense) RewardParams
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
p4

instance DecCBOR RewardParams where
  decCBOR :: forall s. Decoder s RewardParams
decCBOR =
    Decode (Closed Dense) RewardParams -> Decoder s RewardParams
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode (Closed Dense) RewardParams -> Decoder s RewardParams)
-> Decode (Closed Dense) RewardParams -> Decoder s RewardParams
forall a b. (a -> b) -> a -> b
$
      (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Decode
     (Closed Dense)
     (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
forall t. t -> Decode (Closed Dense) t
RecD Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        Decode
  (Closed Dense)
  (Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Decode (Closed (ZonkAny 3)) Word16
-> Decode
     (Closed Dense)
     (NonNegativeInterval -> Coin -> Coin -> RewardParams)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 3)) Word16
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  (Closed Dense)
  (NonNegativeInterval -> Coin -> Coin -> RewardParams)
-> Decode (Closed (ZonkAny 2)) NonNegativeInterval
-> Decode (Closed Dense) (Coin -> Coin -> RewardParams)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 2)) NonNegativeInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode (Closed Dense) (Coin -> Coin -> RewardParams)
-> Decode (Closed (ZonkAny 1)) Coin
-> Decode (Closed Dense) (Coin -> RewardParams)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 1)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode (Closed Dense) (Coin -> RewardParams)
-> Decode (Closed (ZonkAny 0)) Coin
-> Decode (Closed Dense) RewardParams
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 0)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance EncCBOR RewardInfoPool where
  encCBOR :: RewardInfoPool -> Encoding
encCBOR (RewardInfoPool Coin
p1 Coin
p2 Coin
p3 Coin
p4 UnitInterval
p5 Double
d6) =
    Encode (Closed Dense) RewardInfoPool -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode (Closed Dense) RewardInfoPool -> Encoding)
-> Encode (Closed Dense) RewardInfoPool -> Encoding
forall a b. (a -> b) -> a -> b
$
      (Coin
 -> Coin
 -> Coin
 -> Coin
 -> UnitInterval
 -> Double
 -> RewardInfoPool)
-> Encode
     (Closed Dense)
     (Coin
      -> Coin
      -> Coin
      -> Coin
      -> UnitInterval
      -> Double
      -> RewardInfoPool)
forall t. t -> Encode (Closed Dense) t
Rec Coin
-> Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool
RewardInfoPool
        Encode
  (Closed Dense)
  (Coin
   -> Coin
   -> Coin
   -> Coin
   -> UnitInterval
   -> Double
   -> RewardInfoPool)
-> Encode (Closed Dense) Coin
-> Encode
     (Closed Dense)
     (Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
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
p1
        Encode
  (Closed Dense)
  (Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Encode (Closed Dense) Coin
-> Encode
     (Closed Dense)
     (Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
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
p2
        Encode
  (Closed Dense)
  (Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Encode (Closed Dense) Coin
-> Encode
     (Closed Dense) (Coin -> UnitInterval -> Double -> RewardInfoPool)
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
p3
        Encode
  (Closed Dense) (Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Encode (Closed Dense) Coin
-> Encode (Closed Dense) (UnitInterval -> Double -> RewardInfoPool)
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
p4
        Encode (Closed Dense) (UnitInterval -> Double -> RewardInfoPool)
-> Encode (Closed Dense) UnitInterval
-> Encode (Closed Dense) (Double -> RewardInfoPool)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> UnitInterval -> Encode (Closed Dense) UnitInterval
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To UnitInterval
p5
        Encode (Closed Dense) (Double -> RewardInfoPool)
-> Encode (Closed Dense) Double
-> Encode (Closed Dense) RewardInfoPool
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> (Double -> Encoding) -> Double -> Encode (Closed Dense) Double
forall t. (t -> Encoding) -> t -> Encode (Closed Dense) t
E Double -> Encoding
encodeDouble Double
d6

instance DecCBOR RewardInfoPool where
  decCBOR :: forall s. Decoder s RewardInfoPool
decCBOR =
    Decode (Closed Dense) RewardInfoPool -> Decoder s RewardInfoPool
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode (Closed Dense) RewardInfoPool -> Decoder s RewardInfoPool)
-> Decode (Closed Dense) RewardInfoPool -> Decoder s RewardInfoPool
forall a b. (a -> b) -> a -> b
$
      (Coin
 -> Coin
 -> Coin
 -> Coin
 -> UnitInterval
 -> Double
 -> RewardInfoPool)
-> Decode
     (Closed Dense)
     (Coin
      -> Coin
      -> Coin
      -> Coin
      -> UnitInterval
      -> Double
      -> RewardInfoPool)
forall t. t -> Decode (Closed Dense) t
RecD Coin
-> Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool
RewardInfoPool
        Decode
  (Closed Dense)
  (Coin
   -> Coin
   -> Coin
   -> Coin
   -> UnitInterval
   -> Double
   -> RewardInfoPool)
-> Decode (Closed (ZonkAny 8)) Coin
-> Decode
     (Closed Dense)
     (Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 8)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  (Closed Dense)
  (Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Decode (Closed (ZonkAny 7)) Coin
-> Decode
     (Closed Dense)
     (Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 7)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  (Closed Dense)
  (Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Decode (Closed (ZonkAny 6)) Coin
-> Decode
     (Closed Dense) (Coin -> UnitInterval -> Double -> RewardInfoPool)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 6)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  (Closed Dense) (Coin -> UnitInterval -> Double -> RewardInfoPool)
-> Decode (Closed (ZonkAny 5)) Coin
-> Decode (Closed Dense) (UnitInterval -> Double -> RewardInfoPool)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 5)) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode (Closed Dense) (UnitInterval -> Double -> RewardInfoPool)
-> Decode (Closed (ZonkAny 4)) UnitInterval
-> Decode (Closed Dense) (Double -> RewardInfoPool)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 4)) UnitInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode (Closed Dense) (Double -> RewardInfoPool)
-> Decode (Closed Dense) Double
-> Decode (Closed Dense) RewardInfoPool
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! (forall s. Decoder s Double) -> Decode (Closed Dense) Double
forall t. (forall s. Decoder s t) -> Decode (Closed Dense) t
D Decoder s Double
forall s. Decoder s Double
decodeDouble