{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.State.SnapShots (
  sumStakePerPool,
  StakePoolSnapShot (..),
  mkStakePoolSnapShot,
  SnapShot (..),
  mkSnapShot,
  leiosCandidates,
  MarkSnapShot (..),
  SetSnapShot (..),
  GoSnapShot (..),
  mkSetSnapShot,
  mkGoSnapShot,
  SnapShots (..),
  emptySnapShot,
  emptySnapShots,
  snapShotFromInstantStake,
  resetStakePoolsSnapShot,
  maxPool,
  maxPool',
  calculatePoolDistr,
  calculatePoolDistr',
  calculatePoolStake,
  ssStakeMarkL,
  ssStakeMarkPoolDistrL,
  ssStakeSetL,
  ssStakeGoL,
  ssFeeL,
  ssStake,
  ssStakeL,
  ssActiveStakeL,
  msSnapShotL,
  ssSnapShotL,
  ssLeiosCommitteeL,
  gsSnapShotL,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (..),
  EpochInterval (..),
  EpochNo (..),
  KeyValuePairs (..),
  NonNegativeInterval,
  NonZero (..),
  StrictMaybe (..),
  ToKeyValuePairs (..),
  UnitInterval,
  addEpochInterval,
  knownNonZeroBounded,
  nonZeroOr,
  recipNonZero,
  toIntegerNonZero,
  toRatioNonZero,
  unsafeNonZero,
  (%.),
  (/.),
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  Interns,
  decNoShareCBOR,
  decSharePlusLensCBOR,
  decodeListLen,
  decodeRecordNamedT,
  decodeVMap,
  encodeListLen,
 )
import Cardano.Ledger.Binary.Decoding (interns)
import Cardano.Ledger.Coin (
  Coin (..),
  coinToRational,
  knownNonZeroCoin,
  rationalToCoinViaFloor,
  unCoinNonZero,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), credKeyHash)
import Cardano.Ledger.State.CertState (DState (..), PState (..))
import Cardano.Ledger.State.LeiosCommittee (
  LeiosCandidate (..),
  LeiosCommittee (..),
  leiosCommitteeToJSON,
  selectLeiosCommittee,
 )
import Cardano.Ledger.State.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.State.Stake
import Cardano.Ledger.State.StakePool (BlsKeyState (..), StakePoolState (..))
import Cardano.Ledger.Val ((<+>))
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.State.Strict (get)
import Data.Aeson (ToJSON (..), (.=))
import Data.Default (Default, def)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.VMap (VB, VMap (..))
import qualified Data.VMap as VMap
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import Data.Word (Word16)
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (&), (^.), _1)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))

-- | Compute amount of stake each pool has. Any registered stake pool that has no stake will not be
-- included in the resulting map
sumStakePerPool ::
  VMap VB VB (Credential Staking) (KeyHash StakePool) ->
  Stake ->
  Map (KeyHash StakePool) Coin
sumStakePerPool :: VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake -> Map (KeyHash StakePool) Coin
sumStakePerPool VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
stake) = (Map (KeyHash StakePool) Coin
 -> Credential Staking
 -> CompactForm Coin
 -> Map (KeyHash StakePool) Coin)
