{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stake] -> ShowS
$cshowList :: [Stake] -> ShowS
show :: Stake -> String
$cshow :: Stake -> String
showsPrec :: Int -> Stake -> ShowS
$cshowsPrec :: Int -> Stake -> ShowS
Show, Stake -> Stake -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stake -> Stake -> Bool
$c/= :: Stake -> Stake -> Bool
== :: Stake -> Stake -> Bool
$c== :: Stake -> Stake -> Bool
Eq, Stake -> ()
forall a. (a -> ()) -> NFData a
rnf :: Stake -> ()
$crnf :: Stake -> ()
NFData, 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
$cto :: forall x. Rep Stake x -> Stake
$cfrom :: forall x. Stake -> Rep Stake x
Generic, [Stake] -> Encoding
[Stake] -> Value
Stake -> Bool
Stake -> Encoding
Stake -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: Stake -> Bool
$comitField :: Stake -> Bool
toEncodingList :: [Stake] -> Encoding
$ctoEncodingList :: [Stake] -> Encoding
toJSONList :: [Stake] -> Value
$ctoJSONList :: [Stake] -> Value
toEncoding :: Stake -> Encoding
$ctoEncoding :: Stake -> Encoding
toJSON :: Stake -> Value
$ctoJSON :: Stake -> Value
ToJSON, Context -> Stake -> IO (Maybe ThunkInfo)
Proxy Stake -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Stake -> String
$cshowTypeOf :: Proxy Stake -> String
wNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
noThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Stake -> IO (Maybe ThunkInfo)
NoThunks, Typeable 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
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Stake] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy [Stake] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Stake -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Stake -> Size
encCBOR :: Stake -> Encoding
$cencCBOR :: Stake -> Encoding
EncCBOR)

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

sumAllStake :: Stake -> Coin
sumAllStake :: Stake -> Coin
sumAllStake = forall a. Compactible a => CompactForm a -> a
fromCompact 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 = forall (vv :: * -> *) v a (kv :: * -> *) k.
Vector vv v =>
(a -> v -> a) -> a -> VMap kv vv k v -> a
VMap.foldl forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty 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 forall a b. (a -> b) -> a -> b
$ 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
_ -> 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 forall a. Eq a => a -> a -> Bool
== 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) = 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 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 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 -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall t. Val t => t -> t -> t
(<+>) KeyHash 'StakePool
kh (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 forall a b. (a -> b) -> a -> b
$ Rational
factor1 forall a. Num a => a -> a -> a
* Rational
factor2
  where
    nonZeroZ0 :: NonZero Rational
nonZeroZ0 = forall a. Integral a => NonZero (Ratio a) -> NonZero (Ratio a)
recipNonZero forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => NonZero a -> NonZero (Ratio a)
toRatioNonZero forall a b. (a -> b) -> a -> b
$ forall a. Integral a => NonZero a -> NonZero Integer
toIntegerNonZero NonZero Word16
nOpt
    z0 :: Rational
z0 = forall a. NonZero a -> a
unNonZero NonZero Rational
nonZeroZ0
    sigma' :: Rational
sigma' = forall a. Ord a => a -> a -> a
min Rational
sigma Rational
z0
    p' :: Rational
p' = 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 forall a. Fractional a => a -> a -> a
/ (Rational
1 forall a. Num a => a -> a -> a
+ forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0)
    factor2 :: Rational
factor2 = Rational
sigma' forall a. Num a => a -> a -> a
+ Rational
p' forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
a0 forall a. Num a => a -> a -> a
* Rational
factor3
    factor3 :: Rational
factor3 = (Rational
sigma' forall a. Num a => a -> a -> a
- Rational
p' forall a. Num a => a -> a -> a
* Rational
factor4) forall a. Fractional a => a -> NonZero a -> a
/. NonZero Rational
nonZeroZ0
    factor4 :: Rational
factor4 = (Rational
z0 forall a. Num a => a -> a -> a
- Rational
sigma') 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L
    nOpt :: NonZero Word16
nOpt = (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppNOptL) 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapShot] -> ShowS
$cshowList :: [SnapShot] -> ShowS
show :: SnapShot -> String
$cshow :: SnapShot -> String
showsPrec :: Int -> SnapShot -> ShowS
$cshowsPrec :: Int -> SnapShot -> ShowS
Show, SnapShot -> SnapShot -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapShot -> SnapShot -> Bool
$c/= :: SnapShot -> SnapShot -> Bool
== :: SnapShot -> SnapShot -> Bool
$c== :: SnapShot -> SnapShot -> Bool
Eq, 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
$cto :: forall x. Rep SnapShot x -> SnapShot
$cfrom :: forall x. SnapShot -> Rep SnapShot x
Generic)

