{-# 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 StandaloneDeriving #-}
{-# 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.EpochBoundary (
  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)
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  Interns,
  decNoShareCBOR,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  encodeListLen,
  toMemptyLens,
 )
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm (..),
  coinToRational,
  rationalToCoinViaFloor,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.PoolParams (PoolParams (ppVrf))
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.Ratio ((%))
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 hash key to coins associated.
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

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 ->
  Word16 ->
  Coin ->
  Rational ->
  Rational ->
  Coin
maxPool' :: NonNegativeInterval
-> Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
a0 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
    z0 :: Rational
z0 = Integer
1 forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
nOpt
    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 = 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 -> a -> a
/ Rational
z0
    factor4 :: Rational
factor4 = (Rational
z0 forall a. Num a => a -> a -> a
- Rational
sigma') forall a. Fractional a => a -> a -> a
/ Rational
z0

-- | 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
-> Word16 -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
a0 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 :: Word16
nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppNOptL

-- | 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 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 (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake Stake
stake) of
          Maybe (CompactForm Coin)
Nothing -> Map (KeyHash 'StakePool) Word64
ans
          Just (CompactCoin Word64
c) -> 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 total :: CompactForm Coin
total = Stake -> CompactForm Coin
sumAllStakeCompact Stake
stake
      -- total could be zero (in particular when shrinking)
      nonZeroTotalCompact :: CompactForm Coin
nonZeroTotalCompact = if CompactForm Coin
total forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then Word64 -> CompactForm Coin
CompactCoin Word64
1 else CompactForm Coin
total
      nonZeroTotalInteger :: Integer
nonZeroTotalInteger = Coin -> Integer
unCoin forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => CompactForm a -> a
fromCompact 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 -> a -> Ratio a
% 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)
        )
        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})