-> Map (KeyHash StakePool) Coin
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> Map (KeyHash StakePool) Coin
forall (kv :: * -> *) k (vv :: * -> *) v a.
(Vector kv k, Vector vv v) =>
(a -> k -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldlWithKey Map (KeyHash StakePool) Coin
-> Credential Staking
-> CompactForm Coin
-> Map (KeyHash StakePool) Coin
accum Map (KeyHash StakePool) Coin
forall k a. Map k a
Map.empty VMap VB VP (Credential Staking) (CompactForm Coin)
stake
  where
    accum :: Map (KeyHash StakePool) Coin
-> Credential Staking
-> CompactForm Coin
-> Map (KeyHash StakePool) Coin
accum !Map (KeyHash StakePool) Coin
acc Credential Staking
cred CompactForm Coin
compactCoin =
      case Credential Staking
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Maybe (KeyHash StakePool)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential Staking
cred VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs of
        Maybe (KeyHash StakePool)
Nothing -> Map (KeyHash StakePool) Coin
acc
        Just KeyHash StakePool
kh -> (Coin -> Coin -> Coin)
-> KeyHash StakePool
-> Coin
-> Map (KeyHash StakePool) Coin
-> Map (KeyHash StakePool) Coin
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
(<+>) KeyHash StakePool
kh (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
compactCoin) Map (KeyHash StakePool) Coin
acc
{-# DEPRECATED sumStakePerPool "As no longer necessary" #-}

-- | Calculate maximal pool reward
maxPool' ::
  NonNegativeInterval ->
  NonZero Word16 ->
  Coin ->
  Rational ->
  Rational ->
  MaxPledgeLeverage ->
  Coin
maxPool' :: NonNegativeInterval
-> NonZero Word16
-> Coin
-> Rational
-> Rational
-> MaxPledgeLeverage
-> Coin
maxPool' NonNegativeInterval
a0 NonZero Word16
nOpt Coin
r Rational
sigma Rational
pR MaxPledgeLeverage
maxPledgeLeverage = Rational -> Coin
rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$ Rational
factor1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
factor2
  where
    nonZeroZ0 :: NonZero Rational
nonZeroZ0 = NonZero Rational -> NonZero Rational
forall a. Integral a => NonZero (Ratio a) -> NonZero (Ratio a)
recipNonZero (NonZero Rational -> NonZero Rational)
-> (NonZero Integer -> NonZero Rational)
-> NonZero Integer
-> NonZero Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonZero Integer -> NonZero Rational
forall a. Integral a => NonZero a -> NonZero (Ratio a)
toRatioNonZero (NonZero Integer -> NonZero Rational)
-> NonZero Integer -> NonZero Rational
forall a b. (a -> b) -> a -> b
$ NonZero Word16 -> NonZero Integer
forall a. Integral a => NonZero a -> NonZero Integer
toIntegerNonZero NonZero Word16
nOpt
    z0 :: Rational
z0 = NonZero Rational -> Rational
forall a. NonZero a -> a
unNonZero NonZero Rational
nonZeroZ0
    sigma' :: Rational
sigma' =
      Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
sigma Rational
z0 -- original Shelley behavior
        Rational -> (Rational -> Rational) -> Rational
forall a b. a -> (a -> b) -> b
& case MaxPledgeLeverage -> StrictMaybe NonNegativeInterval
unMaxPledgeLeverage MaxPledgeLeverage
maxPledgeLeverage of
          StrictMaybe NonNegativeInterval
SNothing -> Rational -> Rational
forall a. a -> a
id
          SJust NonNegativeInterval
l -> Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min (NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
l Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
pR) -- Dijkstra CIP-50 behavior
    p' :: Rational
p' = Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
pR Rational
z0
    factor1 :: Rational
factor1 =
      -- This division is safe, because a0 is non-negative and we're adding one
      -- to it
      Coin -> Rational
coinToRational Coin
r Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0)
    factor2 :: Rational
factor2 = Rational
sigma' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
p' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
factor3
    factor3 :: Rational
factor3 = (Rational
sigma' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
p' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
factor4) Rational -> NonZero Rational -> Rational
forall a. Fractional a => a -> NonZero a -> a
/. NonZero Rational
nonZeroZ0
    factor4 :: Rational
factor4 = (Rational
z0 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
sigma') Rational -> NonZero Rational -> Rational
forall a. Fractional a => a -> NonZero a -> a
/. NonZero Rational
nonZeroZ0

-- | Version of `maxPool'` that extracts `ppA0L`, `ppNOptL` and `ppMaxPledgeLeverageG` from a `PParams`.
maxPool ::
  EraPParams era =>
  PParams era ->
  Coin ->
  Rational ->
  Rational ->
  Coin
maxPool :: forall era.
EraPParams era =>
PParams era -> Coin -> Rational -> Rational -> Coin
maxPool PParams era
pp Coin
r Rational
sigma Rational
pR = NonNegativeInterval
-> NonZero Word16
-> Coin
-> Rational
-> Rational
-> MaxPledgeLeverage
-> Coin
maxPool' NonNegativeInterval
a0 NonZero Word16
nOpt Coin
r Rational
sigma Rational
pR MaxPledgeLeverage
maxPledgeLeverage
  where
    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 :: NonZero 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) Word16 -> NonZero Word16 -> NonZero Word16
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1
    maxPledgeLeverage :: MaxPledgeLeverage
maxPledgeLeverage = PParams era
pp PParams era
-> Getting MaxPledgeLeverage (PParams era) MaxPledgeLeverage
-> MaxPledgeLeverage
forall s a. s -> Getting a s a -> a
^. Getting MaxPledgeLeverage (PParams era) MaxPledgeLeverage
forall era.
EraPParams era =>
SimpleGetter (PParams era) MaxPledgeLeverage
SimpleGetter (PParams era) MaxPledgeLeverage
ppMaxPledgeLeverageG

-- | This type is the collection of all the necessary data per stake pool that is derived from the
-- `StakePoolState`, `InstantStake` and `Accounts` that is later used for reward
-- calculation
data StakePoolSnapShot = StakePoolSnapShot
  { StakePoolSnapShot -> CompactForm Coin
spssStake :: !(CompactForm Coin)
  -- ^ Total stake delegated to this stake pool.
  , StakePoolSnapShot -> Rational
spssStakeRatio :: !Rational
  -- ^ Ratio of the stake pool stake `spssStake` over the total `ssTotalActiveStake` for that snapshot
  , StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwners :: !(Set (KeyHash Staking))
  -- ^ Unlike owners that are specified in the `StakePoolParams`, the owners listed in this field
  -- are also ensured to be delegating to the stake pool they claim to own.
  , StakePoolSnapShot -> Coin
spssSelfDelegatedOwnersStake :: !Coin
  -- ^ Sum of all the stake that is associated with the owners of the pool listed in
  -- `spssSelfDelegatedOwners`
  , StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssVrf :: !(VRFVerKeyHash StakePoolVRF)
  -- ^ Corresponding field in the `StakePoolState` is `spsVrf`.
  , StakePoolSnapShot -> StrictMaybe BlsKeyState
spssBlsKey :: !(StrictMaybe BlsKeyState)
  -- ^ Corresponding field in the `StakePoolState` is `spsBlsKey`.
  , StakePoolSnapShot -> Coin
spssPledge :: !Coin
  -- ^ Corresponding field in the `StakePoolState` is `spsPledge`.
  , StakePoolSnapShot -> Coin
spssCost :: !Coin
  -- ^ Corresponding field in the `StakePoolState` is `spsCost`.
  , StakePoolSnapShot -> UnitInterval
spssMargin :: !UnitInterval
  -- ^ Corresponding field in the `StakePoolState` is `spsMargin`.
  , StakePoolSnapShot -> Int
spssNumDelegators :: !Int
  -- ^ Number of delegators, which is the count from the `spsDelegators` field.  We don't need the
  -- actual delegators, since at this point the actual stake has already been resolved.  This count
  -- is only needed to preserve older behavior where we filter out stake pools from `PoolDistr` that
  -- do not have any delegations.
  , StakePoolSnapShot -> AccountId
spssAccountId :: !AccountId
  -- ^ This is the account where stake pools rewards will be deposited to. Corresponding field in
  -- the `StakePoolState` is `spsAccountAddress`.
  }
  deriving (Int -> StakePoolSnapShot -> ShowS
[StakePoolSnapShot] -> ShowS
StakePoolSnapShot -> String
(Int -> StakePoolSnapShot -> ShowS)
-> (StakePoolSnapShot -> String)
-> ([StakePoolSnapShot] -> ShowS)
-> Show StakePoolSnapShot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StakePoolSnapShot -> ShowS
showsPrec :: Int -> StakePoolSnapShot -> ShowS
$cshow :: StakePoolSnapShot -> String
show :: StakePoolSnapShot -> String
$cshowList :: [StakePoolSnapShot] -> ShowS
showList :: [StakePoolSnapShot] -> ShowS
Show, StakePoolSnapShot -> StakePoolSnapShot -> Bool
(StakePoolSnapShot -> StakePoolSnapShot -> Bool)
-> (StakePoolSnapShot -> StakePoolSnapShot -> Bool)
-> Eq StakePoolSnapShot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StakePoolSnapShot -> StakePoolSnapShot -> Bool
== :: StakePoolSnapShot -> StakePoolSnapShot -> Bool
$c/= :: StakePoolSnapShot -> StakePoolSnapShot -> Bool
/= :: StakePoolSnapShot -> StakePoolSnapShot -> Bool
Eq, (forall x. StakePoolSnapShot -> Rep StakePoolSnapShot x)
-> (forall x. Rep StakePoolSnapShot x -> StakePoolSnapShot)
-> Generic StakePoolSnapShot
forall x. Rep StakePoolSnapShot x -> StakePoolSnapShot
forall x. StakePoolSnapShot -> Rep StakePoolSnapShot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StakePoolSnapShot -> Rep StakePoolSnapShot x
from :: forall x. StakePoolSnapShot -> Rep StakePoolSnapShot x
$cto :: forall x. Rep StakePoolSnapShot x -> StakePoolSnapShot
to :: forall x. Rep StakePoolSnapShot x -> StakePoolSnapShot
Generic)
  deriving ([StakePoolSnapShot] -> Value
[StakePoolSnapShot] -> Encoding
StakePoolSnapShot -> Bool
StakePoolSnapShot -> Value
StakePoolSnapShot -> Encoding
(StakePoolSnapShot -> Value)
-> (StakePoolSnapShot -> Encoding)
-> ([StakePoolSnapShot] -> Value)
-> ([StakePoolSnapShot] -> Encoding)
-> (StakePoolSnapShot -> Bool)
-> ToJSON StakePoolSnapShot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: StakePoolSnapShot -> Value
toJSON :: StakePoolSnapShot -> Value
$ctoEncoding :: StakePoolSnapShot -> Encoding
toEncoding :: StakePoolSnapShot -> Encoding
$ctoJSONList :: [StakePoolSnapShot] -> Value
toJSONList :: [StakePoolSnapShot] -> Value
$ctoEncodingList :: [StakePoolSnapShot] -> Encoding
toEncodingList :: [StakePoolSnapShot] -> Encoding
$comitField :: StakePoolSnapShot -> Bool
omitField :: StakePoolSnapShot -> Bool
ToJSON) via KeyValuePairs StakePoolSnapShot

mkStakePoolSnapShot ::
  -- | Active Stake
  ActiveStake ->
  -- | Total Active Stake
  NonZero Coin ->
  -- | Stake Pool State
  StakePoolState ->
  StakePoolSnapShot
mkStakePoolSnapShot :: ActiveStake -> NonZero Coin -> StakePoolState -> StakePoolSnapShot
mkStakePoolSnapShot ActiveStake
activeStake NonZero Coin
totalActiveStake StakePoolState
stakePoolState =
  StakePoolSnapShot
    { spssStake :: CompactForm Coin
spssStake = CompactForm Coin
stakePoolStake
    , spssStakeRatio :: Rational
spssStakeRatio = Coin -> Integer
unCoin (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
stakePoolStake) Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. NonZero Coin -> NonZero Integer
unCoinNonZero NonZero Coin
totalActiveStake
    , spssSelfDelegatedOwners :: Set (KeyHash Staking)
spssSelfDelegatedOwners = Set (KeyHash Staking)
selfDelegatedOwners
    , spssSelfDelegatedOwnersStake :: Coin
spssSelfDelegatedOwnersStake =
        CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$
          ActiveStake -> [Credential Staking] -> CompactForm Coin
forall (f :: * -> *).
Foldable f =>
ActiveStake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactActiveStake ActiveStake
activeStake ([Credential Staking] -> CompactForm Coin)
-> [Credential Staking] -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$
            -- Conversion to a list allows us to tap into list fusion, thus avoiding unnecessary
            -- extra Set allocation and `O(n*log(n))` mappping over a Set.
            (KeyHash Staking -> Credential Staking)
-> [KeyHash Staking] -> [Credential Staking]
forall a b. (a -> b) -> [a] -> [b]
map KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (Set (KeyHash Staking) -> [KeyHash Staking]
forall a. Set a -> [a]
Set.elems Set (KeyHash Staking)
selfDelegatedOwners)
    , spssVrf :: VRFVerKeyHash StakePoolVRF
spssVrf = VRFVerKeyHash StakePoolVRF
spsVrf
    , spssBlsKey :: StrictMaybe BlsKeyState
spssBlsKey = StrictMaybe BlsKeyState
spsBlsKey
    , spssPledge :: Coin
spssPledge = Coin
spsPledge
    , spssCost :: Coin
spssCost = Coin
spsCost
    , spssMargin :: UnitInterval
spssMargin = UnitInterval
spsMargin
    , spssNumDelegators :: Int
spssNumDelegators = Set (Credential Staking) -> Int
forall a. Set a -> Int
Set.size Set (Credential Staking)
spsDelegators
    , spssAccountId :: AccountId
spssAccountId = AccountId
spsAccountId
    }
  where
    StakePoolState
      { VRFVerKeyHash StakePoolVRF
spsVrf :: StakePoolState -> VRFVerKeyHash StakePoolVRF
spsVrf :: VRFVerKeyHash StakePoolVRF
spsVrf
      , StrictMaybe BlsKeyState
spsBlsKey :: StakePoolState -> StrictMaybe BlsKeyState
spsBlsKey :: StrictMaybe BlsKeyState
spsBlsKey
      , Coin
spsPledge :: StakePoolState -> Coin
spsPledge :: Coin
spsPledge
      , Coin
spsCost :: StakePoolState -> Coin
spsCost :: Coin
spsCost
      , UnitInterval
spsMargin :: StakePoolState -> UnitInterval
spsMargin :: UnitInterval
spsMargin
      , AccountId
spsAccountId :: AccountId
spsAccountId :: StakePoolState -> AccountId
spsAccountId
      , Set (KeyHash Staking)
spsOwners :: Set (KeyHash Staking)
spsOwners :: StakePoolState -> Set (KeyHash Staking)
spsOwners
      , Set (Credential Staking)
spsDelegators :: StakePoolState -> Set (Credential Staking)
spsDelegators :: Set (Credential Staking)
spsDelegators
      } =
        StakePoolState
stakePoolState
    selfDelegatedOwners :: Set (KeyHash Staking)
selfDelegatedOwners =
      (KeyHash Staking -> Bool)
-> Set (KeyHash Staking) -> Set (KeyHash Staking)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\KeyHash Staking
ownerKeyHash -> KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
ownerKeyHash Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Credential Staking)
spsDelegators) Set (KeyHash Staking)
spsOwners
    stakePoolStake :: CompactForm Coin
stakePoolStake = ActiveStake -> Set (Credential Staking) -> CompactForm Coin
forall (f :: * -> *).
Foldable f =>
ActiveStake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactActiveStake ActiveStake
activeStake Set (Credential Staking)
spsDelegators

instance NoThunks StakePoolSnapShot

instance NFData StakePoolSnapShot

instance ToKeyValuePairs StakePoolSnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => StakePoolSnapShot -> [kv]
toKeyValuePairs ss :: StakePoolSnapShot
ss@(StakePoolSnapShot CompactForm Coin
_ Rational
_ Set (KeyHash Staking)
_ Coin
_ VRFVerKeyHash StakePoolVRF
_ StrictMaybe BlsKeyState
_ Coin
_ Coin
_ UnitInterval
_ Int
_ AccountId
_) =
    let StakePoolSnapShot {Int
Rational
Set (KeyHash Staking)
StrictMaybe BlsKeyState
CompactForm Coin
VRFVerKeyHash StakePoolVRF
UnitInterval
Coin
AccountId
spssStake :: StakePoolSnapShot -> CompactForm Coin
spssStakeRatio :: StakePoolSnapShot -> Rational
spssSelfDelegatedOwners :: StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: StakePoolSnapShot -> Coin
spssVrf :: StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssBlsKey :: StakePoolSnapShot -> StrictMaybe BlsKeyState
spssPledge :: StakePoolSnapShot -> Coin
spssCost :: StakePoolSnapShot -> Coin
spssMargin :: StakePoolSnapShot -> UnitInterval
spssNumDelegators :: StakePoolSnapShot -> Int
spssAccountId :: StakePoolSnapShot -> AccountId
spssStake :: CompactForm Coin
spssStakeRatio :: Rational
spssSelfDelegatedOwners :: Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: Coin
spssVrf :: VRFVerKeyHash StakePoolVRF
spssBlsKey :: StrictMaybe BlsKeyState
spssPledge :: Coin
spssCost :: Coin
spssMargin :: UnitInterval
spssNumDelegators :: Int
spssAccountId :: AccountId
..} = StakePoolSnapShot
ss
     in [ Key
"stake" Key -> CompactForm Coin -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CompactForm Coin
spssStake
        , Key
"stakeRatio" Key -> Rational -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Rational
spssStakeRatio
        , Key
"selfDelegatedOwners" Key -> Set (KeyHash Staking) -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set (KeyHash Staking)
spssSelfDelegatedOwners
        , Key
"selfDelegatedOwnersStake" Key -> Coin -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
spssSelfDelegatedOwnersStake
        , Key
"vrf" Key -> VRFVerKeyHash StakePoolVRF -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VRFVerKeyHash StakePoolVRF
spssVrf
        , Key
"blsKey" Key -> StrictMaybe BlsKeyState -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StrictMaybe BlsKeyState
spssBlsKey
        , Key
"pledge" Key -> Coin -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
spssPledge
        , Key
"cost" Key -> Coin -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
spssCost
        , Key
"margin" Key -> UnitInterval -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UnitInterval
spssMargin
        , Key
"numDelegators" Key -> Int -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
spssNumDelegators
        , Key
"accountId" Key -> AccountId -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AccountId
spssAccountId
        ]