instance NoThunks SnapShot

instance NFData SnapShot

instance EncCBOR SnapShot where
  encCBOR :: SnapShot -> Encoding
encCBOR SnapShot {Stake
ssStake :: Stake
$sel:ssStake:SnapShot :: SnapShot -> Stake
ssStake, VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssDelegations:SnapShot :: SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations, VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
$sel:ssPoolParams:SnapShot :: SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams} =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Stake
ssStake
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations
      forall a. Semigroup a => a -> a -> a
<> 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 = forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"SnapShot" (forall a b. a -> b -> a
const Int
3) forall a b. (a -> b) -> a -> b
$ do
    Stake
ssStake <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall s t a b. Field1 s t a b => Lens s t a b
_1
    VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR (forall a b c. Monoid a => Lens' a b -> Lens' c b -> Lens' c a
toMemptyLens forall s t a b. Field1 s t a b => Lens s t a b
_1 forall s t a b. Field2 s t a b => Lens s t a b
_2)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShot {Stake
ssStake :: Stake
$sel:ssStake:SnapShot :: Stake
ssStake, VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations, VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
$sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams}

instance ToJSON SnapShot where
  toJSON :: SnapShot -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => SnapShot -> [a]
toSnapShotPair
  toEncoding :: SnapShot -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
ssPoolParams :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssDelegations :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssStake :: Stake
$sel:ssPoolParams:SnapShot :: SnapShot -> VMap VB VB (KeyHash 'StakePool) PoolParams
$sel:ssDelegations:SnapShot :: SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
$sel:ssStake:SnapShot :: SnapShot -> Stake
..} = SnapShot
ss
   in [ Key
"stake" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stake
ssStake
      , Key
"delegations" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations
      , Key
"poolParams" 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapShots] -> ShowS
$cshowList :: [SnapShots] -> ShowS
show :: SnapShots -> String
$cshow :: SnapShots -> String
showsPrec :: Int -> SnapShots -> ShowS
$cshowsPrec :: Int -> SnapShots -> ShowS
Show, SnapShots -> SnapShots -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapShots -> SnapShots -> Bool
$c/= :: SnapShots -> SnapShots -> Bool
== :: SnapShots -> SnapShots -> Bool
$c== :: SnapShots -> SnapShots -> Bool
Eq, 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
$cto :: forall x. Rep SnapShots x -> SnapShots
$cfrom :: forall x. SnapShots -> Rep SnapShots x
Generic)
  -- TODO: switch `AllowThunksIn` to `OnlyCheckWhnfNamed`
  deriving (Context -> SnapShots -> IO (Maybe ThunkInfo)
Proxy SnapShots -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SnapShots -> String
$cshowTypeOf :: Proxy SnapShots -> String
wNoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
noThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SnapShots -> IO (Maybe ThunkInfo)
NoThunks) via AllowThunksIn '["ssStakeMark", "ssStakeMarkPoolDistr"] SnapShots

instance NFData SnapShots

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

instance DecCBOR SnapShots where
  decCBOR :: forall s. Decoder s SnapShots
decCBOR = 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 = forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"SnapShots" (forall a b. a -> b -> a
const Int
4) forall a b. (a -> b) -> a -> b
$ do
    !SnapShot
ssStakeMark <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    SnapShot
ssStakeSet <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    SnapShot
ssStakeGo <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
    Coin
ssFee <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. DecCBOR a => Decoder s a
decCBOR
    let ssStakeMarkPoolDistr :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
