{-# 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 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.Crypto (Crypto)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
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.Typeable
import Data.VMap as VMap
import GHC.Generics (Generic)
import GHC.Word (Word64)
import Lens.Micro (Lens', lens, (^.), _1, _2)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
import Numeric.Natural (Natural)
newtype Stake c = Stake
{ forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake :: VMap VB VP (Credential 'Staking c) (CompactForm Coin)
}
deriving (Int -> Stake c -> ShowS
forall c. Int -> Stake c -> ShowS
forall c. [Stake c] -> ShowS
forall c. Stake c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stake c] -> ShowS
$cshowList :: forall c. [Stake c] -> ShowS
show :: Stake c -> String
$cshow :: forall c. Stake c -> String
showsPrec :: Int -> Stake c -> ShowS
$cshowsPrec :: forall c. Int -> Stake c -> ShowS
Show, Stake c -> Stake c -> Bool
forall c. Stake c -> Stake c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stake c -> Stake c -> Bool
$c/= :: forall c. Stake c -> Stake c -> Bool
== :: Stake c -> Stake c -> Bool
$c== :: forall c. Stake c -> Stake c -> Bool
Eq, Stake c -> ()
forall c. Stake c -> ()
forall a. (a -> ()) -> NFData a
rnf :: Stake c -> ()
$crnf :: forall c. Stake c -> ()
NFData, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (Stake c) x -> Stake c
forall c x. Stake c -> Rep (Stake c) x
$cto :: forall c x. Rep (Stake c) x -> Stake c
$cfrom :: forall c x. Stake c -> Rep (Stake c) x
Generic, [Stake c] -> Encoding
[Stake c] -> Value
Stake c -> Bool
Stake c -> Encoding
Stake c -> Value
forall c. Crypto c => [Stake c] -> Encoding
forall c. Crypto c => [Stake c] -> Value
forall c. Crypto c => Stake c -> Bool
forall c. Crypto c => Stake c -> Encoding
forall c. Crypto c => Stake c -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: Stake c -> Bool
$comitField :: forall c. Crypto c => Stake c -> Bool
toEncodingList :: [Stake c] -> Encoding
$ctoEncodingList :: forall c. Crypto c => [Stake c] -> Encoding
toJSONList :: [Stake c] -> Value
$ctoJSONList :: forall c. Crypto c => [Stake c] -> Value
toEncoding :: Stake c -> Encoding
$ctoEncoding :: forall c. Crypto c => Stake c -> Encoding
toJSON :: Stake c -> Value
$ctoJSON :: forall c. Crypto c => Stake c -> Value
ToJSON)
deriving newtype instance Typeable c => NoThunks (Stake c)
deriving newtype instance
Crypto c => EncCBOR (Stake c)
instance Crypto c => DecShareCBOR (Stake c) where
type Share (Stake c) = Share (VMap VB VP (Credential 'Staking c) (CompactForm Coin))
getShare :: Stake c -> Share (Stake c)
getShare = forall a. DecShareCBOR a => a -> Share a
getShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake
decShareCBOR :: forall s. Share (Stake c) -> Decoder s (Stake c)
decShareCBOR = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
Stake forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. DecShareCBOR a => Share a -> Decoder s a
decShareCBOR
sumAllStake :: Stake c -> Coin
sumAllStake :: forall c. Stake c -> Coin
sumAllStake = forall a. Compactible a => CompactForm a -> a
fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Stake c -> CompactForm Coin
sumAllStakeCompact
{-# INLINE sumAllStake #-}
sumAllStakeCompact :: Stake c -> CompactForm Coin
sumAllStakeCompact :: forall c. Stake c -> 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
. forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake
{-# INLINE sumAllStakeCompact #-}
poolStake ::
KeyHash 'StakePool c ->
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c) ->
Stake c ->
Stake c
poolStake :: forall c.
KeyHash 'StakePool c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Stake c
poolStake KeyHash 'StakePool c
hk VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs (Stake VMap VB VP (Credential 'Staking c) (CompactForm Coin)
stake) =
forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
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 c
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 c
cred VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just KeyHash 'StakePool c
hk) VMap VB VP (Credential 'Staking c) (CompactForm Coin)
stake
sumStakePerPool ::
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c) ->
Stake c ->
Map (KeyHash 'StakePool c) Coin
sumStakePerPool :: forall c.
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c -> Map (KeyHash 'StakePool c) Coin
sumStakePerPool VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs (Stake VMap VB VP (Credential 'Staking c) (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 c) Coin
-> Credential 'Staking c
-> CompactForm Coin
-> Map (KeyHash 'StakePool c) Coin
accum forall k a. Map k a
Map.empty VMap VB VP (Credential 'Staking c) (CompactForm Coin)
stake
where
accum :: Map (KeyHash 'StakePool c) Coin
-> Credential 'Staking c
-> CompactForm Coin
-> Map (KeyHash 'StakePool c) Coin
accum !Map (KeyHash 'StakePool c) Coin
acc Credential 'Staking c
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 c
cred VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs of
Maybe (KeyHash 'StakePool c)
Nothing -> Map (KeyHash 'StakePool c) Coin
acc
Just KeyHash 'StakePool c
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 c
kh (forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
compactCoin) Map (KeyHash 'StakePool c) Coin
acc
maxPool' ::
NonNegativeInterval ->
Natural ->
Coin ->
Rational ->
Rational ->
Coin
maxPool' :: NonNegativeInterval
-> Natural -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
a0 Natural
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 Natural
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
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
-> Natural -> Coin -> Rational -> Rational -> Coin
maxPool' NonNegativeInterval
a0 Natural
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 :: Natural
nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL
data SnapShot c = SnapShot
{ forall c. SnapShot c -> Stake c
ssStake :: !(Stake c)
, forall c.
SnapShot c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations :: !(VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c))
, forall c.
SnapShot c -> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams :: !(VMap VB VB (KeyHash 'StakePool c) (PoolParams c))
}
deriving (Int -> SnapShot c -> ShowS
forall c. Int -> SnapShot c -> ShowS
forall c. [SnapShot c] -> ShowS
forall c. SnapShot c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapShot c] -> ShowS
$cshowList :: forall c. [SnapShot c] -> ShowS
show :: SnapShot c -> String
$cshow :: forall c. SnapShot c -> String
showsPrec :: Int -> SnapShot c -> ShowS
$cshowsPrec :: forall c. Int -> SnapShot c -> ShowS
Show, SnapShot c -> SnapShot c -> Bool
forall c. SnapShot c -> SnapShot c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapShot c -> SnapShot c -> Bool
$c/= :: forall c. SnapShot c -> SnapShot c -> Bool
== :: SnapShot c -> SnapShot c -> Bool
$c== :: forall c. SnapShot c -> SnapShot c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (SnapShot c) x -> SnapShot c
forall c x. SnapShot c -> Rep (SnapShot c) x
$cto :: forall c x. Rep (SnapShot c) x -> SnapShot c
$cfrom :: forall c x. SnapShot c -> Rep (SnapShot c) x
Generic)
instance Typeable c => NoThunks (SnapShot c)
instance NFData (SnapShot c)
instance
Crypto c =>
EncCBOR (SnapShot c)
where
encCBOR :: SnapShot c -> Encoding
encCBOR
SnapShot
{ $sel:ssStake:SnapShot :: forall c. SnapShot c -> Stake c
ssStake = Stake c
s
, $sel:ssDelegations:SnapShot :: forall c.
SnapShot c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations = VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
d
, $sel:ssPoolParams:SnapShot :: forall c.
SnapShot c -> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams = VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
p
} =
Word -> Encoding
encodeListLen Word
3
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Stake c
s
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
d
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
p
instance Crypto c => DecShareCBOR (SnapShot c) where
type
Share (SnapShot c) =
(Interns (Credential 'Staking c), Interns (KeyHash 'StakePool c))
decSharePlusCBOR :: forall s. StateT (Share (SnapShot c)) (Decoder s) (SnapShot c)
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 c
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 c) (KeyHash 'StakePool c)
ssDelegations <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
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 c
ssStake :: Stake c
$sel:ssStake:SnapShot :: Stake c
ssStake, VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
$sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations, VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams :: VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
$sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams}
instance Crypto c => ToJSON (SnapShot c) where
toJSON :: SnapShot c -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c. (KeyValue e a, Crypto c) => SnapShot c -> [a]
toSnapShotPair
toEncoding :: SnapShot c -> 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 c. (KeyValue e a, Crypto c) => SnapShot c -> [a]
toSnapShotPair
toSnapShotPair :: (KeyValue e a, Crypto c) => SnapShot c -> [a]
toSnapShotPair :: forall e a c. (KeyValue e a, Crypto c) => SnapShot c -> [a]
toSnapShotPair ss :: SnapShot c
ss@(SnapShot Stake c
_ VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
_ VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
_) =
let SnapShot {VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
Stake c
ssPoolParams :: VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssDelegations :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssStake :: Stake c
$sel:ssPoolParams:SnapShot :: forall c.
SnapShot c -> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
$sel:ssDelegations:SnapShot :: forall c.
SnapShot c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
$sel:ssStake:SnapShot :: forall c. SnapShot c -> Stake c
..} = SnapShot c
ss
in [ Key
"stake" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Stake c
ssStake
, Key
"delegations" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations
, Key
"poolParams" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams
]
data SnapShots c = SnapShots
{ forall c. SnapShots c -> SnapShot c
ssStakeMark :: SnapShot c
, forall c. SnapShots c -> PoolDistr c
ssStakeMarkPoolDistr :: PoolDistr c
, forall c. SnapShots c -> SnapShot c
ssStakeSet :: !(SnapShot c)
, forall c. SnapShots c -> SnapShot c
ssStakeGo :: !(SnapShot c)
, forall c. SnapShots c -> Coin
ssFee :: !Coin
}
deriving (Int -> SnapShots c -> ShowS
forall c. Int -> SnapShots c -> ShowS
forall c. [SnapShots c] -> ShowS
forall c. SnapShots c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapShots c] -> ShowS
$cshowList :: forall c. [SnapShots c] -> ShowS
show :: SnapShots c -> String
$cshow :: forall c. SnapShots c -> String
showsPrec :: Int -> SnapShots c -> ShowS
$cshowsPrec :: forall c. Int -> SnapShots c -> ShowS
Show, SnapShots c -> SnapShots c -> Bool
forall c. SnapShots c -> SnapShots c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapShots c -> SnapShots c -> Bool
$c/= :: forall c. SnapShots c -> SnapShots c -> Bool
== :: SnapShots c -> SnapShots c -> Bool
$c== :: forall c. SnapShots c -> SnapShots c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (SnapShots c) x -> SnapShots c
forall c x. SnapShots c -> Rep (SnapShots c) x
$cto :: forall c x. Rep (SnapShots c) x -> SnapShots c
$cfrom :: forall c x. SnapShots c -> Rep (SnapShots c) x
Generic)
deriving (Context -> SnapShots c -> IO (Maybe ThunkInfo)
Proxy (SnapShots c) -> String
forall c.
Typeable c =>
Context -> SnapShots c -> IO (Maybe ThunkInfo)
forall c. Typeable c => Proxy (SnapShots c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (SnapShots c) -> String
$cshowTypeOf :: forall c. Typeable c => Proxy (SnapShots c) -> String
wNoThunks :: Context -> SnapShots c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
Typeable c =>
Context -> SnapShots c -> IO (Maybe ThunkInfo)
noThunks :: Context -> SnapShots c -> IO (Maybe ThunkInfo)
$cnoThunks :: forall c.
Typeable c =>
Context -> SnapShots c -> IO (Maybe ThunkInfo)
NoThunks) via AllowThunksIn '["ssStakeMark", "ssStakeMarkPoolDistr"] (SnapShots c)
instance NFData (SnapShots c)
instance
Crypto c =>
EncCBOR (SnapShots c)
where
encCBOR :: SnapShots c -> Encoding
encCBOR (SnapShots {SnapShot c
ssStakeMark :: SnapShot c
$sel:ssStakeMark:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeMark, SnapShot c
ssStakeSet :: SnapShot c
$sel:ssStakeSet:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeSet, SnapShot c
ssStakeGo :: SnapShot c
$sel:ssStakeGo:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeGo, Coin
ssFee :: Coin
$sel:ssFee:SnapShots :: forall c. SnapShots c -> Coin
ssFee}) =
Word -> Encoding
encodeListLen Word
4
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot c
ssStakeMark
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot c
ssStakeSet
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR SnapShot c
ssStakeGo
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Coin
ssFee
instance Crypto c => DecCBOR (SnapShots c) where
decCBOR :: forall s. Decoder s (SnapShots c)
decCBOR = forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR
instance Crypto c => DecShareCBOR (SnapShots c) where
type Share (SnapShots c) = Share (SnapShot c)
decSharePlusCBOR :: forall s. StateT (Share (SnapShots c)) (Decoder s) (SnapShots c)
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 c
ssStakeMark <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
SnapShot c
ssStakeSet <- forall a s. DecShareCBOR a => StateT (Share a) (Decoder s) a
decSharePlusCBOR
SnapShot c
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 c
ssStakeMarkPoolDistr = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot c
ssStakeMark
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShots {SnapShot c
ssStakeMark :: SnapShot c
$sel:ssStakeMark:SnapShots :: SnapShot c
ssStakeMark, PoolDistr c
ssStakeMarkPoolDistr :: PoolDistr c
$sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr c
ssStakeMarkPoolDistr, SnapShot c
ssStakeSet :: SnapShot c
$sel:ssStakeSet:SnapShots :: SnapShot c
ssStakeSet, SnapShot c
ssStakeGo :: SnapShot c
$sel:ssStakeGo:SnapShots :: SnapShot c
ssStakeGo, Coin
ssFee :: Coin
$sel:ssFee:SnapShots :: Coin
ssFee}
instance Default (SnapShots c) where
def :: SnapShots c
def = forall c. SnapShots c
emptySnapShots
instance Crypto c => ToJSON (SnapShots c) where
toJSON :: SnapShots c -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a crypto.
(KeyValue e a, Crypto crypto) =>
SnapShots crypto -> [a]
toSnapShotsPair
toEncoding :: SnapShots c -> 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 crypto.
(KeyValue e a, Crypto crypto) =>
SnapShots crypto -> [a]
toSnapShotsPair
toSnapShotsPair :: (KeyValue e a, Crypto crypto) => SnapShots crypto -> [a]
toSnapShotsPair :: forall e a crypto.
(KeyValue e a, Crypto crypto) =>
SnapShots crypto -> [a]
toSnapShotsPair ss :: SnapShots crypto
ss@(SnapShots !SnapShot crypto
_ PoolDistr crypto
_ SnapShot crypto
_ SnapShot crypto
_ Coin
_) =
let SnapShots {SnapShot crypto
ssStakeMark :: SnapShot crypto
$sel:ssStakeMark:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeMark, SnapShot crypto
ssStakeSet :: SnapShot crypto
$sel:ssStakeSet:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeSet, SnapShot crypto
ssStakeGo :: SnapShot crypto
$sel:ssStakeGo:SnapShots :: forall c. SnapShots c -> SnapShot c
ssStakeGo, Coin
ssFee :: Coin
$sel:ssFee:SnapShots :: forall c. SnapShots c -> Coin
ssFee} = SnapShots crypto
ss
in [ Key
"pstakeMark" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot crypto
ssStakeMark
, Key
"pstakeSet" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot crypto
ssStakeSet
, Key
"pstakeGo" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapShot crypto
ssStakeGo
, Key
"feeSS" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
ssFee
]
emptySnapShot :: SnapShot c
emptySnapShot :: forall c. SnapShot c
emptySnapShot = forall c.
Stake c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
-> SnapShot c
SnapShot (forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
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 c
emptySnapShots :: forall c. SnapShots c
emptySnapShots =
forall c.
SnapShot c
-> PoolDistr c -> SnapShot c -> SnapShot c -> Coin -> SnapShots c
SnapShots forall c. SnapShot c
emptySnapShot (forall c. SnapShot c -> PoolDistr c
calculatePoolDistr forall c. SnapShot c
emptySnapShot) forall c. SnapShot c
emptySnapShot forall c. SnapShot c
emptySnapShot (Integer -> Coin
Coin Integer
0)
calculatePoolStake ::
(KeyHash 'StakePool c -> Bool) ->
VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c) ->
Stake c ->
Map.Map (KeyHash 'StakePool c) Word64
calculatePoolStake :: forall c.
(KeyHash 'StakePool c -> Bool)
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Map (KeyHash 'StakePool c) Word64
calculatePoolStake KeyHash 'StakePool c -> Bool
includeHash VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs Stake c
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 c) Word64
-> Credential 'Staking c
-> KeyHash 'StakePool c
-> Map (KeyHash 'StakePool c) Word64
accum forall k a. Map k a
Map.empty VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs
where
accum :: Map (KeyHash 'StakePool c) Word64
-> Credential 'Staking c
-> KeyHash 'StakePool c
-> Map (KeyHash 'StakePool c) Word64
accum Map (KeyHash 'StakePool c) Word64
ans Credential 'Staking c
cred KeyHash 'StakePool c
keyHash =
if KeyHash 'StakePool c -> Bool
includeHash KeyHash 'StakePool c
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 c
cred (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake Stake c
stake) of
Maybe (CompactForm Coin)
Nothing -> Map (KeyHash 'StakePool c) 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 c
keyHash Word64
c Map (KeyHash 'StakePool c) Word64
ans
else Map (KeyHash 'StakePool c) Word64
ans
calculatePoolDistr :: SnapShot c -> PoolDistr c
calculatePoolDistr :: forall c. SnapShot c -> PoolDistr c
calculatePoolDistr = forall c.
(KeyHash 'StakePool c -> Bool) -> SnapShot c -> PoolDistr c
calculatePoolDistr' (forall a b. a -> b -> a
const Bool
True)
calculatePoolDistr' :: forall c. (KeyHash 'StakePool c -> Bool) -> SnapShot c -> PoolDistr c
calculatePoolDistr' :: forall c.
(KeyHash 'StakePool c -> Bool) -> SnapShot c -> PoolDistr c
calculatePoolDistr' KeyHash 'StakePool c -> Bool
includeHash (SnapShot Stake c
stake VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
poolParams) =
let total :: CompactForm Coin
total = forall c. Stake c -> CompactForm Coin
sumAllStakeCompact Stake c
stake
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 c) Word64
poolStakeMap = forall c.
(KeyHash 'StakePool c -> Bool)
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Map (KeyHash 'StakePool c) Word64
calculatePoolStake KeyHash 'StakePool c -> Bool
includeHash VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
delegs Stake c
stake
in forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
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 c
poolparam ->
forall c.
Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF c
-> IndividualPoolStake c
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)
(forall c. PoolParams c -> VRFVerKeyHash 'StakePoolVRF c
ppVrf PoolParams c
poolparam)
)
Map (KeyHash 'StakePool c) 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 c) (PoolParams c)
poolParams)
)
CompactForm Coin
nonZeroTotalCompact
ssStakeMarkL :: Lens' (SnapShots c) (SnapShot c)
ssStakeMarkL :: forall c. Lens' (SnapShots c) (SnapShot c)
ssStakeMarkL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShots c -> SnapShot c
ssStakeMark (\SnapShots c
ds SnapShot c
u -> SnapShots c
ds {$sel:ssStakeMark:SnapShots :: SnapShot c
ssStakeMark = SnapShot c
u})
ssStakeMarkPoolDistrL :: Lens' (SnapShots c) (PoolDistr c)
ssStakeMarkPoolDistrL :: forall c. Lens' (SnapShots c) (PoolDistr c)
ssStakeMarkPoolDistrL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShots c -> PoolDistr c
ssStakeMarkPoolDistr (\SnapShots c
ds PoolDistr c
u -> SnapShots c
ds {$sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr c
ssStakeMarkPoolDistr = PoolDistr c
u})
ssStakeSetL :: Lens' (SnapShots c) (SnapShot c)
ssStakeSetL :: forall c. Lens' (SnapShots c) (SnapShot c)
ssStakeSetL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShots c -> SnapShot c
ssStakeSet (\SnapShots c
ds SnapShot c
u -> SnapShots c
ds {$sel:ssStakeSet:SnapShots :: SnapShot c
ssStakeSet = SnapShot c
u})
ssStakeGoL :: Lens' (SnapShots c) (SnapShot c)
ssStakeGoL :: forall c. Lens' (SnapShots c) (SnapShot c)
ssStakeGoL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShots c -> SnapShot c
ssStakeGo (\SnapShots c
ds SnapShot c
u -> SnapShots c
ds {$sel:ssStakeGo:SnapShots :: SnapShot c
ssStakeGo = SnapShot c
u})
ssFeeL :: Lens' (SnapShots c) Coin
ssFeeL :: forall c. Lens' (SnapShots c) Coin
ssFeeL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShots c -> Coin
ssFee (\SnapShots c
ds Coin
u -> SnapShots c
ds {$sel:ssFee:SnapShots :: Coin
ssFee = Coin
u})
ssStakeL :: Lens' (SnapShot c) (Stake c)
ssStakeL :: forall c. Lens' (SnapShot c) (Stake c)
ssStakeL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. SnapShot c -> Stake c
ssStake (\SnapShot c
ds Stake c
u -> SnapShot c
ds {$sel:ssStake:SnapShot :: Stake c
ssStake = Stake c
u})
ssStakeDistrL :: Lens' (SnapShot c) (VMap VB VP (Credential 'Staking c) (CompactForm Coin))
ssStakeDistrL :: forall c.
Lens'
(SnapShot c)
(VMap VB VP (Credential 'Staking c) (CompactForm Coin))
ssStakeDistrL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. SnapShot c -> Stake c
ssStake) (\SnapShot c
ds VMap VB VP (Credential 'Staking c) (CompactForm Coin)
u -> SnapShot c
ds {$sel:ssStake:SnapShot :: Stake c
ssStake = forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
Stake VMap VB VP (Credential 'Staking c) (CompactForm Coin)
u})
ssDelegationsL :: Lens' (SnapShot c) (VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c))
ssDelegationsL :: forall c.
Lens'
(SnapShot c)
(VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c))
ssDelegationsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
SnapShot c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations (\SnapShot c
ds VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
u -> SnapShot c
ds {$sel:ssDelegations:SnapShot :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations = VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
u})
ssPoolParamsL :: Lens' (SnapShot c) (VMap VB VB (KeyHash 'StakePool c) (PoolParams c))
ssPoolParamsL :: forall c.
Lens'
(SnapShot c) (VMap VB VB (KeyHash 'StakePool c) (PoolParams c))
ssPoolParamsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
SnapShot c -> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams (\SnapShot c
ds VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
u -> SnapShot c
ds {$sel:ssPoolParams:SnapShot :: VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
ssPoolParams = VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
u})