instance EncCBOR StakePoolSnapShot where
  encCBOR :: StakePoolSnapShot -> Encoding
encCBOR spss :: StakePoolSnapShot
spss@(StakePoolSnapShot CompactForm Coin
_ Rational
_ Set (KeyHash Staking)
_ Coin
_ VRFVerKeyHash StakePoolVRF
_ StrictMaybe BlsKeyState
_ Coin
_ Coin
_ UnitInterval
_ Int
_ AccountId
_) =
    let StakePoolSnapShot {Int
Rational
Set (KeyHash Staking)
StrictMaybe BlsKeyState
CompactForm Coin
VRFVerKeyHash StakePoolVRF
UnitInterval
Coin
AccountId
spssStake :: StakePoolSnapShot -> CompactForm Coin
spssStakeRatio :: StakePoolSnapShot -> Rational
spssSelfDelegatedOwners :: StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: StakePoolSnapShot -> Coin
spssVrf :: StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssBlsKey :: StakePoolSnapShot -> StrictMaybe BlsKeyState
spssPledge :: StakePoolSnapShot -> Coin
spssCost :: StakePoolSnapShot -> Coin
spssMargin :: StakePoolSnapShot -> UnitInterval
spssNumDelegators :: StakePoolSnapShot -> Int
spssAccountId :: StakePoolSnapShot -> AccountId
spssStake :: CompactForm Coin
spssStakeRatio :: Rational
spssSelfDelegatedOwners :: Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: Coin
spssVrf :: VRFVerKeyHash StakePoolVRF
spssBlsKey :: StrictMaybe BlsKeyState
spssPledge :: Coin
spssCost :: Coin
spssMargin :: UnitInterval
spssNumDelegators :: Int
spssAccountId :: AccountId
..} = StakePoolSnapShot
spss
     in Word -> Encoding
encodeListLen Word
11
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR CompactForm Coin
spssStake
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Rational -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Rational
spssStakeRatio
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (KeyHash Staking) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Set (KeyHash Staking)
spssSelfDelegatedOwners
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
spssSelfDelegatedOwnersStake
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VRFVerKeyHash StakePoolVRF -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VRFVerKeyHash StakePoolVRF
spssVrf
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StrictMaybe BlsKeyState -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StrictMaybe BlsKeyState
spssBlsKey
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
spssPledge
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
spssCost
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UnitInterval -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR UnitInterval
spssMargin
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Int
spssNumDelegators
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AccountId -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR AccountId
spssAccountId

instance DecShareCBOR StakePoolSnapShot where
  type Share StakePoolSnapShot = Interns (Credential Staking)
  decSharePlusCBOR :: forall s.
StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
decSharePlusCBOR = Text
-> (StakePoolSnapShot -> Int)
-> StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
-> StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"StakePoolSnapShot" (Int -> StakePoolSnapShot -> Int
forall a b. a -> b -> a
const Int
11) (StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
 -> StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot)
-> StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
-> StateT (Share StakePoolSnapShot) (Decoder s) StakePoolSnapShot
forall a b. (a -> b) -> a -> b
$ do
    credInterns <- StateT
  (Interns (Credential Staking))
  (Decoder s)
  (Interns (Credential Staking))
forall (m :: * -> *) s. Monad m => StateT s m s
get
    spssStake <- lift decCBOR
    spssStakeRatio <- lift decCBOR
    let unwrap Credential r
cred =
          KeyHash r -> Maybe (KeyHash r) -> KeyHash r
forall a. a -> Maybe a -> a
fromMaybe (String -> KeyHash r
forall a. HasCallStack => String -> a
error (String -> KeyHash r) -> String -> KeyHash r
forall a b. (a -> b) -> a -> b
$ String
"Impossible: Unwrapping an intern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Credential r -> String
forall a. Show a => a -> String
show Credential r
cred) (Maybe (KeyHash r) -> KeyHash r) -> Maybe (KeyHash r) -> KeyHash r
forall a b. (a -> b) -> a -> b
$ Credential r -> Maybe (KeyHash r)
forall (r :: KeyRole). Credential r -> Maybe (KeyHash r)
credKeyHash Credential r
cred
    spssSelfDelegatedOwners <- Set.map (unwrap . interns credInterns . KeyHashObj) <$> lift decCBOR
    spssSelfDelegatedOwnersStake <- lift decCBOR
    spssVrf <- lift decCBOR
    spssBlsKey <- lift decCBOR
    spssPledge <- lift decCBOR
    spssCost <- lift decCBOR
    spssMargin <- lift decCBOR
    spssNumDelegators <- lift decCBOR
    spssAccountId <- AccountId . interns credInterns <$> lift decCBOR
    pure StakePoolSnapShot {..}

-- | Snapshot of the stake distribution.
data SnapShot = SnapShot
  { SnapShot -> ActiveStake
ssActiveStake :: !ActiveStake
  -- ^ All of the stake for registered staking credentials that have a delegation to a stake pool.
  , SnapShot -> NonZero Coin
ssTotalActiveStake :: !(NonZero Coin)
  -- ^ Total active stake, which is the sum of all of the stake from `ssActiveStake`. It is primarily used
  -- in a denominator, therefore it cannot be zero and is defaulted to 1. This is a reasonable
  -- assumption for a system that relies on non-zero active stake to produce blocks.
  , SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot :: !(VMap VB VB (KeyHash StakePool) StakePoolSnapShot)
  -- ^ Snapshot of stake pools' information that is relevant only for the reward calculation logic.
  }
  deriving (Int -> SnapShot -> ShowS
[SnapShot] -> ShowS
SnapShot -> String
(Int -> SnapShot -> ShowS)
-> (SnapShot -> String) -> ([SnapShot] -> ShowS) -> Show SnapShot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapShot -> ShowS
showsPrec :: Int -> SnapShot -> ShowS
$cshow :: SnapShot -> String
show :: SnapShot -> String
$cshowList :: [SnapShot] -> ShowS
showList :: [SnapShot] -> ShowS
Show, SnapShot -> SnapShot -> Bool
(SnapShot -> SnapShot -> Bool)
-> (SnapShot -> SnapShot -> Bool) -> Eq SnapShot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapShot -> SnapShot -> Bool
== :: SnapShot -> SnapShot -> Bool
$c/= :: SnapShot -> SnapShot -> Bool
/= :: SnapShot -> SnapShot -> Bool
Eq, (forall x. SnapShot -> Rep SnapShot x)
-> (forall x. Rep SnapShot x -> SnapShot) -> Generic SnapShot
forall x. Rep SnapShot x -> SnapShot
forall x. SnapShot -> Rep SnapShot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapShot -> Rep SnapShot x
from :: forall x. SnapShot -> Rep SnapShot x
$cto :: forall x. Rep SnapShot x -> SnapShot
to :: forall x. Rep SnapShot x -> SnapShot
Generic)
  deriving ([SnapShot] -> Value
[SnapShot] -> Encoding
SnapShot -> Bool
SnapShot -> Value
SnapShot -> Encoding
(SnapShot -> Value)
-> (SnapShot -> Encoding)
-> ([SnapShot] -> Value)
-> ([SnapShot] -> Encoding)
-> (SnapShot -> Bool)
-> ToJSON SnapShot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SnapShot -> Value
toJSON :: SnapShot -> Value
$ctoEncoding :: SnapShot -> Encoding
toEncoding :: SnapShot -> Encoding
$ctoJSONList :: [SnapShot] -> Value
toJSONList :: [SnapShot] -> Value
$ctoEncodingList :: [SnapShot] -> Encoding
toEncodingList :: [SnapShot] -> Encoding
$comitField :: SnapShot -> Bool
omitField :: SnapShot -> Bool
ToJSON) via KeyValuePairs SnapShot

instance NFData SnapShot

instance NoThunks SnapShot

instance EncCBOR SnapShot where
  encCBOR :: SnapShot -> Encoding
encCBOR ss :: SnapShot
ss@(SnapShot ActiveStake
_ NonZero Coin
_ VMap VB VB (KeyHash StakePool) StakePoolSnapShot
_) =
    let SnapShot {VMap VB VB (KeyHash StakePool) StakePoolSnapShot
NonZero Coin
ActiveStake
ssTotalActiveStake :: SnapShot -> NonZero Coin
ssActiveStake :: SnapShot -> ActiveStake
ssStakePoolsSnapShot :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssActiveStake :: ActiveStake
ssTotalActiveStake :: NonZero Coin
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
..} = SnapShot
ss
     in Word -> Encoding
encodeListLen Word
2
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ActiveStake -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ActiveStake
ssActiveStake
          -- `ssTotalActiveStake` is ommitted on purpose
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VMap VB VB (KeyHash StakePool) StakePoolSnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot

instance DecShareCBOR SnapShot where
  type Share SnapShot = (Interns (Credential Staking), Interns (KeyHash StakePool))
  decSharePlusCBOR :: forall s. StateT (Share SnapShot) (Decoder s) SnapShot
decSharePlusCBOR = do
    n <- Decoder s Int
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool))
     (Decoder s)
     Int
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s Int
forall s. Decoder s Int
decodeListLen
    case n of
      Int
2 -> do
        -- New format: [ActiveStake, StakePoolsSnapShot]
        activeStake <- Lens'
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Share ActiveStake)
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool))
     (Decoder s)
     ActiveStake
forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (Share ActiveStake -> f (Share ActiveStake))
-> (Interns (Credential Staking), Interns (KeyHash StakePool))
-> f (Interns (Credential Staking), Interns (KeyHash StakePool))
(Interns (Credential Staking) -> f (Interns (Credential Staking)))
-> (Interns (Credential Staking), Interns (KeyHash StakePool))
-> f (Interns (Credential Staking), Interns (KeyHash StakePool))
forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Share ActiveStake)
Lens
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Interns (Credential Staking))
  (Interns (Credential Staking))
_1
        (stakeCredInterns, stakePoolIdInterns) <- get
        stakePoolsSnapShot <-
          lift $ decodeVMap (interns stakePoolIdInterns <$> decCBOR) (decShareCBOR stakeCredInterns)
        pure $ mkSnapShot activeStake stakePoolsSnapShot
      Int
