{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Ledger.State.SnapShots (
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 (..))
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 #-}
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) =
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
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 =
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
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
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
]
data SnapShots = SnapShots
{ SnapShots -> SnapShot
ssStakeMark :: SnapShot
, SnapShots -> PoolDistr
ssStakeMarkPoolDistr :: PoolDistr
, 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)
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
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
_) =
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)
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
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)
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})
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})