{-# 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.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.Class (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)

-- | Type of stake as map from hash key to coins associated.
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 #-}

-- | Get stake of one pool
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) =
  -- Stake $ (eval (dom (delegs ▷ setSingleton hk) ◁ 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

-- | Calculate maximal pool reward
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

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

-- | Snapshot of the stake distribution.
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
      ]

-- | 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 c = SnapShots
  { forall c. SnapShots c -> SnapShot c
ssStakeMark :: SnapShot c -- Lazy on purpose
  , forall c. SnapShots c -> PoolDistr c
ssStakeMarkPoolDistr :: PoolDistr c -- Lazy on purpose
  , 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)
  -- TODO: switch `AllowThunksIn` to `OnlyCheckWhnfNamed`
  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
      -- We intentionaly do not serialize the redundant ssStakeMarkPoolDistr
      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
_) =
  -- ssStakeMarkPoolDistr is omitted on purpose
  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)

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

-- | Sum up the Coin (as CompactForm Coin = Word64) for each StakePool
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
      -- 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 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
-> Hash c (VerKeyVRF 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 -> Hash c (VerKeyVRF 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

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

-- SnapShots

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

-- SnapShot

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