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

module Cardano.Ledger.State.SnapShots (
  sumStakePerPool,
  StakePoolSnapShot (..),
  mkStakePoolSnapShot,
  SnapShot (..),
  SnapShots (..),
  emptySnapShot,
  emptySnapShots,
  snapShotFromInstantStake,
  maxPool,
  maxPool',
  calculatePoolDistr,
  calculatePoolDistr',
  calculatePoolStake,
  ssStakeMarkL,
  ssStakeMarkPoolDistrL,
  ssStakeSetL,
  ssStakeGoL,
  ssFeeL,
  ssStakeL,
  ssStakeDistrL,
  ssDelegationsL,
  ssPoolParamsL,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (..),
  KeyValuePairs (..),
  Network,
  NonNegativeInterval,
  NonZero (..),
  ToKeyValuePairs (..),
  UnitInterval,
  knownNonZeroBounded,
  nonZeroOr,
  recipNonZero,
  toIntegerNonZero,
  toRatioNonZero,
  (%.),
  (/.),
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  Interns,
  decNoShareCBOR,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  decodeVMap,
  encodeListLen,
  toMemptyLens,
 )
import Cardano.Ledger.Binary.Decoding (interns)
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm (..),
  coinToRational,
  fromCompactCoinNonZero,
  knownNonZeroCoin,
  knownNonZeroCompactCoin,
  rationalToCoinViaFloor,
  unCoinNonZero,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), credKeyHash)
import Cardano.Ledger.State.Account
import Cardano.Ledger.State.CertState (DState (..), PState (..))
import Cardano.Ledger.State.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.State.Stake
import Cardano.Ledger.State.StakePool (
  StakePoolParams (sppVrf),
  StakePoolState (..),
  stakePoolStateToStakePoolParams,
 )
