{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- ===========================================================================
-- There are three parts to IncrementalStaking.
-- 1) The incremental part, where we keep track of each update to the UTxO
--    adding Inputs and deleting consumed Outputs. Done in the Utxo rules.
-- 2) Finalizing and aggregating by stake credential to create a Snapshot.
--    done in the Snap rules.
-- 3) Applying the RewardUpdate, to the Rewards component of the UMap.
--    done in the NewEpoch rules.

module Cardano.Ledger.Shelley.LedgerState.IncrementalStake (
  updateStakeDistribution,
  incrementalStakeDistr,
  applyRUpd,
  applyRUpdFiltered,
  smartUTxOState,
  filterAllRewards,
  FilteredRewards (..),
)
where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.BaseTypes (ProtVer)
import Cardano.Ledger.CertState (
  CertState (..),
  DState (..),
  PState (..),
  delegations,
  rewards,
 )
import Cardano.Ledger.Coin (
  Coin (..),
  CompactForm (CompactCoin),
  addDeltaCoin,
 )
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (
  Credential (..),
  StakeReference (StakeRefBase, StakeRefPtr),
 )
import Cardano.Ledger.EpochBoundary (SnapShot (..), Stake (..))
import Cardano.Ledger.Shelley.Governance (EraGov (GovState))
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState.Types
import Cardano.Ledger.Shelley.RewardUpdate (RewardUpdate (..))
import Cardano.Ledger.Shelley.Rewards (
  aggregateCompactRewards,
  aggregateRewards,
  filterRewards,
 )
import Cardano.Ledger.UMap (
  UMElem,
  UMap (..),
  member,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..))
import Control.DeepSeq (NFData (rnf), deepseq)
import Control.Exception (assert)
import Data.Coerce (coerce)
import Data.Foldable (fold)
import Data.Map.Internal.Debug as Map (valid)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.VMap as VMap
import Data.Word
import Lens.Micro

-- =======================================================================
-- Part 1, Incrementally updating the IncrementalStake in Utxo rule
-- =======================================================================

-- | Incrementally add the inserts 'utxoAdd' and the deletes 'utxoDel' to the IncrementalStake.
updateStakeDistribution ::
  EraTxOut era =>
  PParams era ->
  IncrementalStake ->
  UTxO era ->
  UTxO era ->
  IncrementalStake
updateStakeDistribution :: forall era.
EraTxOut era =>
PParams era
-> IncrementalStake -> UTxO era -> UTxO era -> IncrementalStake
updateStakeDistribution PParams era
pp IncrementalStake
incStake0 UTxO era
utxoDel UTxO era
utxoAdd = IncrementalStake
incStake2
  where
    incStake1 :: IncrementalStake
incStake1 = forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake
-> IncrementalStake
incAggUtxoCoinByCred PParams era
pp (coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Num a => a -> a -> a
(+) @Word64)) UTxO era
utxoAdd IncrementalStake
incStake0
    incStake2 :: IncrementalStake
incStake2 = forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake
-> IncrementalStake
incAggUtxoCoinByCred PParams era
pp (coerce :: forall a b. Coercible a b => a -> b
coerce ((-) @Word64)) UTxO era
utxoDel IncrementalStake
incStake1

-- | Incrementally sum up all the Coin, for each staking Credential, in the outputs of the UTxO, and
--   "add" them to the IncrementalStake. "add" has different meaning depending on if we are inserting
--   or deleting the UtxO entries. For inserts (the mode is to add (+)) and for deletes (the mode is
--   to subtract (-)).
--   Never store a (Coin 0) balance, since these do not occur in the non-incremental style that
--   works directly from the whole UTxO.
--   This function has a non-incremental analog 'aggregateUtxoCoinByCredential' . In this incremental
--   version we expect the size of the UTxO to be fairly small. I.e the number of inputs and outputs
--   in a transaction, which is aways < 4096, not millions, and very often < 10).
incAggUtxoCoinByCred ::
  forall era.
  EraTxOut era =>
  PParams era ->
  (CompactForm Coin -> CompactForm Coin -> CompactForm Coin) ->
  UTxO era ->
  IncrementalStake ->
  IncrementalStake
incAggUtxoCoinByCred :: forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake
-> IncrementalStake
incAggUtxoCoinByCred PParams era
pp CompactForm Coin -> CompactForm Coin -> CompactForm Coin
f (UTxO Map TxIn (TxOut era)
u) IncrementalStake
initial =
  forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' IncrementalStake -> TxOut era -> IncrementalStake
accum IncrementalStake
initial Map TxIn (TxOut era)
u
  where
    keepOrDeleteCompact :: CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
new = \case
      Maybe (CompactForm Coin)
Nothing ->
        case CompactForm Coin
new of
          CompactCoin Word64
