{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Cardano.Ledger.State.Stake (
EraStake (..),
CanGetInstantStake (..),
CanSetInstantStake (..),
snapShotFromInstantStake,
resolveActiveInstantStakeCredentials,
)
where
import Cardano.Ledger.Binary (
DecShareCBOR (..),
EncCBOR (..),
Interns,
)
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.State.CertState (DState (..), PState (..))
import Cardano.Ledger.State.SnapShots
import Cardano.Ledger.State.UTxO
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Data.Aeson (ToJSON)
import Data.Default (Default)
import Data.Functor.Identity
import Data.Kind (Type)
import qualified Data.Map.Merge.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.VMap as VMap
import Lens.Micro
import NoThunks.Class (NoThunks)
class
( Era era
, Eq (InstantStake era)
, Show (InstantStake era)
, Monoid (InstantStake era)
, Default (InstantStake era)
, NFData (InstantStake era)
, NoThunks (InstantStake era)
, ToJSON (InstantStake era)
, EncCBOR (InstantStake era)
, DecShareCBOR (InstantStake era)
, Share (InstantStake era) ~ Interns (Credential 'Staking)
) =>
EraStake era
where
type InstantStake era = (r :: Type) | r -> era
instantStakeCredentialsL :: Lens' (InstantStake era) (Map (Credential 'Staking) (CompactForm Coin))
addInstantStake :: UTxO era -> InstantStake era -> InstantStake era
deleteInstantStake :: UTxO era -> InstantStake era -> InstantStake era
resolveInstantStake :: InstantStake era -> UM.UMap -> Stake
snapShotFromInstantStake :: EraStake era => InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake :: forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
iStake DState era
dState PState {Map (KeyHash 'StakePool) PoolParams
psStakePoolParams :: forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams} =
Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> SnapShot
SnapShot Stake
stake VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs (forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (KeyHash 'StakePool) PoolParams
psStakePoolParams)
where
!stake :: Stake
stake = forall era. EraStake era => InstantStake era -> UMap -> Stake
resolveInstantStake InstantStake era
iStake UMap
um
!delegs :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs = forall k v. UView k v -> VMap VB VB k v
UM.unUnifyToVMap (UMap -> UView (Credential 'Staking) (KeyHash 'StakePool)
UM.SPoolUView UMap
um)
!um :: UMap
um = forall era. DState era -> UMap
dsUnified DState era
dState
{-# INLINEABLE snapShotFromInstantStake #-}
class CanGetInstantStake t where
instantStakeG :: SimpleGetter (t era) (InstantStake era)
default instantStakeG :: CanSetInstantStake t => SimpleGetter (t era) (InstantStake era)
instantStakeG = forall (t :: * -> *) era.
CanSetInstantStake t =>
Lens' (t era) (InstantStake era)
instantStakeL
{-# INLINE instantStakeG #-}
class CanGetInstantStake t => CanSetInstantStake t where
instantStakeL :: Lens' (t era) (InstantStake era)
resolveActiveInstantStakeCredentials ::
EraStake era =>
InstantStake era -> UM.UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials :: forall era.
EraStake era =>
InstantStake era
-> UMap -> Map (Credential 'Staking) (CompactForm Coin)
resolveActiveInstantStakeCredentials InstantStake era
instantStake (UM.UMap Map (Credential 'Staking) UMElem
triplesMap Map Ptr (Credential 'Staking)
_) =
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Map.mapMaybeMissing (forall a b. a -> b -> a
const UMElem -> Maybe (CompactForm Coin)
getNonZeroActiveReward))
(forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
Map.zipWithMaybeAMatched forall {p}.
p
-> CompactForm Coin
-> UMElem
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake)
(InstantStake era
instantStake forall s a. s -> Getting a s a -> a
^. forall era.
EraStake era =>
Lens'
(InstantStake era) (Map (Credential 'Staking) (CompactForm Coin))
instantStakeCredentialsL)
Map (Credential 'Staking) UMElem
triplesMap
where
getActiveReward :: UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem = do
RDPair
rd <- UMElem -> Maybe RDPair
UM.umElemRDActive UMElem
umElem
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! RDPair -> CompactForm Coin
UM.rdReward RDPair
rd
{-# INLINE getActiveReward #-}
getNonZeroActiveReward :: UMElem -> Maybe (CompactForm Coin)
getNonZeroActiveReward UMElem
umElem = do
CompactForm Coin
reward <- UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem
CompactForm Coin
reward forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CompactForm Coin
reward forall a. Ord a => a -> a -> Bool
> forall a. Monoid a => a
mempty)
{-# INLINE getNonZeroActiveReward #-}
addInstantActiveStake :: p
-> CompactForm Coin
-> UMElem
-> Identity (Maybe (CompactForm Coin))
addInstantActiveStake p
_ CompactForm Coin
stake UMElem
umElem = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ do
CompactForm Coin
reward <- UMElem -> Maybe (CompactForm Coin)
getActiveReward UMElem
umElem
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! CompactForm Coin
stake forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
reward
{-# INLINE addInstantActiveStake #-}
{-# INLINEABLE resolveActiveInstantStakeCredentials #-}