import Cardano.Ledger.Val ((<+>))
import Control.DeepSeq (NFData)
import Control.Exception (assert)
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, VP)
import qualified Data.VMap as VMap
import Data.Word (Word16)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro (Lens', lens, (^.), _1, _2)
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 ->
  Coin
maxPool' :: NonNegativeInterval
-> NonZero Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
a0 NonZero Word16
nOpt Coin
r Rational
sigma Rational
pR = 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
    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` and `ppNOptL` 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 -> Coin
maxPool' NonNegativeInterval
a0 NonZero Word16
nOpt Coin
r Rational
sigma Rational
pR
  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

-- | 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 -> 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 -> Credential Staking
spssAccountId :: !(Credential Staking)
  -- ^ 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
  Stake ->
  -- | Total Active Stake
  NonZero Coin ->
  -- | Stake Pool State
  StakePoolState ->
  StakePoolSnapShot
mkStakePoolSnapShot :: Stake -> NonZero Coin -> StakePoolState -> StakePoolSnapShot
mkStakePoolSnapShot Stake
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
$
          Stake -> [Credential Staking] -> CompactForm Coin
forall (f :: * -> *).
Foldable f =>
Stake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactStake Stake
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
    , 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 :: Credential Staking
spssAccountId = Credential Staking
spsAccountAddress
    }
  where
    StakePoolState {VRFVerKeyHash StakePoolVRF
spsVrf :: StakePoolState -> VRFVerKeyHash StakePoolVRF
spsVrf :: VRFVerKeyHash StakePoolVRF
spsVrf, Coin
spsPledge :: StakePoolState -> Coin
spsPledge :: Coin
spsPledge, Coin
spsCost :: StakePoolState -> Coin
spsCost :: Coin
spsCost, UnitInterval
spsMargin :: StakePoolState -> UnitInterval
spsMargin :: UnitInterval
spsMargin, Credential Staking
spsAccountAddress :: StakePoolState -> Credential Staking
spsAccountAddress :: Credential Staking
spsAccountAddress, 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 = Stake -> Set (Credential Staking) -> CompactForm Coin
forall (f :: * -> *).
Foldable f =>
Stake -> f (Credential Staking) -> CompactForm Coin
sumCredentialsCompactStake Stake
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
_ Coin
_ Coin
_ UnitInterval
_ Int
_ Credential Staking
_) =
    let StakePoolSnapShot {Int
Rational
Set (KeyHash Staking)
CompactForm Coin
VRFVerKeyHash StakePoolVRF
UnitInterval
Credential Staking
Coin
spssStake :: StakePoolSnapShot -> CompactForm Coin
spssStakeRatio :: StakePoolSnapShot -> Rational
spssSelfDelegatedOwners :: StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: StakePoolSnapShot -> Coin
spssVrf :: StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssPledge :: StakePoolSnapShot -> Coin
spssCost :: StakePoolSnapShot -> Coin
spssMargin :: StakePoolSnapShot -> UnitInterval
spssNumDelegators :: StakePoolSnapShot -> Int
spssAccountId :: StakePoolSnapShot -> Credential Staking
spssStake :: CompactForm Coin
spssStakeRatio :: Rational
spssSelfDelegatedOwners :: Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: Coin
spssVrf :: VRFVerKeyHash StakePoolVRF
spssPledge :: Coin
spssCost :: Coin
spssMargin :: UnitInterval
spssNumDelegators :: Int
spssAccountId :: Credential Staking
..} = 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
"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 -> Credential Staking -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Credential Staking
spssAccountId
        ]

instance EncCBOR StakePoolSnapShot where
  encCBOR :: StakePoolSnapShot -> Encoding
encCBOR spss :: StakePoolSnapShot
spss@(StakePoolSnapShot CompactForm Coin
_ Rational
_ Set (KeyHash Staking)
_ Coin
_ VRFVerKeyHash StakePoolVRF
_ Coin
_ Coin
_ UnitInterval
_ Int
_ Credential Staking
_) =
    let StakePoolSnapShot {Int
Rational
Set (KeyHash Staking)
CompactForm Coin
VRFVerKeyHash StakePoolVRF
UnitInterval
Credential Staking
Coin
spssStake :: StakePoolSnapShot -> CompactForm Coin
spssStakeRatio :: StakePoolSnapShot -> Rational
spssSelfDelegatedOwners :: StakePoolSnapShot -> Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: StakePoolSnapShot -> Coin
spssVrf :: StakePoolSnapShot -> VRFVerKeyHash StakePoolVRF
spssPledge :: StakePoolSnapShot -> Coin
spssCost :: StakePoolSnapShot -> Coin
spssMargin :: StakePoolSnapShot -> UnitInterval
spssNumDelegators :: StakePoolSnapShot -> Int
spssAccountId :: StakePoolSnapShot -> Credential Staking
spssStake :: CompactForm Coin
spssStakeRatio :: Rational
spssSelfDelegatedOwners :: Set (KeyHash Staking)
spssSelfDelegatedOwnersStake :: Coin
spssVrf :: VRFVerKeyHash StakePoolVRF
spssPledge :: Coin
spssCost :: Coin
spssMargin :: UnitInterval
spssNumDelegators :: Int
spssAccountId :: Credential Staking
..} = StakePoolSnapShot
spss
     in Word -> Encoding
encodeListLen Word
10
          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
<> 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
<> Credential Staking -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Credential Staking
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
10) (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
    spssPledge <- lift decCBOR
    spssCost <- lift decCBOR
    spssMargin <- lift decCBOR
    spssNumDelegators <- lift decCBOR
    spssAccountId <- interns credInterns <$> lift decCBOR
    pure StakePoolSnapShot {..}

-- | Snapshot of the stake distribution.
data SnapShot = SnapShot
  { SnapShot -> Stake
ssStake :: !Stake -- TODO: rename to `ssActiveStake`

  -- ^ 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 `ssStake`. 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 (Credential Staking) (KeyHash StakePool)
ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool) -- TODO: remove (lazy on purpose)
  , SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams -- TODO: remove (lazy on purpose)
  , 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
  deriving
    (Context -> SnapShot -> IO (Maybe ThunkInfo)
Proxy SnapShot -> String
(Context -> SnapShot -> IO (Maybe ThunkInfo))
-> (Context -> SnapShot -> IO (Maybe ThunkInfo))
-> (Proxy SnapShot -> String)
-> NoThunks SnapShot
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> SnapShot -> IO (Maybe ThunkInfo)
noThunks :: Context -> SnapShot -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SnapShot -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SnapShot -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SnapShot -> String
showTypeOf :: Proxy SnapShot -> String
NoThunks)
    via AllowThunksIn '["ssDelegations", "ssPoolParams"] SnapShot

instance NFData SnapShot

instance EncCBOR SnapShot where
  encCBOR :: SnapShot -> Encoding
encCBOR ss :: SnapShot
ss@(SnapShot Stake
_ NonZero Coin
_ VMap VB VB (Credential Staking) (KeyHash StakePool)
_ VMap VB VB (KeyHash StakePool) StakePoolParams
_ VMap VB VB (KeyHash StakePool) StakePoolSnapShot
_) =
    let SnapShot {VMap VB VB (KeyHash StakePool) StakePoolParams
VMap VB VB (KeyHash StakePool) StakePoolSnapShot
VMap VB VB (Credential Staking) (KeyHash StakePool)
NonZero Coin
Stake
ssTotalActiveStake :: SnapShot -> NonZero Coin
ssStake :: SnapShot -> Stake
ssDelegations :: SnapShot -> VMap VB VB (Credential Staking) (KeyHash StakePool)
ssPoolParams :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams
ssStakePoolsSnapShot :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStake :: Stake
ssTotalActiveStake :: NonZero Coin
ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
..} = SnapShot
ss
     in Word -> Encoding
encodeListLen Word
4
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Stake -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Stake
ssStake
          -- `ssTotalActiveStake` is ommitted on purpose
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VMap VB VB (Credential Staking) (KeyHash StakePool) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VMap VB VB (KeyHash StakePool) StakePoolParams -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams
          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 = Text
-> (SnapShot -> Int)
-> StateT (Share SnapShot) (Decoder s) SnapShot
-> StateT (Share SnapShot) (Decoder s) SnapShot
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"SnapShot" (Int -> SnapShot -> Int
forall a b. a -> b -> a
const Int
4) (StateT (Share SnapShot) (Decoder s) SnapShot
 -> StateT (Share SnapShot) (Decoder s) SnapShot)
-> StateT (Share SnapShot) (Decoder s) SnapShot
-> StateT (Share SnapShot) (Decoder s) SnapShot
forall a b. (a -> b) -> a -> b
$ do
    ssStake <- 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
    let ssTotalActiveStake = Stake -> Coin
sumAllStake Stake
ssStake Coin -> NonZero Coin -> NonZero Coin
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
    ssDelegations <- decSharePlusCBOR
    ssPoolParams <- decSharePlusLensCBOR (toMemptyLens _1 _2)
    (stakeCredInterns, stakePoolIdInterns) <- get
    ssStakePoolsSnapShot <-
      lift $ decodeVMap (interns stakePoolIdInterns <$> decCBOR) (decShareCBOR stakeCredInterns)
    pure SnapShot {..}

instance ToKeyValuePairs SnapShot where
  toKeyValuePairs :: forall e kv. KeyValue e kv => SnapShot -> [kv]
toKeyValuePairs ss :: SnapShot
ss@(SnapShot Stake
_ NonZero Coin
_ VMap VB VB (Credential Staking) (KeyHash StakePool)
_ VMap VB VB (KeyHash StakePool) StakePoolParams
_ VMap VB VB (KeyHash StakePool) StakePoolSnapShot
_) =
    let SnapShot {VMap VB VB (KeyHash StakePool) StakePoolParams
VMap VB VB (KeyHash StakePool) StakePoolSnapShot
VMap VB VB (Credential Staking) (KeyHash StakePool)
NonZero Coin
Stake
ssTotalActiveStake :: SnapShot -> NonZero Coin
ssStake :: SnapShot -> Stake
ssDelegations :: SnapShot -> VMap VB VB (Credential Staking) (KeyHash StakePool)
ssPoolParams :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams
ssStakePoolsSnapShot :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStake :: Stake
ssTotalActiveStake :: NonZero Coin
ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
..} = SnapShot
ss
     in [ Key
"stake" Key -> Stake -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stake
ssStake
        , Key
"delegations" Key -> VMap VB VB (Credential Staking) (KeyHash StakePool) -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations
        , Key
"poolParams" Key -> VMap VB VB (KeyHash StakePool) StakePoolParams -> 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) StakePoolParams
ssPoolParams
        , 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
        ]

-- | 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 = SnapShots
  { SnapShots -> SnapShot
ssStakeMark :: SnapShot -- Lazy on purpose
  , SnapShots -> PoolDistr
ssStakeMarkPoolDistr :: PoolDistr -- Lazy on purpose
  , SnapShots -> SnapShot
ssStakeSet :: !SnapShot
  , SnapShots -> SnapShot
ssStakeGo :: !SnapShot
  , SnapShots -> Coin
ssFee :: !Coin
  }
  deriving (Int -> SnapShots -> ShowS
[SnapShots] -> ShowS
SnapShots -> String
(Int -> SnapShots -> ShowS)
-> (SnapShots -> String)
-> ([SnapShots] -> ShowS)
-> Show SnapShots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapShots -> ShowS
showsPrec :: Int -> SnapShots -> ShowS
$cshow :: SnapShots -> String
show :: SnapShots -> String
$cshowList :: [SnapShots] -> ShowS
showList :: [SnapShots] -> ShowS
Show, SnapShots -> SnapShots -> Bool
(SnapShots -> SnapShots -> Bool)
-> (SnapShots -> SnapShots -> Bool) -> Eq SnapShots
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapShots -> SnapShots -> Bool
== :: SnapShots -> SnapShots -> Bool
$c/= :: SnapShots -> SnapShots -> Bool
/= :: SnapShots -> SnapShots -> Bool
Eq, (forall x. SnapShots -> Rep SnapShots x)
-> (forall x. Rep SnapShots x -> SnapShots) -> Generic SnapShots
forall x. Rep SnapShots x -> SnapShots
forall x. SnapShots -> Rep SnapShots x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapShots -> Rep SnapShots x
from :: forall x. SnapShots -> Rep SnapShots x
$cto :: forall x. Rep SnapShots x -> SnapShots
to :: forall x. Rep SnapShots x -> SnapShots
Generic)
  deriving ([SnapShots] -> Value
[SnapShots] -> Encoding
SnapShots -> Bool
SnapShots -> Value
SnapShots -> Encoding
(SnapShots -> Value)
-> (SnapShots -> Encoding)
-> ([SnapShots] -> Value)
-> ([SnapShots] -> Encoding)
-> (SnapShots -> Bool)
-> ToJSON SnapShots
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SnapShots -> Value
toJSON :: SnapShots -> Value
$ctoEncoding :: SnapShots -> Encoding
toEncoding :: SnapShots -> Encoding
$ctoJSONList :: [SnapShots] -> Value
toJSONList :: [SnapShots] -> Value
$ctoEncodingList :: [SnapShots] -> Encoding
toEncodingList :: [SnapShots] -> Encoding
$comitField :: SnapShots -> Bool
omitField :: SnapShots -> Bool
ToJSON) via KeyValuePairs SnapShots
  -- TODO: switch `AllowThunksIn` to `OnlyCheckWhnfNamed`
  deriving (Context -> SnapShots -> IO (Maybe ThunkInfo)
Proxy SnapShots -> String
(Context -> SnapShots -> IO (Maybe ThunkInfo))
-> (Context -> SnapShots -> IO (Maybe ThunkInfo))
-> (Proxy SnapShots -> String)
-> NoThunks SnapShots
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
noThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SnapShots -> String
showTypeOf :: Proxy SnapShots -> String
NoThunks) via AllowThunksIn '["ssStakeMark", "ssStakeMarkPoolDistr"] SnapShots

instance NFData SnapShots

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

instance DecCBOR SnapShots where
  decCBOR :: forall s. Decoder s SnapShots
decCBOR = Decoder s SnapShots
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

instance DecShareCBOR SnapShots where
  type Share SnapShots = Share SnapShot
  decSharePlusCBOR :: forall s. StateT (Share SnapShots) (Decoder s) SnapShots
decSharePlusCBOR = Text
-> (SnapShots -> Int)
-> StateT (Share SnapShots) (Decoder s) SnapShots
-> StateT (Share SnapShots) (Decoder s) SnapShots
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 -> Int
forall a b. a -> b -> a
const Int
4) (StateT (Share SnapShots) (Decoder s) SnapShots
 -> StateT (Share SnapShots) (Decoder s) SnapShots)
-> StateT (Share SnapShots) (Decoder s) SnapShots
-> StateT (Share SnapShots) (Decoder s) SnapShots
forall a b. (a -> b) -> a -> b
$ do
    !ssStakeMark <- 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
    ssStakeSet <- decSharePlusCBOR
    ssStakeGo <- decSharePlusCBOR
    ssFee <- lift decCBOR
    let ssStakeMarkPoolDistr = HasCallStack => SnapShot -> PoolDistr
SnapShot -> PoolDistr
calculatePoolDistr SnapShot
ssStakeMark
    pure SnapShots {ssStakeMark, ssStakeMarkPoolDistr, ssStakeSet, ssStakeGo, ssFee}

instance Default SnapShots where
  def :: SnapShots
def = SnapShots
emptySnapShots

instance ToKeyValuePairs SnapShots where
  toKeyValuePairs :: forall e kv. KeyValue e kv => SnapShots -> [kv]
toKeyValuePairs ss :: SnapShots
ss@(SnapShots !SnapShot
_ PoolDistr
_ SnapShot
_ SnapShot
_ Coin
_) =
    -- ssStakeMarkPoolDistr is omitted on purpose
    let SnapShots {SnapShot
ssStakeMark :: SnapShots -> SnapShot
ssStakeMark :: SnapShot
ssStakeMark, SnapShot
ssStakeSet :: SnapShots -> SnapShot
ssStakeSet :: SnapShot
ssStakeSet, SnapShot
ssStakeGo :: SnapShots -> SnapShot
ssStakeGo :: SnapShot
ssStakeGo, Coin
ssFee :: SnapShots -> Coin
ssFee :: Coin
ssFee} = SnapShots
ss
     in [ Key
"pstakeMark" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeMark
        , Key
"pstakeSet" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeSet
        , Key
"pstakeGo" Key -> SnapShot -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
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 = Stake
-> NonZero Coin
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
-> SnapShot
SnapShot (VMap VB VP (Credential Staking) (CompactForm Coin) -> Stake
Stake VMap VB VP (Credential Staking) (CompactForm Coin)
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 (Credential Staking) (KeyHash StakePool)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty VMap VB VB (KeyHash StakePool) StakePoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall a. Monoid a => a
mempty

emptySnapShots :: SnapShots
emptySnapShots :: SnapShots
emptySnapShots =
  SnapShot -> PoolDistr -> SnapShot -> SnapShot -> Coin -> SnapShots
SnapShots SnapShot
emptySnapShot (HasCallStack => SnapShot -> PoolDistr
SnapShot -> PoolDistr
calculatePoolDistr SnapShot
emptySnapShot) SnapShot
emptySnapShot SnapShot
emptySnapShot (Integer -> Coin
Coin Integer
0)

snapShotFromInstantStake ::
  forall era.
  (HasCallStack, EraStake era) =>
  InstantStake era ->
  DState era ->
  PState era ->
  Network ->
  SnapShot
snapShotFromInstantStake :: forall era.
(HasCallStack, EraStake era) =>
InstantStake era -> DState era -> PState era -> Network -> 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} Network
network =
  Bool -> SnapShot -> SnapShot
forall a. HasCallStack => Bool -> a -> a
assert
    ( Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool
        Map (KeyHash StakePool) (Set (Credential Staking))
-> Map (KeyHash StakePool) (Set (Credential Staking)) -> Bool
forall a. Eq a => a -> a -> Bool
== Map (KeyHash StakePool) (Set (Credential Staking))
reverseDelegatorsPerStakePool
        Bool -> Bool -> Bool
|| String -> Bool
forall a. HasCallStack => String -> a
error
          ( String
"Delegs:\n  "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map (KeyHash StakePool) (Set (Credential Staking)) -> String
forall a. Show a => a -> String
show Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n/=\nReverse Delegs:\n  "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map (KeyHash StakePool) (Set (Credential Staking)) -> String
forall a. Show a => a -> String
show Map (KeyHash StakePool) (Set (Credential Staking))
reverseDelegatorsPerStakePool
          )
    )
    (SnapShot -> SnapShot) -> SnapShot -> SnapShot
forall a b. (a -> b) -> a -> b
$ SnapShot
      { ssStake :: Stake
ssStake = Stake
activeStake
      , ssTotalActiveStake :: NonZero Coin
ssTotalActiveStake = NonZero Coin
totalActiveStake
      , ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations = VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
      , ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams = VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams
      , ssStakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
ssStakePoolsSnapShot = VMap VB VB (KeyHash StakePool) StakePoolSnapShot
stakePoolsSnapShot
      }
  where
    reverseDelegatorsPerStakePool :: Map (KeyHash StakePool) (Set (Credential Staking))
reverseDelegatorsPerStakePool =
      (StakePoolState -> Maybe (Set (Credential Staking)))
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
        (\StakePoolState
sps -> StakePoolState -> Set (Credential Staking)
spsDelegators StakePoolState
sps Set (Credential Staking)
-> Maybe () -> Maybe (Set (Credential Staking))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Set (Credential Staking) -> Bool
forall a. Set a -> Bool
Set.null (StakePoolState -> Set (Credential Staking)
spsDelegators StakePoolState
sps))))
        Map (KeyHash StakePool) StakePoolState
psStakePools
    poolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams =
      Int
-> [(KeyHash StakePool, StakePoolParams)]
-> VMap VB VB (KeyHash StakePool) StakePoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Int -> [(k, v)] -> VMap kv vv k v
VMap.fromDistinctAscListN
        (Map (KeyHash StakePool) StakePoolState -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash StakePool) StakePoolState
psStakePools)
        [ (KeyHash StakePool
poolId, KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
stakePoolStateToStakePoolParams KeyHash StakePool
poolId Network
network StakePoolState
ps)
        | (KeyHash StakePool
poolId, StakePoolState
ps) <- Map (KeyHash StakePool) StakePoolState
-> [(KeyHash StakePool, StakePoolState)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (KeyHash StakePool) StakePoolState
psStakePools
        ]
    stakePoolsSnapShot :: VMap VB VB (KeyHash StakePool) StakePoolSnapShot
stakePoolsSnapShot =
      (StakePoolState -> StakePoolSnapShot)
-> VMap VB VB (KeyHash StakePool) StakePoolState
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.map (Stake -> NonZero Coin -> StakePoolState -> StakePoolSnapShot
mkStakePoolSnapShot Stake
activeStake NonZero Coin
totalActiveStake) (VMap VB VB (KeyHash StakePool) StakePoolState
 -> VMap VB VB (KeyHash StakePool) StakePoolSnapShot)
-> VMap VB VB (KeyHash StakePool) StakePoolState
-> VMap VB VB (KeyHash StakePool) StakePoolSnapShot
forall a b. (a -> b) -> a -> b
$ 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
    activeStake :: Stake
activeStake = InstantStake era -> Accounts era -> Stake
forall era.
EraStake era =>
InstantStake era -> Accounts era -> Stake
resolveInstantStake InstantStake era
instantStake Accounts era
accounts
    totalActiveStake :: NonZero Coin
totalActiveStake = Stake -> Coin
sumAllStake Stake
activeStake Coin -> NonZero Coin -> NonZero Coin
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
    accounts :: Accounts era
accounts = DState era -> Accounts era
forall era. DState era -> Accounts era
dsAccounts DState era
dState
    delegs :: VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs = Int
-> [(Credential Staking, KeyHash StakePool)]
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Int -> [(k, v)] -> VMap kv vv k v
VMap.fromDistinctAscListN Int
delegsCount [(Credential Staking, KeyHash StakePool)]
delegsAscList
    delegatorsPerStakePool :: Map (KeyHash StakePool) (Set (Credential Staking))
delegatorsPerStakePool =
      (Map (KeyHash StakePool) (Set (Credential Staking))
 -> Credential Staking
 -> KeyHash StakePool
 -> Map (KeyHash StakePool) (Set (Credential Staking)))
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Map (KeyHash StakePool) (Set (Credential Staking))
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) (Set (Credential Staking))
acc Credential Staking
cred KeyHash StakePool
poolId -> (Set (Credential Staking)
 -> Set (Credential Staking) -> Set (Credential Staking))
-> KeyHash StakePool
-> Set (Credential Staking)
-> Map (KeyHash StakePool) (Set (Credential Staking))
-> Map (KeyHash StakePool) (Set (Credential Staking))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (Credential Staking)
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Semigroup a => a -> a -> a
(<>) KeyHash StakePool
poolId (Credential Staking -> Set (Credential Staking)
forall a. a -> Set a
Set.singleton Credential Staking
cred) Map (KeyHash StakePool) (Set (Credential Staking))
acc)
        Map (KeyHash StakePool) (Set (Credential Staking))
forall a. Monoid a => a
mempty
        VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
    keepAndCountDelegations ::
      Credential Staking ->
      AccountState era ->
      ([(Credential Staking, KeyHash StakePool)], Int) ->
      ([(Credential Staking, KeyHash StakePool)], Int)
    keepAndCountDelegations :: Credential Staking
-> AccountState era
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> ([(Credential Staking, KeyHash StakePool)], Int)
keepAndCountDelegations Credential Staking
cred AccountState era
accountState acc :: ([(Credential Staking, KeyHash StakePool)], Int)
acc@(![(Credential Staking, KeyHash StakePool)]
curDelegs, !Int
curCount) =
      case AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL of
        Maybe (KeyHash StakePool)
Nothing -> ([(Credential Staking, KeyHash StakePool)], Int)
acc
        Just KeyHash StakePool
deleg -> ((Credential Staking
cred, KeyHash StakePool
deleg) (Credential Staking, KeyHash StakePool)
-> [(Credential Staking, KeyHash StakePool)]
-> [(Credential Staking, KeyHash StakePool)]
forall a. a -> [a] -> [a]
: [(Credential Staking, KeyHash StakePool)]
curDelegs, Int
curCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    ([(Credential Staking, KeyHash StakePool)]
delegsAscList, Int
delegsCount) =
      (Credential Staking
 -> AccountState era
 -> ([(Credential Staking, KeyHash StakePool)], Int)
 -> ([(Credential Staking, KeyHash StakePool)], Int))
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> Map (Credential Staking) (AccountState era)
-> ([(Credential Staking, KeyHash StakePool)], Int)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Credential Staking
-> AccountState era
-> ([(Credential Staking, KeyHash StakePool)], Int)
-> ([(Credential Staking, KeyHash StakePool)], Int)
keepAndCountDelegations ([], Int
0) (Map (Credential Staking) (AccountState era)
 -> ([(Credential Staking, KeyHash StakePool)], Int))
-> Map (Credential Staking) (AccountState era)
-> ([(Credential Staking, KeyHash StakePool)], Int)
forall a b. (a -> b) -> a -> b
$ Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
{-# INLINE snapShotFromInstantStake #-}

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

-- | Sum up the Coin (as CompactForm Coin = Word64) for each StakePool
calculatePoolStake ::
  (KeyHash StakePool -> Bool) ->
  VMap VB VB (Credential Staking) (KeyHash StakePool) ->
  Stake ->
  Map.Map (KeyHash StakePool) (CompactForm Coin)
calculatePoolStake :: (KeyHash StakePool -> Bool)
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Map (KeyHash StakePool) (CompactForm Coin)
calculatePoolStake KeyHash StakePool -> Bool
includeHash VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake = (Map (KeyHash StakePool) (CompactForm Coin)
 -> Credential Staking
 -> KeyHash StakePool
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> Map (KeyHash StakePool) (CompactForm Coin)
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> 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
-> KeyHash StakePool
-> Map (KeyHash StakePool) (CompactForm Coin)
accum Map (KeyHash StakePool) (CompactForm Coin)
forall k a. Map k a
Map.empty VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs
  where
    accum :: Map (KeyHash StakePool) (CompactForm Coin)
-> Credential Staking
-> KeyHash StakePool
-> Map (KeyHash StakePool) (CompactForm Coin)
accum Map (KeyHash StakePool) (CompactForm Coin)
ans Credential Staking
cred KeyHash StakePool
keyHash =
      if KeyHash StakePool -> Bool
includeHash KeyHash StakePool
keyHash
        then
          let !c :: CompactForm Coin
c = CompactForm Coin -> Maybe (CompactForm Coin) -> CompactForm Coin
forall a. a -> Maybe a -> a
fromMaybe CompactForm Coin
forall a. Monoid a => a
mempty (Maybe (CompactForm Coin) -> CompactForm Coin)
-> Maybe (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ Credential Staking
-> VMap VB VP (Credential Staking) (CompactForm Coin)
-> Maybe (CompactForm Coin)
forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential Staking
cred (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake Stake
stake)
           in (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
(<>) KeyHash StakePool
keyHash CompactForm Coin
c Map (KeyHash StakePool) (CompactForm Coin)
ans
        else Map (KeyHash StakePool) (CompactForm Coin)
ans

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

calculatePoolDistr' :: HasCallStack => (KeyHash StakePool -> Bool) -> SnapShot -> PoolDistr
calculatePoolDistr' :: HasCallStack =>
(KeyHash StakePool -> Bool) -> SnapShot -> PoolDistr
calculatePoolDistr' KeyHash StakePool -> Bool
includeHash (SnapShot Stake
stake NonZero Coin
activeStake VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs VMap VB VB (KeyHash StakePool) StakePoolParams
poolParams VMap VB VB (KeyHash StakePool) StakePoolSnapShot
stakePoolSnapShot) =
  let total :: CompactForm Coin
total = Stake -> CompactForm Coin
sumAllStakeCompact Stake
stake
      nonZeroTotal :: NonZero Coin
nonZeroTotal = NonZero (CompactForm Coin) -> NonZero Coin
fromCompactCoinNonZero (NonZero (CompactForm Coin) -> NonZero Coin)
-> NonZero (CompactForm Coin) -> NonZero Coin
forall a b. (a -> b) -> a -> b
$ CompactForm Coin
total CompactForm Coin
-> NonZero (CompactForm Coin) -> NonZero (CompactForm Coin)
forall a. HasZero a => a -> NonZero a -> NonZero a
`nonZeroOr` forall (n :: Natural).
(KnownNat n, 1 <= n, WithinBounds n Word64) =>
NonZero (CompactForm Coin)
knownNonZeroCompactCoin @1
      poolStakeMap :: Map (KeyHash StakePool) (CompactForm Coin)
poolStakeMap = (KeyHash StakePool -> Bool)
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> Stake
-> Map (KeyHash StakePool) (CompactForm Coin)
calculatePoolStake KeyHash StakePool -> Bool
includeHash VMap VB VB (Credential Staking) (KeyHash StakePool)
delegs Stake
stake
      oldPoolDistr :: PoolDistr
oldPoolDistr =
        Map (KeyHash StakePool) IndividualPoolStake
-> NonZero Coin -> PoolDistr
PoolDistr
          ( (CompactForm Coin -> StakePoolParams -> IndividualPoolStake)
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) IndividualPoolStake
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith
              ( \stakePoolStake :: CompactForm Coin
stakePoolStake@(CompactCoin Word64
w64) StakePoolParams
poolParam ->
                  Rational
-> CompactForm Coin
-> VRFVerKeyHash StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake
                    (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
w64 Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. NonZero Coin -> NonZero Integer
unCoinNonZero NonZero Coin
nonZeroTotal)
                    CompactForm Coin
stakePoolStake
                    (StakePoolParams -> VRFVerKeyHash StakePoolVRF
sppVrf StakePoolParams
poolParam)
              )
              Map (KeyHash StakePool) (CompactForm Coin)
poolStakeMap
              (VMap VB VB (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) StakePoolParams
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) StakePoolParams
poolParams)
          )
          NonZero Coin
nonZeroTotal
      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
            }
      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
          }
      showFailure :: Bool
showFailure =
        String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$
          String
"PoolDistr is not the same:\nOld PoolDistr:\n"
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PoolDistr -> String
forall a. Show a => a -> String
show PoolDistr
oldPoolDistr
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nNew PoolDistr:\n"
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PoolDistr -> String
forall a. Show a => a -> String
show PoolDistr
poolDistr
   in Bool -> PoolDistr -> PoolDistr
forall a. HasCallStack => Bool -> a -> a
assert (PoolDistr
oldPoolDistr PoolDistr -> PoolDistr -> Bool
forall a. Eq a => a -> a -> Bool
== PoolDistr
poolDistr Bool -> Bool -> Bool
|| Bool
showFailure) PoolDistr
poolDistr

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

-- SnapShots

ssStakeMarkL :: Lens' SnapShots SnapShot
ssStakeMarkL :: Lens' SnapShots SnapShot
ssStakeMarkL = (SnapShots -> SnapShot)
-> (SnapShots -> SnapShot -> SnapShots) -> Lens' SnapShots SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots -> SnapShot
ssStakeMark (\SnapShots
ds SnapShot
u -> SnapShots
ds {ssStakeMark = u})

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

ssStakeSetL :: Lens' SnapShots SnapShot
ssStakeSetL :: Lens' SnapShots SnapShot
ssStakeSetL = (SnapShots -> SnapShot)
-> (SnapShots -> SnapShot -> SnapShots) -> Lens' SnapShots SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots -> SnapShot
ssStakeSet (\SnapShots
ds SnapShot
u -> SnapShots
ds {ssStakeSet = u})

ssStakeGoL :: Lens' SnapShots SnapShot
ssStakeGoL :: Lens' SnapShots SnapShot
ssStakeGoL = (SnapShots -> SnapShot)
-> (SnapShots -> SnapShot -> SnapShots) -> Lens' SnapShots SnapShot
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShots -> SnapShot
ssStakeGo (\SnapShots
ds SnapShot
u -> SnapShots
ds {ssStakeGo = u})

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

-- SnapShot

ssStakeL :: Lens' SnapShot Stake
ssStakeL :: Lens' SnapShot Stake
ssStakeL = (SnapShot -> Stake)
-> (SnapShot -> Stake -> SnapShot) -> Lens' SnapShot Stake
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> Stake
ssStake (\SnapShot
ds Stake
u -> SnapShot
ds {ssStake = u})

ssStakeDistrL :: Lens' SnapShot (VMap VB VP (Credential Staking) (CompactForm Coin))
ssStakeDistrL :: Lens' SnapShot (VMap VB VP (Credential Staking) (CompactForm Coin))
ssStakeDistrL = (SnapShot -> VMap VB VP (Credential Staking) (CompactForm Coin))
-> (SnapShot
    -> VMap VB VP (Credential Staking) (CompactForm Coin) -> SnapShot)
-> Lens'
     SnapShot (VMap VB VP (Credential Staking) (CompactForm Coin))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin))
-> (SnapShot -> Stake)
-> SnapShot
-> VMap VB VP (Credential Staking) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot -> Stake
ssStake) (\SnapShot
ds VMap VB VP (Credential Staking) (CompactForm Coin)
u -> SnapShot
ds {ssStake = Stake u})

ssDelegationsL :: Lens' SnapShot (VMap VB VB (Credential Staking) (KeyHash StakePool))
ssDelegationsL :: Lens'
  SnapShot (VMap VB VB (Credential Staking) (KeyHash StakePool))
ssDelegationsL = (SnapShot -> VMap VB VB (Credential Staking) (KeyHash StakePool))
-> (SnapShot
    -> VMap VB VB (Credential Staking) (KeyHash StakePool) -> SnapShot)
-> Lens'
     SnapShot (VMap VB VB (Credential Staking) (KeyHash StakePool))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations (\SnapShot
ds VMap VB VB (Credential Staking) (KeyHash StakePool)
u -> SnapShot
ds {ssDelegations = u})

ssPoolParamsL :: Lens' SnapShot (VMap VB VB (KeyHash StakePool) StakePoolParams)
ssPoolParamsL :: Lens' SnapShot (VMap VB VB (KeyHash StakePool) StakePoolParams)
ssPoolParamsL = (SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams)
-> (SnapShot
    -> VMap VB VB (KeyHash StakePool) StakePoolParams -> SnapShot)
-> Lens' SnapShot (VMap VB VB (KeyHash StakePool) StakePoolParams)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams (\SnapShot
ds VMap VB VB (KeyHash StakePool) StakePoolParams
u -> SnapShot
ds {ssPoolParams = u})