3 -> do
        -- Old format: [Stake, Delegations, StakePoolsSnapShot]
        oldStake <- Lens'
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Share Stake)
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool))
     (Decoder s)
     Stake
forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (Share Stake -> f (Share Stake))
-> (Interns (Credential Staking), Interns (KeyHash StakePool))
-> f (Interns (Credential Staking), Interns (KeyHash StakePool))
(Interns (Credential Staking) -> f (Interns (Credential Staking)))
-> (Interns (Credential Staking), Interns (KeyHash StakePool))
-> f (Interns (Credential Staking), Interns (KeyHash StakePool))
forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Share Stake)
Lens
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Interns (Credential Staking))
  (Interns (Credential Staking))
_1
        (oldDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)) <-
          decSharePlusCBOR
        (stakeCredInterns, stakePoolIdInterns) <- get
        stakePoolsSnapShot <-
          lift $ decodeVMap (interns stakePoolIdInterns <$> decCBOR) (decShareCBOR stakeCredInterns)
        let activeStake =
              VMap VB VS (Credential Staking) StakeWithDelegation -> ActiveStake
ActiveStake (VMap VB VS (Credential Staking) StakeWithDelegation
 -> ActiveStake)
-> VMap VB VS (Credential Staking) StakeWithDelegation
-> ActiveStake
forall a b. (a -> b) -> a -> b
$
                [(Credential Staking, StakeWithDelegation)]
-> VMap VB VS (Credential Staking) StakeWithDelegation
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
[(k, v)] -> VMap kv vv k v
VMap.fromDistinctAscList
                  [ (Credential Staking
cred, NonZero (CompactForm Coin)
-> KeyHash StakePool -> StakeWithDelegation
StakeWithDelegation (CompactForm Coin -> NonZero (CompactForm Coin)
forall a. a -> NonZero a
unsafeNonZero CompactForm Coin
cc) KeyHash StakePool
deleg)
                  | (Credential Staking
cred, CompactForm Coin
cc) <- VMap VB VP (Credential Staking) (CompactForm Coin)
-> [(Credential Staking, CompactForm Coin)]
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList (VMap VB VP (Credential Staking) (CompactForm Coin)
 -> [(Credential Staking, CompactForm Coin)])
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> [(Credential Staking, CompactForm Coin)]
forall a b. (a -> b) -> a -> b
$ Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake Stake
oldStake
                  , Just KeyHash StakePool
deleg <- [Credential Staking
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Maybe (KeyHash StakePool)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential Staking
cred VMap VB VB (Credential Staking) (KeyHash StakePool)
oldDelegations]
                  ]
        pure $ mkSnapShot activeStake stakePoolsSnapShot
      Int
_ -> Decoder s SnapShot
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool))
     (Decoder s)
     SnapShot
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s SnapShot
 -> StateT
      (Interns (Credential Staking), Interns (KeyHash StakePool))
      (Decoder s)
      SnapShot)
-> Decoder s SnapShot
-> StateT
     (Interns (Credential Staking), Interns (KeyHash StakePool))
     (Decoder s)
     SnapShot
forall a b. (a -> b) -> a -> b
$ String -> Decoder s SnapShot
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s SnapShot) -> String -> Decoder s SnapShot
forall a b. (a -> b) -> a -> b
$ String
"Expected 2 or 3 fields for SnapShot, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n

instance ToKeyValuePairs SnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => SnapShot -> [kv]
toKeyValuePairs ss :: SnapShot
ss@(SnapShot ActiveStake
_ NonZero Coin
_ VMap VB VB (KeyHash StakePool) StakePoolSnapShot
_) =
    let SnapShot {VMap VB VB (KeyHash StakePool) StakePoolSnapShot
NonZero Coin
ActiveStake
ssTotalActiveStake :: SnapShot -> NonZero Coin
ssActiveStake :: SnapShot -> ActiveStake
ssStakePoolsSnapShot :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssActiveStake :: ActiveStake
ssTotalActiveStake :: NonZero Coin
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
..} = SnapShot
ss
     in [ Key
"activeStake" Key -> ActiveStake -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ActiveStake
ssActiveStake
        , Key
"stakePoolsSnapShot" Key -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot
        ]

-- | The freshest snapshot, taken at the boundary into 'msEpochNo'. Alongside
-- the stake standing it records the inputs that the Leios committee will be
-- selected from when this snapshot rotates into 'SetSnapShot'.
data MarkSnapShot = MarkSnapShot
  { MarkSnapShot -> SnapShot
msSnapShot :: SnapShot
  -- ^ Lazy on purpose. See ADR-7.
  , MarkSnapShot -> EpochNo
msEpochNo :: !EpochNo
  -- ^ Epoch number at the beginning of which this snapshot was created.
  , MarkSnapShot -> Word16
msLeiosCommitteeSize :: !Word16
  -- ^ Size of the Leios voting committee as set by @ppLeiosCommitteeSize@ upon
  -- snapshot creation (CIP-0164). Zero before Dijkstra.
  }
  deriving (Int -> MarkSnapShot -> ShowS
[MarkSnapShot] -> ShowS
MarkSnapShot -> String
(Int -> MarkSnapShot -> ShowS)
-> (MarkSnapShot -> String)
-> ([MarkSnapShot] -> ShowS)
-> Show MarkSnapShot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkSnapShot -> ShowS
showsPrec :: Int -> MarkSnapShot -> ShowS
$cshow :: MarkSnapShot -> String
show :: MarkSnapShot -> String
$cshowList :: [MarkSnapShot] -> ShowS
showList :: [MarkSnapShot] -> ShowS
Show, MarkSnapShot -> MarkSnapShot -> Bool
(MarkSnapShot -> MarkSnapShot -> Bool)
-> (MarkSnapShot -> MarkSnapShot -> Bool) -> Eq MarkSnapShot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MarkSnapShot -> MarkSnapShot -> Bool
== :: MarkSnapShot -> MarkSnapShot -> Bool
$c/= :: MarkSnapShot -> MarkSnapShot -> Bool
/= :: MarkSnapShot -> MarkSnapShot -> Bool
Eq, (forall x. MarkSnapShot -> Rep MarkSnapShot x)
-> (forall x. Rep MarkSnapShot x -> MarkSnapShot)
-> Generic MarkSnapShot
forall x. Rep MarkSnapShot x -> MarkSnapShot
forall x. MarkSnapShot -> Rep MarkSnapShot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MarkSnapShot -> Rep MarkSnapShot x
from :: forall x. MarkSnapShot -> Rep MarkSnapShot x
$cto :: forall x. Rep MarkSnapShot x -> MarkSnapShot
to :: forall x. Rep MarkSnapShot x -> MarkSnapShot
Generic)
  deriving ([MarkSnapShot] -> Value
[MarkSnapShot] -> Encoding
MarkSnapShot -> Bool
MarkSnapShot -> Value
MarkSnapShot -> Encoding
(MarkSnapShot -> Value)
-> (MarkSnapShot -> Encoding)
-> ([MarkSnapShot] -> Value)
-> ([MarkSnapShot] -> Encoding)
-> (MarkSnapShot -> Bool)
-> ToJSON MarkSnapShot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: MarkSnapShot -> Value
toJSON :: MarkSnapShot -> Value
$ctoEncoding :: MarkSnapShot -> Encoding
toEncoding :: MarkSnapShot -> Encoding
$ctoJSONList :: [MarkSnapShot] -> Value
toJSONList :: [MarkSnapShot] -> Value
$ctoEncodingList :: [MarkSnapShot] -> Encoding
toEncodingList :: [MarkSnapShot] -> Encoding
$comitField :: MarkSnapShot -> Bool
omitField :: MarkSnapShot -> Bool
ToJSON) via KeyValuePairs MarkSnapShot

instance NFData MarkSnapShot

deriving via AllowThunksIn '["msSnapShot"] MarkSnapShot instance NoThunks MarkSnapShot

instance EncCBOR MarkSnapShot where
  encCBOR :: MarkSnapShot -> Encoding
encCBOR ms :: MarkSnapShot
ms@(MarkSnapShot SnapShot
_ EpochNo
_ Word16
_) =
    let MarkSnapShot {Word16
EpochNo
SnapShot
msEpochNo :: MarkSnapShot -> EpochNo
msSnapShot :: MarkSnapShot -> SnapShot
msLeiosCommitteeSize :: MarkSnapShot -> Word16
msSnapShot :: SnapShot
msEpochNo :: EpochNo
msLeiosCommitteeSize :: Word16
..} = MarkSnapShot
ms
     in Word -> Encoding
encodeListLen Word
3
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot
msSnapShot
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
msEpochNo
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word16 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word16
msLeiosCommitteeSize

instance DecShareCBOR MarkSnapShot where
  type Share MarkSnapShot = Share SnapShot
  decSharePlusCBOR :: forall s. StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
decSharePlusCBOR = Text
-> (MarkSnapShot -> Int)
-> StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
-> StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"MarkSnapShot" (Int -> MarkSnapShot -> Int
forall a b. a -> b -> a
const Int
3) (StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
 -> StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot)
-> StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
-> StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
forall a b. (a -> b) -> a -> b
$ do
    msSnapShot <- StateT
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Decoder s)
  SnapShot
StateT (Share SnapShot) (Decoder s) SnapShot
forall s. StateT (Share SnapShot) (Decoder s) SnapShot
forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    msEpochNo <- lift decCBOR
    msLeiosCommitteeSize <- lift decCBOR
    pure MarkSnapShot {msSnapShot, msEpochNo, msLeiosCommitteeSize}

instance ToKeyValuePairs MarkSnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => MarkSnapShot -> [kv]
toKeyValuePairs ms :: MarkSnapShot
ms@(MarkSnapShot SnapShot
_ EpochNo
_ Word16
_) =
    let MarkSnapShot {Word16
EpochNo
SnapShot
msEpochNo :: MarkSnapShot -> EpochNo
msSnapShot :: MarkSnapShot -> SnapShot
msLeiosCommitteeSize :: MarkSnapShot -> Word16
msSnapShot :: SnapShot
msEpochNo :: EpochNo
msLeiosCommitteeSize :: Word16
..} = MarkSnapShot
ms
     in [ Key
"snapShot" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
msSnapShot
        , Key
"epochNo" Key -> EpochNo -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EpochNo
msEpochNo
        , Key
"leiosCommitteeSize" Key -> Word16 -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word16
msLeiosCommitteeSize
        ]

-- | The snapshot that drives leader election ('Cardano.Ledger.State.PoolDistr')
-- and Leios voting for the epoch after the one it was marked in. The Leios
-- committee is seated here, when the mark rotates into the set position.
data SetSnapShot = SetSnapShot
  { SetSnapShot -> SnapShot
ssSnapShot :: !SnapShot
  , SetSnapShot -> PoolDistr
ssPoolDistr :: !PoolDistr
  , SetSnapShot -> LeiosCommittee
ssLeiosCommittee :: !LeiosCommittee
  -- ^ The Leios voting committee governing the epoch this snapshot is the
  -- leader-election distribution of (CIP-0164). Seated at rotation while
  -- pre-Dijkstra eras leave it empty.
  }
  deriving (Int -> SetSnapShot -> ShowS
[SetSnapShot] -> ShowS
SetSnapShot -> String
(Int -> SetSnapShot -> ShowS)
-> (SetSnapShot -> String)
-> ([SetSnapShot] -> ShowS)
-> Show SetSnapShot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetSnapShot -> ShowS
showsPrec :: Int -> SetSnapShot -> ShowS
$cshow :: SetSnapShot -> String
show :: SetSnapShot -> String
$cshowList :: [SetSnapShot] -> ShowS
showList :: [SetSnapShot] -> ShowS
Show, SetSnapShot -> SetSnapShot -> Bool
(SetSnapShot -> SetSnapShot -> Bool)
-> (SetSnapShot -> SetSnapShot -> Bool) -> Eq SetSnapShot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SetSnapShot -> SetSnapShot -> Bool
== :: SetSnapShot -> SetSnapShot -> Bool
$c/= :: SetSnapShot -> SetSnapShot -> Bool
/= :: SetSnapShot -> SetSnapShot -> Bool
Eq, (forall x. SetSnapShot -> Rep SetSnapShot x)
-> (forall x. Rep SetSnapShot x -> SetSnapShot)
-> Generic SetSnapShot
forall x. Rep SetSnapShot x -> SetSnapShot
forall x. SetSnapShot -> Rep SetSnapShot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SetSnapShot -> Rep SetSnapShot x
from :: forall x. SetSnapShot -> Rep SetSnapShot x
$cto :: forall x. Rep SetSnapShot x -> SetSnapShot
to :: forall x. Rep SetSnapShot x -> SetSnapShot
Generic)
  deriving ([SetSnapShot] -> Value
[SetSnapShot] -> Encoding
SetSnapShot -> Bool
SetSnapShot -> Value
SetSnapShot -> Encoding
(SetSnapShot -> Value)
-> (SetSnapShot -> Encoding)
-> ([SetSnapShot] -> Value)
-> ([SetSnapShot] -> Encoding)
-> (SetSnapShot -> Bool)
-> ToJSON SetSnapShot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SetSnapShot -> Value
toJSON :: SetSnapShot -> Value
$ctoEncoding :: SetSnapShot -> Encoding
toEncoding :: SetSnapShot -> Encoding
$ctoJSONList :: [SetSnapShot] -> Value
toJSONList :: [SetSnapShot] -> Value
$ctoEncodingList :: [SetSnapShot] -> Encoding
toEncodingList :: [SetSnapShot] -> Encoding
$comitField :: SetSnapShot -> Bool
omitField :: SetSnapShot -> Bool
ToJSON) via KeyValuePairs SetSnapShot

instance NFData SetSnapShot

deriving via AllowThunksIn '["ssLeiosCommittee"] SetSnapShot instance NoThunks SetSnapShot

instance EncCBOR SetSnapShot where
  encCBOR :: SetSnapShot -> Encoding
encCBOR ss :: SetSnapShot
ss@(SetSnapShot SnapShot
_ PoolDistr
_ LeiosCommittee
_) =
    let SetSnapShot {LeiosCommittee
PoolDistr
SnapShot
ssSnapShot :: SetSnapShot -> SnapShot
ssPoolDistr :: SetSnapShot -> PoolDistr
ssLeiosCommittee :: SetSnapShot -> LeiosCommittee
ssSnapShot :: SnapShot
ssPoolDistr :: PoolDistr
ssLeiosCommittee :: LeiosCommittee
..} = SetSnapShot
ss
     in -- `ssPoolDistr` is omitted on purpose: it is derived from the snapshot.
        -- The committee is stored so it need not be re-selected on decode, which
        -- also frees us from recording the honoured key age it was seated with.
        Word -> Encoding
encodeListLen Word
2
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot
ssSnapShot
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LeiosCommittee -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR LeiosCommittee
ssLeiosCommittee

instance DecShareCBOR SetSnapShot where
  type Share SetSnapShot = Share SnapShot
  decSharePlusCBOR :: forall s. StateT (Share SetSnapShot) (Decoder s) SetSnapShot
decSharePlusCBOR = Text
-> (SetSnapShot -> Int)
-> StateT (Share SetSnapShot) (Decoder s) SetSnapShot
-> StateT (Share SetSnapShot) (Decoder s) SetSnapShot
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"SetSnapShot" (Int -> SetSnapShot -> Int
forall a b. a -> b -> a
const Int
2) (StateT (Share SetSnapShot) (Decoder s) SetSnapShot
 -> StateT (Share SetSnapShot) (Decoder s) SetSnapShot)
-> StateT (Share SetSnapShot) (Decoder s) SetSnapShot
-> StateT (Share SetSnapShot) (Decoder s) SetSnapShot
forall a b. (a -> b) -> a -> b
$ do
    snapShot <- StateT
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Decoder s)
  SnapShot
StateT (Share SnapShot) (Decoder s) SnapShot
forall s. StateT (Share SnapShot) (Decoder s) SnapShot
forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    committee <- lift decCBOR
    pure $
      SetSnapShot
        { ssSnapShot = snapShot
        , ssPoolDistr = calculatePoolDistr snapShot
        , ssLeiosCommittee = committee
        }

instance ToKeyValuePairs SetSnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => SetSnapShot -> [kv]
toKeyValuePairs ss :: SetSnapShot
ss@(SetSnapShot SnapShot
_ PoolDistr
_ LeiosCommittee
_) =
    let SetSnapShot {LeiosCommittee
PoolDistr
SnapShot
ssSnapShot :: SetSnapShot -> SnapShot
ssPoolDistr :: SetSnapShot -> PoolDistr
ssLeiosCommittee :: SetSnapShot -> LeiosCommittee
ssSnapShot :: SnapShot
ssPoolDistr :: PoolDistr
ssLeiosCommittee :: LeiosCommittee
..} = SetSnapShot
ss
     in [ Key
"snapShot" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssSnapShot
        , Key
"leiosCommittee" Key -> Value -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LeiosCommittee -> Value
leiosCommitteeToJSON LeiosCommittee
ssLeiosCommittee
        ]

-- | The oldest snapshot, consumed by the reward calculation.
newtype GoSnapShot = GoSnapShot
  { GoSnapShot -> SnapShot
gsSnapShot :: SnapShot
  }
  deriving (Int -> GoSnapShot -> ShowS
[GoSnapShot] -> ShowS
GoSnapShot -> String
(Int -> GoSnapShot -> ShowS)
-> (GoSnapShot -> String)
-> ([GoSnapShot] -> ShowS)
-> Show GoSnapShot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GoSnapShot -> ShowS
showsPrec :: Int -> GoSnapShot -> ShowS
$cshow :: GoSnapShot -> String
show :: GoSnapShot -> String
$cshowList :: [GoSnapShot] -> ShowS
showList :: [GoSnapShot] -> ShowS
Show, GoSnapShot -> GoSnapShot -> Bool
(GoSnapShot -> GoSnapShot -> Bool)
-> (GoSnapShot -> GoSnapShot -> Bool) -> Eq GoSnapShot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GoSnapShot -> GoSnapShot -> Bool
== :: GoSnapShot -> GoSnapShot -> Bool
$c/= :: GoSnapShot -> GoSnapShot -> Bool
/= :: GoSnapShot -> GoSnapShot -> Bool
Eq, (forall x. GoSnapShot -> Rep GoSnapShot x)
-> (forall x. Rep GoSnapShot x -> GoSnapShot) -> Generic GoSnapShot
forall x. Rep GoSnapShot x -> GoSnapShot
forall x. GoSnapShot -> Rep GoSnapShot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GoSnapShot -> Rep GoSnapShot x
from :: forall x. GoSnapShot -> Rep GoSnapShot x
$cto :: forall x. Rep GoSnapShot x -> GoSnapShot
to :: forall x. Rep GoSnapShot x -> GoSnapShot
Generic)
  deriving ([GoSnapShot] -> Value
[GoSnapShot] -> Encoding
GoSnapShot -> Bool
GoSnapShot -> Value
GoSnapShot -> Encoding
(GoSnapShot -> Value)
-> (GoSnapShot -> Encoding)
-> ([GoSnapShot] -> Value)
-> ([GoSnapShot] -> Encoding)
-> (GoSnapShot -> Bool)
-> ToJSON GoSnapShot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: GoSnapShot -> Value
toJSON :: GoSnapShot -> Value
$ctoEncoding :: GoSnapShot -> Encoding
toEncoding :: GoSnapShot -> Encoding
$ctoJSONList :: [GoSnapShot] -> Value
toJSONList :: [GoSnapShot] -> Value
$ctoEncodingList :: [GoSnapShot] -> Encoding
toEncodingList :: [GoSnapShot] -> Encoding
$comitField :: GoSnapShot -> Bool
omitField :: GoSnapShot -> Bool
ToJSON) via KeyValuePairs GoSnapShot

instance NFData GoSnapShot

instance NoThunks GoSnapShot

instance EncCBOR GoSnapShot where
  encCBOR :: GoSnapShot -> Encoding
encCBOR gs :: GoSnapShot
gs@(GoSnapShot SnapShot
_) =
    let GoSnapShot {SnapShot
gsSnapShot :: GoSnapShot -> SnapShot
gsSnapShot :: SnapShot
..} = GoSnapShot
gs
     in Word -> Encoding
encodeListLen Word
1
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot
gsSnapShot

instance DecShareCBOR GoSnapShot where
  type Share GoSnapShot = Share SnapShot
  decSharePlusCBOR :: forall s. StateT (Share GoSnapShot) (Decoder s) GoSnapShot
decSharePlusCBOR = Text
-> (GoSnapShot -> Int)
-> StateT (Share GoSnapShot) (Decoder s) GoSnapShot
-> StateT (Share GoSnapShot) (Decoder s) GoSnapShot
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"GoSnapShot" (Int -> GoSnapShot -> Int
forall a b. a -> b -> a
const Int
1) (StateT (Share GoSnapShot) (Decoder s) GoSnapShot
 -> StateT (Share GoSnapShot) (Decoder s) GoSnapShot)
-> StateT (Share GoSnapShot) (Decoder s) GoSnapShot
-> StateT (Share GoSnapShot) (Decoder s) GoSnapShot
forall a b. (a -> b) -> a -> b
$ do
    gsSnapShot <- StateT
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Decoder s)
  SnapShot
StateT (Share SnapShot) (Decoder s) SnapShot
forall s. StateT (Share SnapShot) (Decoder s) SnapShot
forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    pure GoSnapShot {gsSnapShot}

instance ToKeyValuePairs GoSnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => GoSnapShot -> [kv]
toKeyValuePairs gs :: GoSnapShot
gs@(GoSnapShot SnapShot
_) =
    let GoSnapShot {SnapShot
gsSnapShot :: GoSnapShot -> SnapShot
gsSnapShot :: SnapShot
..} = GoSnapShot
gs
     in [Key
"snapShot" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
gsSnapShot]

-- | Rotate a mark snapshot into the set position. This also computes the pool
-- distribution and selects the Leios committee using the mark snapshot and a
-- passed maxKeyAge.
mkSetSnapShot ::
  -- | The mark snapshot of which the 'PoolDistr' and 'LeiosCommittee' will be
  -- computed and forced into the SetSnapShot.
  MarkSnapShot ->
  -- | Max key age for the leios committee.
  EpochInterval ->
  SetSnapShot
mkSetSnapShot :: MarkSnapShot -> EpochInterval -> SetSnapShot
mkSetSnapShot MarkSnapShot {SnapShot
msSnapShot :: MarkSnapShot -> SnapShot
msSnapShot :: SnapShot
msSnapShot, EpochNo
msEpochNo :: MarkSnapShot -> EpochNo
msEpochNo :: EpochNo
msEpochNo, Word16
msLeiosCommitteeSize :: MarkSnapShot -> Word16
msLeiosCommitteeSize :: Word16
msLeiosCommitteeSize} EpochInterval
maxKeyAge =
  SetSnapShot
    { ssSnapShot :: SnapShot
ssSnapShot = SnapShot
msSnapShot
    , ssPoolDistr :: PoolDistr
ssPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
msSnapShot
    , ssLeiosCommittee :: LeiosCommittee
ssLeiosCommittee =
        EpochNo
-> EpochInterval
-> Word16
-> Vector LeiosCandidate
-> LeiosCommittee
selectLeiosCommittee
          (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
msEpochNo (Word32 -> EpochInterval
EpochInterval Word32
1))
          EpochInterval
maxKeyAge
          Word16
msLeiosCommitteeSize
          (VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> Vector LeiosCandidate
leiosCandidates (SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot SnapShot
msSnapShot))
    }

-- | Rotate a set snapshot into the go position.
mkGoSnapShot :: SetSnapShot -> GoSnapShot
mkGoSnapShot :: SetSnapShot -> GoSnapShot
mkGoSnapShot SetSnapShot {SnapShot
ssSnapShot :: SetSnapShot -> SnapShot
ssSnapShot :: SnapShot
ssSnapShot} =
  GoSnapShot {gsSnapShot :: SnapShot
gsSnapShot = SnapShot
ssSnapShot}

