{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Cardano.Ledger.Shelley.LedgerState.IncrementalStake (
applyRUpd,
applyRUpdFiltered,
smartUTxOState,
filterAllRewards,
FilteredRewards (..),
)
where
import Cardano.Ledger.BaseTypes (ProtVer)
import Cardano.Ledger.Coin (
Coin (..),
addDeltaCoin,
)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.LedgerState.Types
import Cardano.Ledger.Shelley.RewardUpdate (RewardUpdate (..))
import Cardano.Ledger.Shelley.Rewards (
aggregateCompactRewards,
aggregateRewards,
filterRewards,
)
import Cardano.Ledger.State
import Cardano.Ledger.UMap (
member,
)
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData (rnf), deepseq)
import Data.Foldable (fold)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Lens.Micro
smartUTxOState ::
EraStake era =>
PParams era ->
UTxO era ->
Coin ->
Coin ->
GovState era ->
Coin ->
UTxOState era
smartUTxOState :: forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
_pp UTxO era
utxo Coin
c1 Coin
c2 GovState era
st =
forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> InstantStake era
-> Coin
-> UTxOState era
UTxOState
UTxO era
utxo
Coin
c1
Coin
c2
GovState era
st
(forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake UTxO era
utxo forall a. Monoid a => a
mempty)
applyRUpd ::
(EraGov era, EraCertState era) =>
RewardUpdate ->
EpochState era ->
EpochState era
applyRUpd :: forall era.
(EraGov era, EraCertState era) =>
RewardUpdate -> EpochState era -> EpochState era
applyRUpd RewardUpdate
ru EpochState era
es =
let (!EpochState era
es', FilteredRewards era
_) = forall era.
(EraGov era, EraCertState era) =>
RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate
ru EpochState era
es
in EpochState era
es'
applyRUpdFiltered ::
(EraGov era, EraCertState era) =>
RewardUpdate ->
EpochState era ->
(EpochState era, FilteredRewards era)
applyRUpdFiltered :: forall era.
(EraGov era, EraCertState era) =>
RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered
RewardUpdate
ru
es :: EpochState era
es@(EpochState AccountState
as LedgerState era
ls SnapShots
ss NonMyopic
_nm) = (EpochState era
epochStateAns, FilteredRewards era
filteredRewards)
where
!epochStateAns :: EpochState era
epochStateAns =
forall era.
AccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState AccountState
as' LedgerState era
ls' SnapShots
ss NonMyopic
nm'
forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
dpState :: CertState era
dpState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
dState :: DState era
dState = CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
prevPParams :: PParams era
prevPParams = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
prevProVer :: ProtVer
prevProVer = PParams era
prevPParams forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
filteredRewards :: FilteredRewards era
filteredRewards@FilteredRewards
{ Map (Credential 'Staking) (Set Reward)
frRegistered :: forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered :: Map (Credential 'Staking) (Set Reward)
frRegistered
, Coin
frTotalUnregistered :: forall era. FilteredRewards era -> Coin
frTotalUnregistered :: Coin
frTotalUnregistered
} = forall era.
Map (Credential 'Staking) (Set Reward)
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' (RewardUpdate -> Map (Credential 'Staking) (Set Reward)
rs RewardUpdate
ru) ProtVer
prevProVer DState era
dState
registeredAggregated :: Map (Credential 'Staking) (CompactForm Coin)
registeredAggregated = ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (CompactForm Coin)
aggregateCompactRewards ProtVer
prevProVer Map (Credential 'Staking) (Set Reward)
frRegistered
as' :: AccountState
as' =
AccountState
as
{ asTreasury :: Coin
asTreasury = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
asTreasury AccountState
as) (RewardUpdate -> DeltaCoin
deltaT RewardUpdate
ru) forall a. Semigroup a => a -> a -> a
<> Coin
frTotalUnregistered
, asReserves :: Coin
asReserves = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
asReserves AccountState
as) (RewardUpdate -> DeltaCoin
deltaR RewardUpdate
ru)
}
ls' :: LedgerState era
ls' =
LedgerState era
ls
forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) Coin
utxosFeesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coin -> DeltaCoin -> Coin
`addDeltaCoin` RewardUpdate -> DeltaCoin
deltaF RewardUpdate
ru)
forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
dState UView (Credential 'Staking) RDPair
-> Map (Credential 'Staking) (CompactForm Coin) -> UMap
UM.∪+ Map (Credential 'Staking) (CompactForm Coin)
registeredAggregated)
nm' :: NonMyopic
nm' = RewardUpdate -> NonMyopic
nonMyopic RewardUpdate
ru
data FilteredRewards era = FilteredRewards
{
forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered :: !(Map (Credential 'Staking) (Set Reward))
, forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frShelleyIgnored :: Map (Credential 'Staking) (Set Reward)
, forall era. FilteredRewards era -> Set (Credential 'Staking)
frUnregistered :: Set (Credential 'Staking)
, forall era. FilteredRewards era -> Coin
frTotalUnregistered :: Coin
}
instance NFData (FilteredRewards era) where
rnf :: FilteredRewards era -> ()
rnf (FilteredRewards Map (Credential 'Staking) (Set Reward)
a Map (Credential 'Staking) (Set Reward)
b Set (Credential 'Staking)
c Coin
d) = Map (Credential 'Staking) (Set Reward)
a forall a b. NFData a => a -> b -> b
`deepseq` Map (Credential 'Staking) (Set Reward)
b forall a b. NFData a => a -> b -> b
`deepseq` Set (Credential 'Staking)
c forall a b. NFData a => a -> b -> b
`deepseq` forall a. NFData a => a -> ()
rnf Coin
d
filterAllRewards' ::
Map (Credential 'Staking) (Set Reward) ->
ProtVer ->
DState era ->
FilteredRewards era
filterAllRewards' :: forall era.
Map (Credential 'Staking) (Set Reward)
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' Map (Credential 'Staking) (Set Reward)
rs ProtVer
protVer DState era
dState =
forall era.
Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Set Reward)
-> Set (Credential 'Staking)
-> Coin
-> FilteredRewards era
FilteredRewards Map (Credential 'Staking) (Set Reward)
registered Map (Credential 'Staking) (Set Reward)
shelleyIgnored Set (Credential 'Staking)
unregistered Coin
totalUnregistered
where
(Map (Credential 'Staking) (Set Reward)
regRU, Map (Credential 'Staking) (Set Reward)
unregRU) = forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Credential 'Staking
k Set Reward
_ -> forall k v. k -> UView k v -> Bool
member Credential 'Staking
k (forall era. DState era -> UView (Credential 'Staking) RDPair
rewards DState era
dState)) Map (Credential 'Staking) (Set Reward)
rs
totalUnregistered :: Coin
totalUnregistered = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) Coin
aggregateRewards ProtVer
protVer Map (Credential 'Staking) (Set Reward)
unregRU
unregistered :: Set (Credential 'Staking)
unregistered = forall k a. Map k a -> Set k
Map.keysSet Map (Credential 'Staking) (Set Reward)
unregRU
(Map (Credential 'Staking) (Set Reward)
registered, Map (Credential 'Staking) (Set Reward)
shelleyIgnored) = ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward))
filterRewards ProtVer
protVer Map (Credential 'Staking) (Set Reward)
regRU
filterAllRewards ::
(EraGov era, EraCertState era) =>
Map (Credential 'Staking) (Set Reward) ->
EpochState era ->
FilteredRewards era
filterAllRewards :: forall era.
(EraGov era, EraCertState era) =>
Map (Credential 'Staking) (Set Reward)
-> EpochState era -> FilteredRewards era
filterAllRewards Map (Credential 'Staking) (Set Reward)
mp EpochState era
epochstate = forall era.
Map (Credential 'Staking) (Set Reward)
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' Map (Credential 'Staking) (Set Reward)
mp ProtVer
prevPP DState era
dState
where
prevPP :: ProtVer
prevPP = EpochState era
epochstate forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
dState :: DState era
dState = EpochState era
epochstate forall s a. s -> Getting a s a -> a
^. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL