{-# 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      : EpochBoundary
-- Description : Functions and definitions for rules at epoch boundary.
--
-- This modules implements the necessary functions for the changes that can happen at epoch boundaries.
module Cardano.Ledger.State.SnapShots (
  Stake (..),
  sumAllStake,
  sumAllStakeCompact,
  sumStakePerPool,
  SnapShot (..),
  SnapShots (..),
  emptySnapShot,
  emptySnapShots,
  poolStake,
  maxPool,
  maxPool',
  calculatePoolDistr,
  calculatePoolDistr',
  calculatePoolStake,
  ssStakeMarkL,
  ssStakeMarkPoolDistrL,
  ssStakeSetL,
  ssStakeGoL,
  ssFeeL,
  ssStakeL,
  ssStakeDistrL,
  ssDelegationsL,
  ssPoolParamsL,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (..),
  NonNegativeInterval,
  NonZero (..),
  knownNonZeroBounded,
  nonZeroOr,
  recipNonZero,
  toIntegerNonZero,
  toRatioNonZero,
  (%.),
  (/.),
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  Interns,
  decNoShareCBOR,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  encodeListLen,
  toMemptyLens,
 )
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm (..),
  coinToRational,
  compactCoinNonZero,
  fromCompactCoinNonZero,
  rationalToCoinViaFloor,
  unCoinNonZero,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.PoolParams (PoolParams (ppVrf))
import Cardano.Ledger.State.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.Val ((<+>))
import Control.DeepSeq (NFData)
import Control.Monad.Trans (lift)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (Default, def)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.VMap as VMap
import Data.Word (Word16)
import GHC.Generics (Generic)
import GHC.Word (Word64)
import Lens.Micro (Lens', lens, (^.), _1, _2)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))

-- | Type of stake as map from staking credential to coins associated. Any staking credential that
-- has no stake will not appear in this Map, even if it is registered. For this reason, this data
-- type should not be used for infering whether credential is registered or not.
newtype Stake = Stake
  { Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake :: VMap VB VP (Credential 'Staking) (CompactForm Coin)
  }
  deriving (Int -> Stake -> ShowS
[Stake] -> ShowS
Stake -> String
(Int -> Stake -> ShowS)
-> (Stake -> String) -> ([Stake] -> ShowS) -> Show Stake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stake -> ShowS
showsPrec :: Int -> Stake -> ShowS
$cshow :: Stake -> String
show :: Stake -> String
$cshowList :: [Stake] -> ShowS
showList :: [Stake] -> ShowS
Show, Stake -> Stake -> Bool
(Stake -> Stake -> Bool) -> (Stake -> Stake -> Bool) -> Eq Stake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Stake -> Stake -> Bool
== :: Stake -> Stake -> Bool
$c/= :: Stake -> Stake -> Bool
/= :: Stake -> Stake -> Bool
Eq, Stake -> ()
(Stake -> ()) -> NFData Stake
forall a. (a -> ()) -> NFData a
$crnf :: Stake -> ()
rnf :: Stake -> ()
NFData, (forall x. Stake -> Rep Stake x)
-> (forall x. Rep Stake x -> Stake) -> Generic Stake
forall x. Rep Stake x -> Stake
forall x. Stake -> Rep Stake x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Stake -> Rep Stake x
from :: forall x. Stake -> Rep Stake x
$cto :: forall x. Rep Stake x -> Stake
to :: forall x. Rep Stake x -> Stake
Generic, [Stake] -> Value
[Stake] -> Encoding
Stake -> Bool
Stake -> Value
Stake -> Encoding
(Stake -> Value)
-> (Stake -> Encoding)
-> ([Stake] -> Value)
-> ([Stake] -> Encoding)
-> (Stake -> Bool)
-> ToJSON Stake
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Stake -> Value
toJSON :: Stake -> Value
$ctoEncoding :: Stake -> Encoding
toEncoding :: Stake -> Encoding
$ctoJSONList :: [Stake] -> Value
toJSONList :: [Stake] -> Value
$ctoEncodingList :: [Stake] -> Encoding
toEncodingList :: [Stake] -> Encoding
$comitField :: Stake -> Bool
omitField :: Stake -> Bool
ToJSON, Context -> Stake -> IO (Maybe ThunkInfo)
Proxy Stake -> String
(Context -> Stake -> IO (Maybe ThunkInfo))
-> (Context -> Stake -> IO (Maybe ThunkInfo))
-> (Proxy Stake -> String)
-> NoThunks Stake
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
noThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Stake -> String
showTypeOf :: Proxy Stake -> String
NoThunks, Typeable Stake
Typeable Stake =>
(Stake -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy Stake -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy [Stake] -> Size)
-> EncCBOR Stake
Stake -> Encoding
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Stake] -> Size
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy Stake -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
$cencCBOR :: Stake -> Encoding
encCBOR :: Stake -> Encoding
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Stake -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Stake -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Stake] -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Stake] -> Size
EncCBOR)

instance DecShareCBOR Stake where
  type Share Stake = Share (VMap VB VP (Credential 'Staking) (CompactForm Coin))
  getShare :: Stake -> Share Stake
getShare = VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Share (VMap VB VP (Credential 'Staking) (CompactForm Coin))
VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Interns (Credential 'Staking)
forall a. DecShareCBOR a => a -> Share a
getShare (VMap VB VP (Credential 'Staking) (CompactForm Coin)
 -> Interns (Credential 'Staking))
-> (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Stake
-> Interns (Credential 'Staking)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake
  decShareCBOR :: forall s. Share Stake -> Decoder s Stake
decShareCBOR = (VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake)
-> Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Decoder s Stake
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
Stake (Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin))
 -> Decoder s Stake)
-> (Interns (Credential 'Staking)
    -> Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin)))
-> Interns (Credential 'Staking)
-> Decoder s Stake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Share (VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin))
Interns (Credential 'Staking)
-> Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin))
forall a s. DecShareCBOR a => Share a -> Decoder s a
forall s.
Share (VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Decoder s (VMap VB VP (Credential 'Staking) (CompactForm Coin))
decShareCBOR

sumAllStake :: Stake -> Coin
sumAllStake :: Stake -> Coin
sumAllStake = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (Stake -> CompactForm Coin) -> Stake -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> CompactForm Coin
sumAllStakeCompact
{-# INLINE sumAllStake #-}

sumAllStakeCompact :: Stake -> CompactForm Coin
sumAllStakeCompact :: Stake -> CompactForm Coin
sumAllStakeCompact = (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> CompactForm Coin
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> CompactForm Coin
forall (vv :: * -> *) v a (kv :: * -> *) k.
Vector vv v =>
(a -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldl CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) CompactForm Coin
forall a. Monoid a => a
mempty (VMap VB VP (Credential 'Staking) (CompactForm Coin)
 -> CompactForm Coin)
-> (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Stake
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake
{-# INLINE sumAllStakeCompact #-}

-- | Get stake of one pool
poolStake ::
  KeyHash 'StakePool ->
  VMap VB VB (Credential 'Staking) (KeyHash 'StakePool) ->
  Stake ->
  Stake
poolStake :: KeyHash 'StakePool
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Stake
-> Stake
poolStake KeyHash 'StakePool
hk VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs (Stake VMap VB VP (Credential 'Staking) (CompactForm Coin)
stake) =
  -- Stake $ (eval (dom (delegs ▷ setSingleton hk) ◁ stake))
  VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
Stake (VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake)
-> VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
forall a b. (a -> b) -> a -> b
$ (Credential 'Staking -> CompactForm Coin -> Bool)
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
(k -> v -> Bool) -> VMap kv vv k v -> VMap kv vv k v
VMap.filter (\Credential 'Staking
cred CompactForm Coin
_ -> 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 Maybe (KeyHash 'StakePool) -> Maybe (KeyHash 'StakePool) -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash 'StakePool -> Maybe (KeyHash 'StakePool)
forall a. a -> Maybe a
Just KeyHash 'StakePool
hk) VMap VB VP (Credential 'Staking) (CompactForm Coin)
stake

-- | Compute amount of stake each pool has. Any registered stake pool that has no stake will not be
-- inlcuded 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

-- | 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

-- | Snapshot of the stake distribution.
data SnapShot = SnapShot
  { SnapShot -> Stake
ssStake :: !Stake
  , SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations :: !(VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
  , SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams :: !(VMap VB VB (KeyHash 'StakePool) PoolParams)
  }
  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)

instance NoThunks SnapShot

instance NFData SnapShot

instance EncCBOR SnapShot where
  encCBOR :: SnapShot -> Encoding
encCBOR SnapShot {Stake
$sel:ssStake:SnapShot :: SnapShot -> Stake
ssStake :: Stake
ssStake, VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssDelegations:SnapShot :: SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations, VMap VB VB (KeyHash 'StakePool) PoolParams
$sel:ssPoolParams:SnapShot :: SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams} =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Stake -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Stake
ssStake
      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) PoolParams -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams

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
3) (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
    Stake
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
    VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations <- StateT
  (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
  (Decoder s)
  (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
StateT
  (Share (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)))
  (Decoder s)
  (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
forall s.
StateT
  (Share (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)))
  (Decoder s)
  (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams <- Lens'
  (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
  (Share (VMap VB VB (KeyHash 'StakePool) PoolParams))
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     (VMap VB VB (KeyHash 'StakePool) PoolParams)
forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (Lens'
  (Interns (KeyHash 'StakePool), Interns PoolParams)
  (Interns (KeyHash 'StakePool))
-> Lens'
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Interns (KeyHash 'StakePool))
-> Lens'
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Interns (KeyHash 'StakePool), Interns PoolParams)
forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens (Interns (KeyHash 'StakePool) -> f (Interns (KeyHash 'StakePool)))
-> (Interns (KeyHash 'StakePool), Interns PoolParams)
-> f (Interns (KeyHash 'StakePool), Interns PoolParams)
forall s t a b. Field1 s t a b => Lens s t a b
Lens'
  (Interns (KeyHash 'StakePool), Interns PoolParams)
  (Interns (KeyHash 'StakePool))
_1 (Interns (KeyHash 'StakePool) -> f (Interns (KeyHash 'StakePool)))
-> (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
-> f (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
forall s t a b. Field2 s t a b => Lens s t a b
Lens'
  (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
  (Interns (KeyHash 'StakePool))
_2)
    SnapShot
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     SnapShot
forall a.
a
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShot {Stake
$sel:ssStake:SnapShot :: Stake
ssStake :: Stake
ssStake, VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations, VMap VB VB (KeyHash 'StakePool) PoolParams
$sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams}

instance ToJSON SnapShot where
  toJSON :: SnapShot -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value) -> (SnapShot -> [Pair]) -> SnapShot -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot -> [Pair]
forall e a. KeyValue e a => SnapShot -> [a]
toSnapShotPair
  toEncoding :: SnapShot -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (SnapShot -> Series) -> SnapShot -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (SnapShot -> [Series]) -> SnapShot -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot -> [Series]
forall e a. KeyValue e a => SnapShot -> [a]
toSnapShotPair

toSnapShotPair :: KeyValue e a => SnapShot -> [a]
toSnapShotPair :: forall e a. KeyValue e a => SnapShot -> [a]
toSnapShotPair ss :: SnapShot
ss@(SnapShot Stake
_ VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
_ VMap VB VB (KeyHash 'StakePool) PoolParams
_) =
  let SnapShot {VMap VB VB (KeyHash 'StakePool) PoolParams
VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
Stake
$sel:ssStake:SnapShot :: SnapShot -> Stake
$sel:ssDelegations:SnapShot :: SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssPoolParams:SnapShot :: SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
ssStake :: Stake
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
..} = SnapShot
ss
   in [ Key
"stake" Key -> Stake -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stake
ssStake
      , Key
"delegations" Key -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool) -> a
forall v. ToJSON v => Key -> v -> a
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) PoolParams -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams
      ]

-- | 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)
  -- 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
$sel:ssStakeMark:SnapShots :: SnapShots -> SnapShot
ssStakeMark :: SnapShot
ssStakeMark, SnapShot
$sel:ssStakeSet:SnapShots :: SnapShots -> SnapShot
ssStakeSet :: SnapShot
ssStakeSet, SnapShot
$sel:ssStakeGo:SnapShots :: SnapShots -> SnapShot
ssStakeGo :: SnapShot
ssStakeGo, Coin
$sel:ssFee:SnapShots :: 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
    !SnapShot
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
    SnapShot
ssStakeSet <- 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
    SnapShot
ssStakeGo <- 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
    Coin
ssFee <- Decoder s Coin
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     Coin
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 Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR
    let ssStakeMarkPoolDistr :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
ssStakeMark
    SnapShots
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     SnapShots
forall a.
a
-> StateT
     (Interns (Credential 'Staking), Interns (KeyHash 'StakePool))
     (Decoder s)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShots {SnapShot
$sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark :: SnapShot
ssStakeMark, PoolDistr
$sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr :: PoolDistr
ssStakeMarkPoolDistr, SnapShot
$sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet :: SnapShot
ssStakeSet, SnapShot
$sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo :: SnapShot
ssStakeGo, Coin
$sel:ssFee:SnapShots :: Coin
ssFee :: Coin
ssFee}

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

instance ToJSON SnapShots where
  toJSON :: SnapShots -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value) -> (SnapShots -> [Pair]) -> SnapShots -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShots -> [Pair]
forall e a. KeyValue e a => SnapShots -> [a]
toSnapShotsPair
  toEncoding :: SnapShots -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (SnapShots -> Series) -> SnapShots -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (SnapShots -> [Series]) -> SnapShots -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShots -> [Series]
forall e a. KeyValue e a => SnapShots -> [a]
toSnapShotsPair

toSnapShotsPair :: KeyValue e a => SnapShots -> [a]
toSnapShotsPair :: forall e a. KeyValue e a => SnapShots -> [a]
toSnapShotsPair ss :: SnapShots
ss@(SnapShots !SnapShot
_ PoolDistr
_ SnapShot
_ SnapShot
_ Coin
_) =
  -- ssStakeMarkPoolDistr is omitted on purpose
  let SnapShots {SnapShot
$sel:ssStakeMark:SnapShots :: SnapShots -> SnapShot
ssStakeMark :: SnapShot
ssStakeMark, SnapShot
$sel:ssStakeSet:SnapShots :: SnapShots -> SnapShot
ssStakeSet :: SnapShot
ssStakeSet, SnapShot
$sel:ssStakeGo:SnapShots :: SnapShots -> SnapShot
ssStakeGo :: SnapShot
ssStakeGo, Coin
$sel:ssFee:SnapShots :: SnapShots -> Coin
ssFee :: Coin
ssFee} = SnapShots
ss
   in [ Key
"pstakeMark" Key -> SnapShot -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeMark
      , Key
"pstakeSet" Key -> SnapShot -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeSet
      , Key
"pstakeGo" Key -> SnapShot -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeGo
      , Key
"feeSS" Key -> Coin -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
ssFee
      ]

emptySnapShot :: SnapShot
emptySnapShot :: SnapShot
emptySnapShot = Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> 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) 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) PoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty

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

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

-- | 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) Word64
calculatePoolStake :: (KeyHash 'StakePool -> Bool)
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Stake
-> Map (KeyHash 'StakePool) Word64
calculatePoolStake KeyHash 'StakePool -> Bool
includeHash VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs Stake
stake = (Map (KeyHash 'StakePool) Word64
 -> Credential 'Staking
 -> KeyHash 'StakePool
 -> Map (KeyHash 'StakePool) Word64)
-> Map (KeyHash 'StakePool) Word64
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'StakePool) Word64
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) Word64
-> Credential 'Staking
-> KeyHash 'StakePool
-> Map (KeyHash 'StakePool) Word64
accum Map (KeyHash 'StakePool) Word64
forall k a. Map k a
Map.empty VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs
  where
    accum :: Map (KeyHash 'StakePool) Word64
-> Credential 'Staking
-> KeyHash 'StakePool
-> Map (KeyHash 'StakePool) Word64
accum Map (KeyHash 'StakePool) Word64
ans Credential 'Staking
cred KeyHash 'StakePool
keyHash =
      if KeyHash 'StakePool -> Bool
includeHash KeyHash 'StakePool
keyHash
        then
          let CompactCoin Word64
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 (Word64 -> Word64 -> Word64)
-> KeyHash 'StakePool
-> Word64
-> Map (KeyHash 'StakePool) Word64
-> Map (KeyHash 'StakePool) Word64
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) KeyHash 'StakePool
keyHash Word64
c Map (KeyHash 'StakePool) Word64
ans
        else Map (KeyHash 'StakePool) Word64
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 Stake
stake VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs VMap VB VB (KeyHash 'StakePool) PoolParams
poolParams) =
  let CompactCoin Word64
total = Stake -> CompactForm Coin
sumAllStakeCompact Stake
stake
      -- total could be zero (in particular when shrinking)
      nonZeroTotalCompact :: NonZero (CompactForm Coin)
nonZeroTotalCompact = NonZero Word64 -> NonZero (CompactForm Coin)
compactCoinNonZero (NonZero Word64 -> NonZero (CompactForm Coin))
-> NonZero Word64 -> NonZero (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$ Word64
total Word64 -> NonZero Word64 -> NonZero Word64
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
      nonZeroTotalInteger :: NonZero Integer
nonZeroTotalInteger = NonZero Coin -> NonZero Integer
unCoinNonZero (NonZero Coin -> NonZero Integer)
-> NonZero Coin -> NonZero Integer
forall a b. (a -> b) -> a -> b
$ NonZero (CompactForm Coin) -> NonZero Coin
fromCompactCoinNonZero NonZero (CompactForm Coin)
nonZeroTotalCompact
      poolStakeMap :: Map (KeyHash 'StakePool) Word64
poolStakeMap = (KeyHash 'StakePool -> Bool)
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Stake
-> Map (KeyHash 'StakePool) Word64
calculatePoolStake KeyHash 'StakePool -> Bool
includeHash VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs Stake
stake
   in Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr
        ( (Word64 -> PoolParams -> IndividualPoolStake)
-> Map (KeyHash 'StakePool) Word64
-> Map (KeyHash 'StakePool) PoolParams
-> 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
            ( \Word64
word64 PoolParams
poolparam ->
                Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake
                  (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
word64 Integer -> NonZero Integer -> Rational
forall a. Integral a => a -> NonZero a -> Ratio a
%. NonZero Integer
nonZeroTotalInteger)
                  (Word64 -> CompactForm Coin
CompactCoin Word64
word64)
                  (PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf PoolParams
poolparam)
            )
            Map (KeyHash 'StakePool) Word64
poolStakeMap
            (VMap VB VB (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
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) PoolParams
poolParams)
        )
        (NonZero (CompactForm Coin) -> CompactForm Coin
forall a. NonZero a -> a
unNonZero NonZero (CompactForm Coin)
nonZeroTotalCompact)

-- ======================================================
-- 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) PoolParams)
ssPoolParamsL :: Lens' SnapShot (VMap VB VB (KeyHash 'StakePool) PoolParams)
ssPoolParamsL = (SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams)
-> (SnapShot
    -> VMap VB VB (KeyHash 'StakePool) PoolParams -> SnapShot)
-> Lens' SnapShot (VMap VB VB (KeyHash 'StakePool) PoolParams)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams (\SnapShot
ds VMap VB VB (KeyHash 'StakePool) PoolParams
u -> SnapShot
ds {ssPoolParams = u})