-- | Snapshots of the stake distribution.
--
-- Note that ssStakeMark and ssStakeMarkPoolDistr are lazy on
-- purpose since we only want to force the thunk after one stability window
-- when we know that they are stable (so that we do not compute them if we do not have to).
-- See more info in the [Optimize TICKF ADR](https://github.com/intersectmbo/cardano-ledger/blob/master/docs/adr/2022-12-12_007-optimize-ledger-view.md)
data SnapShots era = SnapShots
  { forall era. SnapShots era -> MarkSnapShot
ssStakeMark :: !MarkSnapShot
  , forall era. SnapShots era -> PoolDistr
ssStakeMarkPoolDistr :: PoolDistr -- Lazy on purpose
  , forall era. SnapShots era -> SetSnapShot
ssStakeSet :: !SetSnapShot
  , forall era. SnapShots era -> GoSnapShot
ssStakeGo :: !GoSnapShot
  , forall era. SnapShots era -> Coin
ssFee :: !Coin
  }
  deriving (Int -> SnapShots era -> ShowS
[SnapShots era] -> ShowS
SnapShots era -> String
(Int -> SnapShots era -> ShowS)
-> (SnapShots era -> String)
-> ([SnapShots era] -> ShowS)
-> Show (SnapShots era)
forall era. Int -> SnapShots era -> ShowS
forall era. [SnapShots era] -> ShowS
forall era. SnapShots era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> SnapShots era -> ShowS
showsPrec :: Int -> SnapShots era -> ShowS
$cshow :: forall era. SnapShots era -> String
show :: SnapShots era -> String
$cshowList :: forall era. [SnapShots era] -> ShowS
showList :: [SnapShots era] -> ShowS
Show, SnapShots era -> SnapShots era -> Bool
(SnapShots era -> SnapShots era -> Bool)
-> (SnapShots era -> SnapShots era -> Bool) -> Eq (SnapShots era)
forall era. SnapShots era -> SnapShots era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. SnapShots era -> SnapShots era -> Bool
== :: SnapShots era -> SnapShots era -> Bool
$c/= :: forall era. SnapShots era -> SnapShots era -> Bool
/= :: SnapShots era -> SnapShots era -> Bool
Eq, (forall x. SnapShots era -> Rep (SnapShots era) x)
-> (forall x. Rep (SnapShots era) x -> SnapShots era)
-> Generic (SnapShots era)
forall x. Rep (SnapShots era) x -> SnapShots era
forall x. SnapShots era -> Rep (SnapShots era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (SnapShots era) x -> SnapShots era
forall era x. SnapShots era -> Rep (SnapShots era) x
$cfrom :: forall era x. SnapShots era -> Rep (SnapShots era) x
from :: forall x. SnapShots era -> Rep (SnapShots era) x
$cto :: forall era x. Rep (SnapShots era) x -> SnapShots era
to :: forall x. Rep (SnapShots era) x -> SnapShots era
Generic)
  deriving ([SnapShots era] -> Value
[SnapShots era] -> Encoding
SnapShots era -> Bool
SnapShots era -> Value
SnapShots era -> Encoding
(SnapShots era -> Value)
-> (SnapShots era -> Encoding)
-> ([SnapShots era] -> Value)
-> ([SnapShots era] -> Encoding)
-> (SnapShots era -> Bool)
-> ToJSON (SnapShots era)
forall era. [SnapShots era] -> Value
forall era. [SnapShots era] -> Encoding
forall era. SnapShots era -> Bool
forall era. SnapShots era -> Value
forall era. SnapShots era -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall era. SnapShots era -> Value
toJSON :: SnapShots era -> Value
$ctoEncoding :: forall era. SnapShots era -> Encoding
toEncoding :: SnapShots era -> Encoding
$ctoJSONList :: forall era. [SnapShots era] -> Value
toJSONList :: [SnapShots era] -> Value
$ctoEncodingList :: forall era. [SnapShots era] -> Encoding
toEncodingList :: [SnapShots era] -> Encoding
$comitField :: forall era. SnapShots era -> Bool
omitField :: SnapShots era -> Bool
ToJSON) via KeyValuePairs (SnapShots era)
  -- TODO: switch `AllowThunksIn` to `OnlyCheckWhnfNamed`
  deriving (Context -> SnapShots era -> IO (Maybe ThunkInfo)
Proxy (SnapShots era) -> String
(Context -> SnapShots era -> IO (Maybe ThunkInfo))
-> (Context -> SnapShots era -> IO (Maybe ThunkInfo))
-> (Proxy (SnapShots era) -> String)
-> NoThunks (SnapShots era)
forall era.
Typeable era =>
Context -> SnapShots era -> IO (Maybe ThunkInfo)
forall era. Typeable era => Proxy (SnapShots era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall era.
Typeable era =>
Context -> SnapShots era -> IO (Maybe ThunkInfo)
noThunks :: Context -> SnapShots era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Typeable era =>
Context -> SnapShots era -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SnapShots era -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall era. Typeable era => Proxy (SnapShots era) -> String
showTypeOf :: Proxy (SnapShots era) -> String
NoThunks) via AllowThunksIn '["ssStakeMark", "ssStakeMarkPoolDistr"] (SnapShots era)

instance NFData (SnapShots era)

instance EncCBOR (SnapShots era) where
  encCBOR :: SnapShots era -> Encoding
encCBOR (SnapShots {MarkSnapShot
ssStakeMark :: forall era. SnapShots era -> MarkSnapShot
ssStakeMark :: MarkSnapShot
ssStakeMark, SetSnapShot
ssStakeSet :: forall era. SnapShots era -> SetSnapShot
ssStakeSet :: SetSnapShot
ssStakeSet, GoSnapShot
ssStakeGo :: forall era. SnapShots era -> GoSnapShot
ssStakeGo :: GoSnapShot
ssStakeGo, Coin
ssFee :: forall era. SnapShots era -> Coin
ssFee :: Coin
ssFee}) =
    Word -> Encoding
encodeListLen Word
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> MarkSnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR MarkSnapShot
ssStakeMark
      -- We intentionaly do not serialize the redundant ssStakeMarkPoolDistr
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SetSnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SetSnapShot
ssStakeSet
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> GoSnapShot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR GoSnapShot
ssStakeGo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
ssFee

instance Era era => DecCBOR (SnapShots era) where
  decCBOR :: forall s. Decoder s (SnapShots era)
decCBOR = Decoder s (SnapShots era)
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

instance DecShareCBOR (SnapShots era) where
  type Share (SnapShots era) = Share SnapShot
  decSharePlusCBOR :: forall s.
StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
decSharePlusCBOR = Text
-> (SnapShots era -> Int)
-> StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
-> StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"SnapShots" (Int -> SnapShots era -> Int
forall a b. a -> b -> a
const Int
4) (StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
 -> StateT (Share (SnapShots era)) (Decoder s) (SnapShots era))
-> StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
-> StateT (Share (SnapShots era)) (Decoder s) (SnapShots era)
forall a b. (a -> b) -> a -> b
$ do
    !ssStakeMark <- StateT
  (Interns (Credential Staking), Interns (KeyHash StakePool))
  (Decoder s)
  MarkSnapShot
StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
forall s. StateT (Share MarkSnapShot) (Decoder s) MarkSnapShot
forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    ssStakeSet <- decSharePlusCBOR
    ssStakeGo <- decSharePlusCBOR
    ssFee <- lift decCBOR
    let ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr (MarkSnapShot -> SnapShot
msSnapShot MarkSnapShot
ssStakeMark)
    pure SnapShots {ssStakeMark, ssStakeMarkPoolDistr, ssStakeSet, ssStakeGo, ssFee}

instance Default (SnapShots era) where
  def :: SnapShots era
def = SnapShots era
forall era. SnapShots era
emptySnapShots

instance ToKeyValuePairs (SnapShots era) where
  toKeyValuePairs :: forall e kv. KeyValue e kv => SnapShots era -> [kv]
toKeyValuePairs ss :: SnapShots era
ss@(SnapShots !MarkSnapShot
_ PoolDistr
_ SetSnapShot
_ GoSnapShot
_ Coin
_) =
    -- ssStakeMarkPoolDistr is omitted on purpose
    let SnapShots {MarkSnapShot
ssStakeMark :: forall era. SnapShots era -> MarkSnapShot
ssStakeMark :: MarkSnapShot
ssStakeMark, SetSnapShot
ssStakeSet :: forall era. SnapShots era -> SetSnapShot
ssStakeSet :: SetSnapShot
ssStakeSet, GoSnapShot
ssStakeGo :: forall era. SnapShots era -> GoSnapShot
ssStakeGo :: GoSnapShot
ssStakeGo, Coin
ssFee :: forall era. SnapShots era -> Coin
ssFee :: Coin
ssFee} = SnapShots era
ss
     in [ Key
"pstakeMark" Key -> MarkSnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MarkSnapShot
ssStakeMark
        , Key
"pstakeSet" Key -> SetSnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SetSnapShot
ssStakeSet
        , Key
"pstakeGo" Key -> GoSnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GoSnapShot
ssStakeGo
        , Key
"feeSS" Key -> Coin -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
ssFee
        ]

emptySnapShot :: SnapShot
emptySnapShot :: SnapShot
emptySnapShot = ActiveStake
-> NonZero Coin
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> SnapShot
SnapShot (VMap VB VS (Credential Staking) StakeWithDelegation -> ActiveStake
ActiveStake VMap VB VS (Credential Staking) StakeWithDelegation
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty) (forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1) VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall a. Monoid a => a
mempty

emptySnapShots :: SnapShots era
emptySnapShots :: forall era. SnapShots era
emptySnapShots =
  MarkSnapShot
-> PoolDistr -> SetSnapShot -> GoSnapShot -> Coin -> SnapShots era
forall era.
MarkSnapShot
-> PoolDistr -> SetSnapShot -> GoSnapShot -> Coin -> SnapShots era
SnapShots MarkSnapShot
emptyMark (SnapShot -> PoolDistr
calculatePoolDistr SnapShot
emptySnapShot) SetSnapShot
emptySet GoSnapShot
emptyGo (Integer -> Coin
Coin Integer
0)
  where
    emptyMark :: MarkSnapShot
emptyMark = SnapShot -> EpochNo -> Word16 -> MarkSnapShot
MarkSnapShot SnapShot
emptySnapShot (Word64 -> EpochNo
EpochNo Word64
0) Word16
0
    emptySet :: SetSnapShot
emptySet = MarkSnapShot -> EpochInterval -> SetSnapShot
mkSetSnapShot MarkSnapShot
emptyMark (Word32 -> EpochInterval
EpochInterval Word32
0)
    emptyGo :: GoSnapShot
emptyGo = SetSnapShot -> GoSnapShot
mkGoSnapShot SetSnapShot
emptySet

mkSnapShot ::
  ActiveStake ->
  VMap VB VB (KeyHash StakePool) StakePoolSnapShot ->
  SnapShot
mkSnapShot :: ActiveStake
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot -> SnapShot
mkSnapShot ActiveStake
ssActiveStake VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot =
  let ssTotalActiveStake :: NonZero Coin
ssTotalActiveStake = ActiveStake -> NonZero Coin
sumAllActiveStake ActiveStake
ssActiveStake
   in SnapShot {ActiveStake
ssActiveStake :: ActiveStake
ssActiveStake :: ActiveStake
ssActiveStake, NonZero Coin
ssTotalActiveStake :: NonZero Coin
ssTotalActiveStake :: NonZero Coin
ssTotalActiveStake, VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot}
{-# INLINE mkSnapShot #-}

-- | Project each stake pool in a snapshot to its standing for Leios committee
-- selection (CIP-0164). 'selectLeiosCommittee' ranks and seats these.
leiosCandidates ::
  VMap VB VB (KeyHash StakePool) StakePoolSnapShot -> V.Vector LeiosCandidate
leiosCandidates :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> Vector LeiosCandidate
leiosCandidates = ((KeyHash StakePool, StakePoolSnapShot) -> LeiosCandidate)
-> Vector (KeyHash StakePool, StakePoolSnapShot)
-> Vector LeiosCandidate
forall a b. (a -> b) -> Vector a -> Vector b
V.map ((KeyHash StakePool -> StakePoolSnapShot -> LeiosCandidate)
-> (KeyHash StakePool, StakePoolSnapShot) -> LeiosCandidate
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyHash StakePool -> StakePoolSnapShot -> LeiosCandidate
toCandidate) (Vector (KeyHash StakePool, StakePoolSnapShot)
 -> Vector LeiosCandidate)
-> (VMap VB VB (KeyHash StakePool) StakePoolSnapShot
    -> Vector (KeyHash StakePool, StakePoolSnapShot))
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> Vector LeiosCandidate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KVVector VB VB (KeyHash StakePool, StakePoolSnapShot)
-> Vector (KeyHash StakePool, StakePoolSnapShot)
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
VG.convert (KVVector VB VB (KeyHash StakePool, StakePoolSnapShot)
 -> Vector (KeyHash StakePool, StakePoolSnapShot))
-> (VMap VB VB (KeyHash StakePool) StakePoolSnapShot
    -> KVVector VB VB (KeyHash StakePool, StakePoolSnapShot))
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> Vector (KeyHash StakePool, StakePoolSnapShot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> KVVector VB VB (KeyHash StakePool, StakePoolSnapShot)
forall (kv :: * -> *) (vv :: * -> *) k v.
VMap kv vv k v -> KVVector kv vv (k, v)
unVMap
  where
    toCandidate :: KeyHash StakePool -> StakePoolSnapShot -> LeiosCandidate
toCandidate KeyHash StakePool
poolId StakePoolSnapShot
spss =
      KeyHash StakePool
-> CompactForm Coin
-> Rational
-> StrictMaybe BlsKeyState
-> LeiosCandidate
LeiosCandidate KeyHash StakePool
poolId (StakePoolSnapShot -> CompactForm Coin
spssStake StakePoolSnapShot
spss) (StakePoolSnapShot -> Rational
spssStakeRatio StakePoolSnapShot
spss) (StakePoolSnapShot -> StrictMaybe BlsKeyState
spssBlsKey StakePoolSnapShot
spss)

-- | Given stake pools state and SnapShot completely overwrite the StakePoolsSnapShot
resetStakePoolsSnapShot ::
  VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) StakePoolState ->
  SnapShot ->
  SnapShot
resetStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolState
-> SnapShot -> SnapShot
resetStakePoolsSnapShot VMap VB VB (KeyHash StakePool) StakePoolState
stakePoolsState ss :: SnapShot
ss@SnapShot {VMap VB VB (KeyHash StakePool) StakePoolSnapShot
NonZero Coin
ActiveStake
ssTotalActiveStake :: SnapShot -> NonZero Coin
ssActiveStake :: SnapShot -> ActiveStake
ssStakePoolsSnapShot :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssActiveStake :: ActiveStake
ssTotalActiveStake :: NonZero Coin
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
..} =
  SnapShot
ss
    { ssStakePoolsSnapShot =
        VMap.map (mkStakePoolSnapShot ssActiveStake ssTotalActiveStake) stakePoolsState
    }
{-# INLINE resetStakePoolsSnapShot #-}

snapShotFromInstantStake ::
  forall era.
  EraStake era =>
  InstantStake era ->
  DState era ->
  PState era ->
  SnapShot
snapShotFromInstantStake :: forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake DState era
dState PState {Map (KeyHash StakePool) StakePoolState
psStakePools :: Map (KeyHash StakePool) StakePoolState
psStakePools :: forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools} =
  VMap VB VB (KeyHash StakePool) StakePoolState
-> SnapShot -> SnapShot
resetStakePoolsSnapShot (Map (KeyHash StakePool) StakePoolState
-> VMap VB VB (KeyHash StakePool) StakePoolState
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (KeyHash StakePool) StakePoolState
psStakePools) (SnapShot -> SnapShot) -> SnapShot -> SnapShot
forall a b. (a -> b) -> a -> b
$
    ActiveStake
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot -> SnapShot
mkSnapShot ActiveStake
activeStake VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty
  where
    activeStake :: ActiveStake
activeStake = InstantStake era -> Accounts era -> ActiveStake
forall era.
EraStake era =>
InstantStake era -> Accounts era -> ActiveStake
resolveInstantStake InstantStake era
instantStake (Accounts era -> ActiveStake) -> Accounts era -> ActiveStake
forall a b. (a -> b) -> a -> b
$ DState era -> Accounts era
forall era. DState era -> Accounts era
dsAccounts DState era
dState
{-# INLINE snapShotFromInstantStake #-}

-- =======================================

-- | Sum up the Coin (as CompactForm Coin = Word64) for each StakePool
calculatePoolStake ::
  (KeyHash StakePool -> Bool) ->
  ActiveStake ->
  Map.Map (KeyHash StakePool) (CompactForm Coin)
calculatePoolStake :: (KeyHash StakePool -> Bool)
-> ActiveStake -> Map (KeyHash StakePool) (CompactForm Coin)
calculatePoolStake KeyHash StakePool -> Bool
includeHash (ActiveStake VMap VB VS (Credential Staking) StakeWithDelegation
m) = (Map (KeyHash StakePool) (CompactForm Coin)
 -> Credential Staking
 -> StakeWithDelegation
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> Map (KeyHash StakePool) (CompactForm Coin)
-> VMap VB VS (Credential Staking) StakeWithDelegation
-> Map (KeyHash StakePool) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v a.
(Vector kv k, Vector vv v) =>
(a -> k -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldlWithKey Map (KeyHash StakePool) (CompactForm Coin)
-> Credential Staking
-> StakeWithDelegation
-> Map (KeyHash StakePool) (CompactForm Coin)
accum Map (KeyHash StakePool) (CompactForm Coin)
forall k a. Map k a
Map.empty VMap VB VS (Credential Staking) StakeWithDelegation
m
  where
    accum :: Map (KeyHash StakePool) (CompactForm Coin)
-> Credential Staking
-> StakeWithDelegation
-> Map (KeyHash StakePool) (CompactForm Coin)
accum Map (KeyHash StakePool) (CompactForm Coin)
ans Credential Staking
_cred StakeWithDelegation
swd =
      if KeyHash StakePool -> Bool
includeHash (KeyHash StakePool -> Bool) -> KeyHash StakePool -> Bool
forall a b. (a -> b) -> a -> b
$ StakeWithDelegation -> KeyHash StakePool
swdDelegation StakeWithDelegation
swd
        then (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> KeyHash StakePool
-> CompactForm Coin
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) (StakeWithDelegation -> KeyHash StakePool
swdDelegation StakeWithDelegation
swd) (NonZero (CompactForm Coin) -> CompactForm Coin
forall a. NonZero a -> a
unNonZero (NonZero (CompactForm Coin) -> CompactForm Coin)
-> NonZero (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ StakeWithDelegation -> NonZero (CompactForm Coin)
swdStake StakeWithDelegation
swd) Map (KeyHash StakePool) (CompactForm Coin)
ans
        else Map (KeyHash StakePool) (CompactForm Coin)
ans

calculatePoolDistr :: SnapShot -> PoolDistr
calculatePoolDistr :: SnapShot -> PoolDistr
calculatePoolDistr = (KeyHash StakePool -> Bool) -> SnapShot -> PoolDistr
calculatePoolDistr' (Bool -> KeyHash StakePool -> Bool
forall a b. a -> b -> a
const Bool
True)

calculatePoolDistr' :: (KeyHash StakePool -> Bool) -> SnapShot -> PoolDistr
calculatePoolDistr' :: (KeyHash StakePool -> Bool) -> SnapShot -> PoolDistr
calculatePoolDistr' KeyHash StakePool -> Bool
includeHash (SnapShot ActiveStake
_ NonZero Coin
activeStake VMap VB VB (KeyHash StakePool) StakePoolSnapShot
stakePoolSnapShot) =
  let toIndividualPoolStake :: KeyHash StakePool -> StakePoolSnapShot -> Maybe IndividualPoolStake
toIndividualPoolStake KeyHash StakePool
poolId StakePoolSnapShot
spss = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (KeyHash StakePool -> Bool
includeHash KeyHash StakePool
poolId)
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (StakePoolSnapShot -> Int
spssNumDelegators StakePoolSnapShot
spss Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
        IndividualPoolStake -> Maybe IndividualPoolStake
forall a. a -> Maybe a
Just
          IndividualPoolStake
            { individualPoolStake :: Rational
individualPoolStake = StakePoolSnapShot -> Rational
spssStakeRatio StakePoolSnapShot
spss
            , individualTotalPoolStake :: CompactForm Coin
individualTotalPoolStake = StakePoolSnapShot -> CompactForm Coin
spssStake StakePoolSnapShot
spss
            , individualPoolStakeVrf :: VRFVerKeyHash StakePoolVRF
individualPoolStakeVrf = StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssVrf StakePoolSnapShot
spss
            , individualPoolStakeBls :: StrictMaybe BlsKey
individualPoolStakeBls = BlsKeyState -> BlsKey
bksKey (BlsKeyState -> BlsKey)
-> StrictMaybe BlsKeyState -> StrictMaybe BlsKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StakePoolSnapShot -> StrictMaybe BlsKeyState
spssBlsKey StakePoolSnapShot
spss
            }
      poolDistr :: PoolDistr
poolDistr =
        PoolDistr
          { unPoolDistr :: Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr = VMap VB VB (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash StakePool) IndividualPoolStake
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (VMap VB VB (KeyHash StakePool) IndividualPoolStake
 -> Map (KeyHash StakePool) IndividualPoolStake)
-> VMap VB VB (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash StakePool) IndividualPoolStake
forall a b. (a -> b) -> a -> b
$ (KeyHash StakePool
 -> StakePoolSnapShot -> Maybe IndividualPoolStake)
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> VMap VB VB (KeyHash StakePool) IndividualPoolStake
forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(k -> a -> Maybe b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapMaybeWithKey KeyHash StakePool -> StakePoolSnapShot -> Maybe IndividualPoolStake
toIndividualPoolStake VMap VB VB (KeyHash StakePool) StakePoolSnapShot
stakePoolSnapShot
          , pdTotalActiveStake :: NonZero Coin
pdTotalActiveStake = NonZero Coin
activeStake
          }
   in PoolDistr
poolDistr

-- ======================================================
-- Lenses
-- ===============================================

-- SnapShots

ssStakeMarkL :: Lens' (SnapShots era) MarkSnapShot
ssStakeMarkL :: forall era (f :: * -> *).
Functor f =>
(MarkSnapShot -> f MarkSnapShot)
-> SnapShots era -> f (SnapShots era)
ssStakeMarkL = (SnapShots era -> MarkSnapShot)
-> (SnapShots era -> MarkSnapShot -> SnapShots era)
-> Lens (SnapShots era) (SnapShots era) MarkSnapShot MarkSnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots era -> MarkSnapShot
forall era. SnapShots era -> MarkSnapShot
ssStakeMark (\SnapShots era
ds MarkSnapShot
u -> SnapShots era
ds {ssStakeMark = u})

ssStakeMarkPoolDistrL :: Lens' (SnapShots era) PoolDistr
ssStakeMarkPoolDistrL :: forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr) -> SnapShots era -> f (SnapShots era)
ssStakeMarkPoolDistrL = (SnapShots era -> PoolDistr)
-> (SnapShots era -> PoolDistr -> SnapShots era)
-> Lens (SnapShots era) (SnapShots era) PoolDistr PoolDistr
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots era -> PoolDistr
forall era. SnapShots era -> PoolDistr
ssStakeMarkPoolDistr (\SnapShots era
ds PoolDistr
u -> SnapShots era
ds {ssStakeMarkPoolDistr = u})

ssStakeSetL :: Lens' (SnapShots era) SetSnapShot
ssStakeSetL :: forall era (f :: * -> *).
Functor f =>
(SetSnapShot -> f SetSnapShot)
-> SnapShots era -> f (SnapShots era)
ssStakeSetL = (SnapShots era -> SetSnapShot)
-> (SnapShots era -> SetSnapShot -> SnapShots era)
-> Lens (SnapShots era) (SnapShots era) SetSnapShot SetSnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots era -> SetSnapShot
forall era. SnapShots era -> SetSnapShot
ssStakeSet (\SnapShots era
ds SetSnapShot
u -> SnapShots era
ds {ssStakeSet = u})

ssStakeGoL :: Lens' (SnapShots era) GoSnapShot
ssStakeGoL :: forall era (f :: * -> *).
Functor f =>
(GoSnapShot -> f GoSnapShot) -> SnapShots era -> f (SnapShots era)
ssStakeGoL = (SnapShots era -> GoSnapShot)
-> (SnapShots era -> GoSnapShot -> SnapShots era)
-> Lens (SnapShots era) (SnapShots era) GoSnapShot GoSnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots era -> GoSnapShot
forall era. SnapShots era -> GoSnapShot
ssStakeGo (\SnapShots era
ds GoSnapShot
u -> SnapShots era
ds {ssStakeGo = u})

ssFeeL :: Lens' (SnapShots era) Coin
ssFeeL :: forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> SnapShots era -> f (SnapShots era)
ssFeeL = (SnapShots era -> Coin)
-> (SnapShots era -> Coin -> SnapShots era)
-> Lens (SnapShots era) (SnapShots era) Coin Coin
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots era -> Coin
forall era. SnapShots era -> Coin
ssFee (\SnapShots era
ds Coin
u -> SnapShots era
ds {ssFee = u})

-- MarkSnapShot / SetSnapShot / GoSnapShot

msSnapShotL :: Lens' MarkSnapShot SnapShot
msSnapShotL :: Lens' MarkSnapShot SnapShot
msSnapShotL = (MarkSnapShot -> SnapShot)
-> (MarkSnapShot -> SnapShot -> MarkSnapShot)
-> Lens' MarkSnapShot SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MarkSnapShot -> SnapShot
msSnapShot (\MarkSnapShot
ms SnapShot
u -> MarkSnapShot
ms {msSnapShot = u})

ssSnapShotL :: Lens' SetSnapShot SnapShot
ssSnapShotL :: Lens' SetSnapShot SnapShot
ssSnapShotL = (SetSnapShot -> SnapShot)
-> (SetSnapShot -> SnapShot -> SetSnapShot)
-> Lens' SetSnapShot SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SetSnapShot -> SnapShot
ssSnapShot (\SetSnapShot
ss SnapShot
u -> SetSnapShot
ss {ssSnapShot = u})

ssLeiosCommitteeL :: Lens' SetSnapShot LeiosCommittee
ssLeiosCommitteeL :: Lens' SetSnapShot LeiosCommittee
ssLeiosCommitteeL = (SetSnapShot -> LeiosCommittee)
-> (SetSnapShot -> LeiosCommittee -> SetSnapShot)
-> Lens' SetSnapShot LeiosCommittee
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SetSnapShot -> LeiosCommittee
ssLeiosCommittee (\SetSnapShot
ss LeiosCommittee
u -> SetSnapShot
ss {ssLeiosCommittee = u})

gsSnapShotL :: Lens' GoSnapShot SnapShot
gsSnapShotL :: Lens' GoSnapShot SnapShot
gsSnapShotL = (GoSnapShot -> SnapShot)
-> (GoSnapShot -> SnapShot -> GoSnapShot)
-> Lens' GoSnapShot SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens GoSnapShot -> SnapShot
gsSnapShot (\GoSnapShot
gs SnapShot
u -> GoSnapShot
gs {gsSnapShot = u})

-- SnapShot

ssActiveStakeL :: Lens' SnapShot ActiveStake
ssActiveStakeL :: Lens' SnapShot ActiveStake
ssActiveStakeL = (SnapShot -> ActiveStake)
-> (SnapShot -> ActiveStake -> SnapShot)
-> Lens' SnapShot ActiveStake
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> ActiveStake
ssActiveStake (\SnapShot
ds ActiveStake
u -> SnapShot
ds {ssActiveStake = u})

ssStake :: SnapShot -> ActiveStake
ssStake :: SnapShot -> ActiveStake
ssStake = SnapShot -> ActiveStake
ssActiveStake
{-# DEPRECATED ssStake "In favor of `ssActiveStake`" #-}

ssStakeL :: Lens' SnapShot ActiveStake
ssStakeL :: Lens' SnapShot ActiveStake
ssStakeL = (SnapShot -> ActiveStake)
-> (SnapShot -> ActiveStake -> SnapShot)
-> Lens' SnapShot ActiveStake
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> ActiveStake
ssActiveStake (\SnapShot
ds ActiveStake
u -> SnapShot
ds {ssActiveStake = u})
{-# DEPRECATED ssStakeL "In favor of `ssActiveStakeL`" #-}