{-# 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,
  getPoolParameters,
  getTotalStake,
  poolsByTotalStakeFraction,
  RewardInfoPool (..),
  RewardParams (..),
  getRewardInfoPools,
  getRewardProvenance,
  getNonMyopicMemberRewards,

  -- * Transaction helpers
  addKeyWitnesses,

  -- * Ada pots
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
)
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.Core
import Cardano.Ledger.Credential (Credential (..))
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Keys (WitVKey (..))
import Cardano.Ledger.PoolDistr (
  IndividualPoolStake (..),
  PoolDistr (..),
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.AdaPots (
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
 )
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (
  CertState (..),
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  RewardUpdate,
  UTxOState (..),
  circulation,
  createRUpd,
  curPParamsEpochStateL,
  incrementalStakeDistr,
 )
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.Rules.NewEpoch (calculatePoolDistr)
import Cardano.Ledger.Slot (epochInfoSize)
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (UTxO (..), txInsFilter)
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.Ratio ((%))
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 = forall era. UTxOState era -> UTxO era
utxosUtxo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$ 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 = forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
ss
    compactAddrSet :: Set CompactAddr
compactAddrSet = 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL of
        Left Addr
addr -> Addr
addr forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Addr
addrSet
        Right CompactAddr
cAddr -> CompactAddr
cAddr 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 = forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter (forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
nes)

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

-- | Get the /current/ registered stake pools.
getPools ::
  NewEpochState era ->
  Set (KeyHash 'StakePool)
getPools :: forall era. NewEpochState era -> Set (KeyHash 'StakePool)
getPools = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}.
NewEpochState era -> Map (KeyHash 'StakePool) PoolParams
f
  where
    f :: NewEpochState era -> Map (KeyHash 'StakePool) PoolParams
f = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs

-- | Get the /current/ registered stake pool parameters for a given set of
-- stake pools. The result map will contain entries for all the given stake
-- pools that are currently registered.
getPoolParameters ::
  NewEpochState era ->
  Set (KeyHash 'StakePool) ->
  Map (KeyHash 'StakePool) PoolParams
getPoolParameters :: forall era.
NewEpochState era
-> Set (KeyHash 'StakePool) -> Map (KeyHash 'StakePool) PoolParams
getPoolParameters = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}.
NewEpochState era -> Map (KeyHash 'StakePool) PoolParams
f
  where
    f :: NewEpochState era -> Map (KeyHash 'StakePool) PoolParams
f = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs

-- | 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 ::
  forall era.
  EraGov era =>
  Globals ->
  NewEpochState era ->
  PoolDistr
poolsByTotalStakeFraction :: forall era. EraGov 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 = forall era. EraGov era => NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss
    Coin Integer
totalStake = forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
    stakeRatio :: Rational
stakeRatio = Coin -> Integer
unCoin (forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
totalActiveStake) 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 = 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
      es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
   in 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 =>
  Globals ->
  NewEpochState era ->
  Set (Either Coin (Credential 'Staking)) ->
  Map
    (Either Coin (Credential 'Staking))
    (Map (KeyHash 'StakePool) Coin)
getNonMyopicMemberRewards :: forall era.
EraGov era =>
Globals
-> NewEpochState era
-> Set (Either Coin (Credential 'Staking))
-> Map
     (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
getNonMyopicMemberRewards Globals
globals NewEpochState era
ss =
  forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\Either Coin (Credential 'Staking)
cred -> forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (StakeShare -> (PerformanceEstimate, PoolParams, StakeShare) -> Coin
mkNMMRewards forall a b. (a -> b) -> a -> b
$ Either Coin (Credential 'Staking) -> StakeShare
memShare Either Coin (Credential 'Staking)
cred) Map
  (KeyHash 'StakePool) (PerformanceEstimate, PoolParams, StakeShare)
poolData)
  where
    maxSupply :: Coin
maxSupply = Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
    Coin Integer
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    toShare :: Coin -> StakeShare
toShare (Coin Integer
x) = Rational -> StakeShare
StakeShare (Integer
x forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake)
    memShare :: Either Coin (Credential 'Staking) -> StakeShare
memShare (Right Credential 'Staking
cred) =
      Coin -> StakeShare
toShare forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Compactible a => CompactForm a -> a
fromCompact forall a b. (a -> b) -> a -> b
$ 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 = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov 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} = 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) PoolParams
poolParams = forall era. EraGov era => NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss
    poolData :: Map
  (KeyHash 'StakePool) (PerformanceEstimate, PoolParams, StakeShare)
poolData =
      forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList
        [ ( KeyHash 'StakePool
k
          ,
            ( Likelihood -> PerformanceEstimate
percentile' (KeyHash 'StakePool -> Likelihood
histLookup KeyHash 'StakePool
k)
            , PoolParams
p
            , Coin -> StakeShare
toShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> Coin
EB.sumAllStake 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, PoolParams
p) <- 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) PoolParams
poolParams
        ]
    histLookup :: KeyHash 'StakePool -> Likelihood
histLookup KeyHash 'StakePool
k = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty KeyHash 'StakePool
k Map (KeyHash 'StakePool) Likelihood
ls
    topPools :: Set (KeyHash 'StakePool)
topPools =
      forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PerformanceEstimate
-> Set (KeyHash 'StakePool)
getTopRankedPoolsVMap
        Coin
rPot
        (Integer -> Coin
Coin Integer
totalStake)
        PParams era
pp
        VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Likelihood -> PerformanceEstimate
percentile' Map (KeyHash 'StakePool) Likelihood
ls)
    mkNMMRewards :: StakeShare -> (PerformanceEstimate, PoolParams, StakeShare) -> Coin
mkNMMRewards StakeShare
t (PerformanceEstimate
hitRateEst, PoolParams
poolp, StakeShare
sigma) =
      if PoolParams -> Bool
checkPledge PoolParams
poolp
        then forall era.
EraPParams era =>
PParams era
-> Coin
-> PoolParams
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash 'StakePool)
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew PParams era
pp Coin
rPot PoolParams
poolp StakeShare
s StakeShare
sigma StakeShare
t Set (KeyHash 'StakePool)
topPools PerformanceEstimate
hitRateEst
        else forall a. Monoid a => a
mempty
      where
        s :: StakeShare
s = (Coin -> StakeShare
toShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> Coin
ppPledge) PoolParams
poolp
        checkPledge :: PoolParams -> Bool
checkPledge PoolParams
pool =
          let ostake :: Coin
ostake = PoolParams -> Stake -> Coin
sumPoolOwnersStake PoolParams
pool Stake
stake
           in PoolParams -> Coin
ppPledge PoolParams
poolp forall a. Ord a => a -> a -> Bool
<= Coin
ostake

sumPoolOwnersStake :: PoolParams -> EB.Stake -> Coin
sumPoolOwnersStake :: PoolParams -> Stake -> Coin
sumPoolOwnersStake PoolParams
pool Stake
stake =
  let getStakeFor :: KeyHash 'Staking -> Coin
getStakeFor KeyHash 'Staking
o =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Compactible a => CompactForm a -> a
fromCompact forall a b. (a -> b) -> a -> b
$ forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
o) (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
EB.unStake Stake
stake)
   in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' KeyHash 'Staking -> Coin
getStakeFor (PoolParams -> Set (KeyHash 'Staking)
ppOwners PoolParams
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 :: forall era. EraGov era => NewEpochState era -> EB.SnapShot
currentSnapshot :: forall era. EraGov era => NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss =
  forall era.
EraPParams era =>
PParams era
-> IncrementalStake -> DState era -> PState era -> SnapShot
incrementalStakeDistr PParams era
pp IncrementalStake
incrementalStake DState era
dstate PState era
pstate
  where
    pp :: PParams era
pp = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    incrementalStake :: IncrementalStake
incrementalStake = forall era. UTxOState era -> IncrementalStake
utxosStakeDistr forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState
    dstate :: DState era
dstate = forall era. CertState era -> DState era
certDState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState
    pstate :: PState era
pstate = forall era. CertState era -> PState era
certPState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState

-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardInfoPool -> RewardInfoPool -> Bool
$c/= :: RewardInfoPool -> RewardInfoPool -> Bool
== :: RewardInfoPool -> RewardInfoPool -> Bool
$c== :: RewardInfoPool -> RewardInfoPool -> Bool
Eq, Int -> RewardInfoPool -> ShowS
[RewardInfoPool] -> ShowS
RewardInfoPool -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardInfoPool] -> ShowS
$cshowList :: [RewardInfoPool] -> ShowS
show :: RewardInfoPool -> String
$cshow :: RewardInfoPool -> String
showsPrec :: Int -> RewardInfoPool -> ShowS
$cshowsPrec :: Int -> RewardInfoPool -> ShowS
Show, 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
$cto :: forall x. Rep RewardInfoPool x -> RewardInfoPool
$cfrom :: forall x. RewardInfoPool -> Rep RewardInfoPool x
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardParams -> RewardParams -> Bool
$c/= :: RewardParams -> RewardParams -> Bool
== :: RewardParams -> RewardParams -> Bool
$c== :: RewardParams -> RewardParams -> Bool
Eq, Int -> RewardParams -> ShowS
[RewardParams] -> ShowS
RewardParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardParams] -> ShowS
$cshowList :: [RewardParams] -> ShowS
show :: RewardParams -> String
$cshow :: RewardParams -> String
showsPrec :: Int -> RewardParams -> ShowS
$cshowsPrec :: Int -> RewardParams -> ShowS
Show, 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
$cto :: forall x. Rep RewardParams x -> RewardParams
$cfrom :: forall x. RewardParams -> Rep RewardParams x
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 =>
  Globals ->
  NewEpochState era ->
  (RewardParams, Map (KeyHash 'StakePool) RewardInfoPool)
getRewardInfoPools :: forall era.
EraGov era =>
Globals
-> NewEpochState era
-> (RewardParams, Map (KeyHash 'StakePool) RewardInfoPool)
getRewardInfoPools Globals
globals NewEpochState era
ss =
  (RewardParams
mkRewardParams, forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (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 -> PoolParams -> RewardInfoPool
mkRewardInfoPool VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams))
  where
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov 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
      } = forall era. EpochState era -> NonMyopic
esNonMyopic EpochState era
es
    histLookup :: KeyHash 'StakePool -> Likelihood
histLookup KeyHash 'StakePool
key = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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) PoolParams
poolParams = forall era. EraGov era => NewEpochState era -> SnapShot
currentSnapshot NewEpochState era
ss

    mkRewardParams :: RewardParams
mkRewardParams =
      RewardParams
        { a0 :: NonNegativeInterval
a0 = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L
        , nOpt :: Word16
nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppNOptL
        , totalStake :: Coin
totalStake = forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
        , rPot :: Coin
rPot = Coin
rPot
        }
    mkRewardInfoPool :: KeyHash 'StakePool -> PoolParams -> RewardInfoPool
mkRewardInfoPool KeyHash 'StakePool
key PoolParams
poolp =
      RewardInfoPool
        { stake :: Coin
stake = Coin
pstake
        , ownerStake :: Coin
ownerStake = Coin
ostake
        , ownerPledge :: Coin
ownerPledge = PoolParams -> Coin
ppPledge PoolParams
poolp
        , margin :: UnitInterval
margin = PoolParams -> UnitInterval
ppMargin PoolParams
poolp
        , cost :: Coin
cost = PoolParams -> Coin
ppCost PoolParams
poolp
        , performanceEstimate :: Double
performanceEstimate =
            PerformanceEstimate -> Double
unPerformanceEstimate forall a b. (a -> b) -> a -> b
$ Likelihood -> PerformanceEstimate
percentile' forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Likelihood
histLookup KeyHash 'StakePool
key
        }
      where
        pstake :: Coin
pstake = Stake -> Coin
EB.sumAllStake 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 = PoolParams -> Stake -> Coin
sumPoolOwnersStake PoolParams
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 =>
  Globals ->
  NewEpochState era ->
  (RewardUpdate, RewardProvenance)
getRewardProvenance :: forall era.
EraGov era =>
Globals -> NewEpochState era -> (RewardUpdate, RewardProvenance)
getRewardProvenance Globals
globals NewEpochState era
newEpochState =
  ( forall r a. Reader r a -> r -> a
runReader
      (forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase RewardUpdate
createRUpd EpochSize
slotsPerEpoch BlocksMade
blocksMade EpochState era
epochState Coin
maxSupply ActiveSlotCoeff
asc Word64
secparam)
      Globals
globals
  , forall a. Default a => a
def
  )
  where
    epochState :: EpochState era
epochState = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
newEpochState
    maxSupply :: Coin
maxSupply = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Globals -> Word64
maxLovelaceSupply Globals
globals))
    blocksMade :: BlocksMade
blocksMade = forall era. NewEpochState era -> BlocksMade
nesBprev NewEpochState era
newEpochState
    epochNo :: EpochNo
epochNo = forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
newEpochState
    slotsPerEpoch :: EpochSize
    slotsPerEpoch :: EpochSize
slotsPerEpoch = HasCallStack => EpochInfo Identity -> EpochNo -> EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochNo
    asc :: ActiveSlotCoeff
asc = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    secparam :: Word64
secparam = Globals -> Word64
securityParameter Globals
globals

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

addKeyWitnesses :: EraTx era => Tx era -> Set (WitVKey 'Witness) -> Tx era
addKeyWitnesses :: forall era. EraTx era => Tx era -> Set (WitVKey 'Witness) -> Tx era
addKeyWitnesses Tx era
tx Set (WitVKey 'Witness)
newWits = Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ 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) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        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 Word16
p1
        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 NonNegativeInterval
p2
        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
p3
        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
p4

instance DecCBOR RewardParams where
  decCBOR :: forall s. Decoder s RewardParams
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 Word16 -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        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

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

instance DecCBOR RewardInfoPool where
  decCBOR :: forall s. Decoder s RewardInfoPool
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 Coin
-> Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool
RewardInfoPool
        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
        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. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall s. Decoder s Double
decodeDouble