0 -> forall a. Maybe a
Nothing
          CompactForm Coin
final -> forall a. a -> Maybe a
Just CompactForm Coin
final
      Just CompactForm Coin
old ->
        case CompactForm Coin
old CompactForm Coin -> CompactForm Coin -> CompactForm Coin
`f` CompactForm Coin
new of
          CompactCoin Word64
0 -> forall a. Maybe a
Nothing
          CompactForm Coin
final -> forall a. a -> Maybe a
Just CompactForm Coin
final
    ignorePtrs :: Bool
ignorePtrs = ProtVer -> Bool
HardForks.forgoPointerAddressResolution (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
    accum :: IncrementalStake -> TxOut era -> IncrementalStake
accum ans :: IncrementalStake
ans@(IStake Map (Credential 'Staking) (CompactForm Coin)
stake Map Ptr (CompactForm Coin)
ptrs) TxOut era
out =
      let cc :: CompactForm Coin
cc = TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL
       in case TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
            Addr Network
_ PaymentCredential
_ (StakeRefPtr Ptr
p)
              | Bool -> Bool
not Bool
ignorePtrs ->
                  Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
IStake Map (Credential 'Staking) (CompactForm Coin)
stake (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
cc) Ptr
p Map Ptr (CompactForm Coin)
ptrs)
            Addr Network
_ PaymentCredential
_ (StakeRefBase Credential 'Staking
hk) ->
              Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
IStake (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (CompactForm Coin
-> Maybe (CompactForm Coin) -> Maybe (CompactForm Coin)
keepOrDeleteCompact CompactForm Coin
cc) Credential 'Staking
hk Map (Credential 'Staking) (CompactForm Coin)
stake) Map Ptr (CompactForm Coin)
ptrs
            Addr
_other -> IncrementalStake
ans

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

-- | A valid (or self-consistent) UTxOState{utxosUtxo, utxosDeposited , utxosFees  , utxosPpups , utxosStakeDistr}
--   maintains an invariant between the utxosUtxo and utxosStakeDistr fields. the utxosStakeDistr field is
--   the aggregation of Coin over the StakeReferences in the UTxO. It can be computed by a pure
--   function from the _utxo field. In some situations, mostly unit or example tests, or when
--   initializing a small UTxO, we want to create a UTxOState that computes the utxosStakeDistr from
--   the utxosUtxo. This is aways safe to do, but if the utxosUtxo field is big, this can be very expensive,
--   which defeats the purpose of memoizing the utxosStakeDistr field. So use of this function should be
--   restricted to tests and initializations, where the invariant should be maintained.
--
--   TO IncrementalStake
smartUTxOState ::
  EraTxOut era =>
  PParams era ->
  UTxO era ->
  Coin ->
  Coin ->
  GovState era ->
  Coin ->
  UTxOState era
smartUTxOState :: forall era.
EraTxOut 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
-> IncrementalStake
-> Coin
-> UTxOState era
UTxOState
    UTxO era
utxo
    Coin
c1
    Coin
c2
    GovState era
st
    (forall era.
EraTxOut era =>
PParams era
-> IncrementalStake -> UTxO era -> UTxO era -> IncrementalStake
updateStakeDistribution PParams era
pp forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty UTxO era
utxo)

-- =======================================================================
-- Part 2. Compute a Snapshot using the IncrementalStake in Snap rule
-- =======================================================================

-- | This computes a Snapshot using IncrementalStake (which is an
--   aggregate of the current UTxO) and UMap (which tracks Coin,
--   SPoolUView, and Ptrs simultaneously).  Note that logically:
--   1) IncrementalStake = (credStake, ptrStake)
--   2) UMap = (rewards, activeDelegs, ptrmap :: Map ptr cred)
--
--   Using this scheme the logic can do 3 things in one go, without touching the UTxO.
--   1) Resolve Pointers
--   2) Throw away things not actively delegated
--   3) Add up the coin
--
--   The Stake distribution function (Map cred coin) (the first component of a SnapShot)
--   is defined by this SetAlgebra expression:
--   (dom activeDelegs) ◁ (aggregate+ (credStake ∪ ptrStake ∪ rewards))
--
--   We can apply meaning preserving operations to get equivalent expressions
--
--   (dom activeDelegs) ◁ (aggregate+ (credStake ∪ ptrStake ∪ rewards))
--   aggregate+ (dom activeDelegs ◁ (credStake ∪ ptrStake ∪ rewards))
--   aggregate+ ((dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake) ∪ (dom activeDelegs ◁ rewards))
--
--   We will compute this in several steps
--   step1 = (dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake)
--   step2 =  aggregate (dom activeDelegs ◁ rewards) step1
--   This function has a non-incremental analog, 'stakeDistr', mosty used in tests, which does use the UTxO.
incrementalStakeDistr ::
  forall era.
  EraPParams era =>
  PParams era ->
  IncrementalStake ->
  DState era ->
  PState era ->
  SnapShot