ssStakeMark
    forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShots {SnapShot
ssStakeMark :: SnapShot
$sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark, PoolDistr
ssStakeMarkPoolDistr :: PoolDistr
$sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr, SnapShot
ssStakeSet :: SnapShot
$sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet, SnapShot
ssStakeGo :: SnapShot
$sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo, Coin
ssFee :: Coin
$sel:ssFee:SnapShots :: Coin
ssFee}

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

instance ToJSON SnapShots where
  toJSON :: SnapShots -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => SnapShots -> [a]
toSnapShotsPair
  toEncoding :: SnapShots -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
ssStakeMark :: SnapShot
$sel:ssStakeMark:SnapShots :: SnapShots -> SnapShot
ssStakeMark, SnapShot
ssStakeSet :: SnapShot
$sel:ssStakeSet:SnapShots :: SnapShots -> SnapShot
ssStakeSet, SnapShot
ssStakeGo :: SnapShot
$sel:ssStakeGo:SnapShots :: SnapShots -> SnapShot
ssStakeGo, Coin
ssFee :: Coin
$sel:ssFee:SnapShots :: SnapShots -> Coin
ssFee} = SnapShots
ss
   in [ Key
"pstakeMark" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeMark
      , Key
"pstakeSet" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeSet
      , Key
"pstakeGo" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot
ssStakeGo
      , Key
"feeSS" 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 forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty) forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v
VMap.empty 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 = 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 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 = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential 'Staking
cred (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake Stake
stake)
           in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith 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' (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 forall a b. (a -> b) -> a -> b
$ Word64
total 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 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
        ( 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
                  (forall a. Integral a => a -> Integer
toInteger Word64
word64 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
            (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)
        )
        (forall a. NonZero a -> a
unNonZero NonZero (CompactForm Coin)
nonZeroTotalCompact)

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

-- SnapShots

ssStakeMarkL :: Lens' SnapShots SnapShot
ssStakeMarkL :: Lens' SnapShots SnapShot
ssStakeMarkL = 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 {$sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark = SnapShot
u})

ssStakeMarkPoolDistrL :: Lens' SnapShots PoolDistr
ssStakeMarkPoolDistrL :: Lens' SnapShots PoolDistr
ssStakeMarkPoolDistrL = 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 {$sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr = PoolDistr
u})

ssStakeSetL :: Lens' SnapShots SnapShot
ssStakeSetL :: Lens' SnapShots SnapShot
ssStakeSetL = 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 {$sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet = SnapShot
u})

ssStakeGoL :: Lens' SnapShots SnapShot
ssStakeGoL :: Lens' SnapShots SnapShot
ssStakeGoL = 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 {$sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo = SnapShot
u})

ssFeeL :: Lens' SnapShots Coin
ssFeeL :: Lens' SnapShots Coin
ssFeeL = 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 {$sel:ssFee:SnapShots :: Coin
ssFee = Coin
u})

-- SnapShot

ssStakeL :: Lens' SnapShot Stake
ssStakeL :: Lens' SnapShot Stake
ssStakeL = 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 {$sel:ssStake:SnapShot :: Stake
ssStake = Stake
u})

ssStakeDistrL :: Lens' SnapShot (VMap VB VP (Credential 'Staking) (CompactForm Coin))
ssStakeDistrL :: Lens'
  SnapShot (VMap VB VP (Credential 'Staking) (CompactForm Coin))
ssStakeDistrL = 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 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 {$sel:ssStake:SnapShot :: Stake
ssStake = VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
Stake VMap VB VP (Credential 'Staking) (CompactForm Coin)
u})

ssDelegationsL :: Lens' SnapShot (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
ssDelegationsL :: Lens'
  SnapShot (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool))
ssDelegationsL = 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 {$sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations = VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
u})

ssPoolParamsL :: Lens' SnapShot (VMap VB VB (KeyHash 'StakePool) PoolParams)
ssPoolParamsL :: Lens' SnapShot (VMap VB VB (KeyHash 'StakePool) PoolParams)
ssPoolParamsL = 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 {$sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool) PoolParams
ssPoolParams = VMap VB VB (KeyHash 'StakePool) PoolParams
u})