incrementalStakeDistr :: forall era.
EraPParams era =>
PParams era
-> IncrementalStake -> DState era -> PState era -> SnapShot
incrementalStakeDistr PParams era
pp (IStake Map (Credential 'Staking) (CompactForm Coin)
credStake Map Ptr (CompactForm Coin)
ptrStake) DState era
ds PState era
ps =
  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 a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (Credential 'Staking) (CompactForm Coin)
step2)
    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
poolParams)
  where
    UMap Map (Credential 'Staking) UMElem
triplesMap Map Ptr (Credential 'Staking)
ptrsMap = forall era. DState era -> UMap
dsUnified DState era
ds
    PState {psStakePoolParams :: forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = Map (KeyHash 'StakePool) PoolParams
poolParams} = PState era
ps
    delegs_ :: VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs_ = forall k v. UView k v -> VMap VB VB k v
UM.unUnifyToVMap (forall era.
DState era -> UView (Credential 'Staking) (KeyHash 'StakePool)
delegations DState era
ds)
    -- A credential is active, only if it is being delegated
    activeCreds :: Map (Credential 'Staking) (CompactForm Coin)
activeCreds = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Credential 'Staking
k CompactForm Coin
_ -> forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k) =>
k -> VMap kv vv k v -> Bool
VMap.member Credential 'Staking
k VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs_) Map (Credential 'Staking) (CompactForm Coin)
credStake
    ignorePtrs :: Bool
ignorePtrs = ProtVer -> Bool
HardForks.forgoPointerAddressResolution (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
    -- pre Conway: (dom activeDelegs ◁ credStake) ∪ (dom activeDelegs ◁ ptrStake)
    -- afterwards we forgo ptr resolution: (dom activeDelegs ◁ credStake)
    step1 :: Map (Credential 'Staking) (CompactForm Coin)
step1 =
      if Bool
ignorePtrs
        then Map (Credential 'Staking) (CompactForm Coin)
activeCreds
        else -- Resolve inserts and deletes which were indexed by ptrs, by looking them up
        -- in the ptrsMap and combining the result of the lookup with the ordinary
        -- stake, keeping only the active credentials
          forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map (Credential 'Staking) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking) (CompactForm Coin)
addResolvedPointer Map (Credential 'Staking) (CompactForm Coin)
activeCreds Map Ptr (CompactForm Coin)
ptrStake
    step2 :: Map (Credential 'Staking) (CompactForm Coin)
step2 = forall k.
Ord k =>
Map k UMElem
-> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake Map (Credential 'Staking) UMElem
triplesMap Map (Credential 'Staking) (CompactForm Coin)
step1
    addResolvedPointer :: Map (Credential 'Staking) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking) (CompactForm Coin)
addResolvedPointer Map (Credential 'Staking) (CompactForm Coin)
ans Ptr
ptr CompactForm Coin
ccoin =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr
ptr Map Ptr (Credential 'Staking)
ptrsMap of -- map of ptrs to credentials
        Just Credential 'Staking
cred | forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k) =>
k -> VMap kv vv k v -> Bool
VMap.member Credential 'Staking
cred VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
delegs_ -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) Credential 'Staking
cred CompactForm Coin
ccoin Map (Credential 'Staking) (CompactForm Coin)
ans
        Maybe (Credential 'Staking)
_ -> Map (Credential 'Staking) (CompactForm Coin)
ans

-- | Aggregate active stake by merging two maps. The triple map from the
--   UMap, and the IncrementalStake. Only keep the active stake. Active can
--   be determined if there is a (SJust deleg) in the Tuple.  This is step2 =
--   aggregate (dom activeDelegs ◁ rewards) step1
aggregateActiveStake ::
  Ord k => Map k UMElem -> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake :: forall k.
Ord k =>
Map k UMElem
-> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake Map k UMElem
m1 Map k (CompactForm Coin)
m2 = forall a. HasCallStack => Bool -> a -> a
assert (forall k a. Ord k => Map k a -> Bool
Map.valid Map k (CompactForm Coin)
m) Map k (CompactForm Coin)
m
  where
    m :: Map k (CompactForm Coin)
m =
      forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
        -- How to merge the ranges of the two maps where they have a common key. Below
        -- 'coin1' and 'coin2' have the same key, '_k', and the stake is active if the delegation is SJust
        (\k
_k UMElem
trip CompactForm Coin
coin2 -> CompactForm Coin -> RDPair -> CompactForm Coin
extractAndAdd CompactForm Coin
coin2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UMElem -> Maybe RDPair
UM.umElemRDActive UMElem
trip)
        -- what to do when a key appears just in 'tripmap', we only add the coin if the key is active
        (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (\UMElem
trip -> RDPair -> CompactForm Coin
UM.rdReward forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UMElem -> Maybe RDPair
UM.umElemRDActive UMElem
trip))
        -- what to do when a key is only in 'incremental', keep everything, because at
        -- the call site of aggregateActiveStake, the arg 'incremental' is filtered by
        -- 'resolveActiveIncrementalPtrs' which guarantees that only active stake is included.
        forall a. a -> a
id
        Map k UMElem
m1
        Map k (CompactForm Coin)
m2
    extractAndAdd :: CompactForm Coin -> UM.RDPair -> CompactForm Coin
    extractAndAdd :: CompactForm Coin -> RDPair -> CompactForm Coin
extractAndAdd CompactForm Coin
coin (UM.RDPair CompactForm Coin
rew CompactForm Coin
_dep) = CompactForm Coin
coin forall a. Semigroup a => a -> a -> a
<> CompactForm Coin
rew

-- =====================================================
-- Part 3 Apply a reward update, in NewEpoch rule
-- =====================================================

-- | Apply a RewardUpdate to the EpochState. Does several things
--   1) Adds reward coins to Rewards component of the UMap field of the DState,
--      for actively delegated Stake
--   2) Adds to the Treasury of the AccountState for non-actively delegated stake
--   3) Adds fees to the UTxOState
applyRUpd ::
  EraGov era =>
  RewardUpdate ->
  EpochState era ->
  EpochState era
applyRUpd :: forall era.
EraGov era =>
RewardUpdate -> EpochState era -> EpochState era
applyRUpd RewardUpdate
ru EpochState era
es =
  let (!EpochState era
es', FilteredRewards era
_) = forall era.
EraGov era =>
RewardUpdate
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate
ru EpochState era
es
   in EpochState era
es'

-- TO IncrementalStake
applyRUpdFiltered ::
  EraGov era =>
  RewardUpdate ->
  EpochState era ->
  (EpochState era, FilteredRewards era)
applyRUpdFiltered :: forall era.
EraGov 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
      utxoState_ :: UTxOState era
utxoState_ = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
      dpState :: CertState era
dpState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
      dState :: DState era
dState = forall era. CertState era -> DState era
certDState CertState era
dpState
      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
      -- Note: domain filteredRewards is a subset of domain (rewards 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
      -- Note: domain registeredAggregated is a subset of domain (rewards dstate)
      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
          { lsUTxOState :: UTxOState era
lsUTxOState =
              UTxOState era
utxoState_ {utxosFees :: Coin
utxosFees = forall era. UTxOState era -> Coin
utxosFees UTxOState era
utxoState_ Coin -> DeltaCoin -> Coin
`addDeltaCoin` RewardUpdate -> DeltaCoin
deltaF RewardUpdate
ru}
          , lsCertState :: CertState era
lsCertState =
              CertState era
dpState
                { certDState :: DState era
certDState =
                    DState era
dState
                      { dsUnified :: UMap
dsUnified = 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
  { -- Only the first component is strict on purpose. The others are lazy because in most instances
    -- they are never used, so this keeps them from being evaluated.

    forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered :: !(Map (Credential 'Staking) (Set Reward))
  -- ^ These are registered, in the current Unified map of the CertState
  , forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frShelleyIgnored :: Map (Credential 'Staking) (Set Reward)
  -- ^ These are registered, but ignored in the ShelleyEra because of backward
  --   compatibility in non-Shelley Eras, this field will be Map.empty
  , forall era. FilteredRewards era -> Set (Credential 'Staking)
frUnregistered :: Set (Credential 'Staking)
  -- ^ These are NOT registered in the current Unified map of the CertState
  , forall era. FilteredRewards era -> Coin
frTotalUnregistered :: Coin
  -- ^ Total Coin of the unregistered rewards. These will end up in the Treasury or Reserves.
  }

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

-- | Return aggregated information from a reward mapping from the previous Epoch.
--   Breaks the mapping into several parts captured by the 'Filtered' data type.
--   Note that the 'registered' field of the returned (FilteredRewards) is a Map
--   whose domain is always a subset of the Rewards View of the Unified Map in the DState of the EpochState.
--   'prevPParams' is the ProtocolParams of the previous Epoch
--   'rs' is the rewards mapping of the RewardUpdate from that previous Epoch
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
    -- Partition on memebership in the rewards view of the unified map of DState
    -- Note that only registered rewards appear in 'regRU' because of this 'member' check.
    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 =>
  Map (Credential 'Staking) (Set Reward) ->
  EpochState era ->
  FilteredRewards era
filterAllRewards :: forall era.
EraGov 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 = (forall era. CertState era -> DState era
certDState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState) EpochState era
epochstate