{-# 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.Keys (
  KeyRole (..),
 )
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 (EraCrypto era) ->
  UTxO era ->
  UTxO era ->
  IncrementalStake (EraCrypto era)
updateStakeDistribution :: forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
updateStakeDistribution PParams era
pp IncrementalStake (EraCrypto era)
incStake0 UTxO era
utxoDel UTxO era
utxoAdd = IncrementalStake (EraCrypto era)
incStake2
  where
    incStake1 :: IncrementalStake (EraCrypto era)
incStake1 = forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake (EraCrypto era)
-> IncrementalStake (EraCrypto era)
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 (EraCrypto era)
incStake0
    incStake2 :: IncrementalStake (EraCrypto era)
incStake2 = forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake (EraCrypto era)
-> IncrementalStake (EraCrypto era)
incAggUtxoCoinByCred PParams era
pp (coerce :: forall a b. Coercible a b => a -> b
coerce ((-) @Word64)) UTxO era
utxoDel IncrementalStake (EraCrypto era)
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 (EraCrypto era) ->
  IncrementalStake (EraCrypto era)
incAggUtxoCoinByCred :: forall era.
EraTxOut era =>
PParams era
-> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> UTxO era
-> IncrementalStake (EraCrypto era)
-> IncrementalStake (EraCrypto era)
incAggUtxoCoinByCred PParams era
pp CompactForm Coin -> CompactForm Coin -> CompactForm Coin
f (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
u) IncrementalStake (EraCrypto era)
initial =
  forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' IncrementalStake (EraCrypto era)
-> TxOut era -> IncrementalStake (EraCrypto era)
accum IncrementalStake (EraCrypto era)
initial Map (TxIn (EraCrypto era)) (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 (EraCrypto era)
-> TxOut era -> IncrementalStake (EraCrypto era)
accum ans :: IncrementalStake (EraCrypto era)
ans@(IStake Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era))
addrTxOutL of
            Addr Network
_ PaymentCredential (EraCrypto era)
_ (StakeRefPtr Ptr
p)
              | Bool -> Bool
not Bool
ignorePtrs ->
                  forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake c
IStake Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era)
_ (StakeRefBase Credential 'Staking (EraCrypto era)
hk) ->
              forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake c
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 (EraCrypto era)
hk Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stake) Map Ptr (CompactForm Coin)
ptrs
            Addr (EraCrypto era)
_other -> IncrementalStake (EraCrypto era)
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 (EraCrypto era)
-> Coin
-> UTxOState era
UTxOState
    UTxO era
utxo
    Coin
c1
    Coin
c2
    GovState era
st
    (forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
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 (EraCrypto era) ->
  DState era ->
  PState era ->
  SnapShot (EraCrypto era)
incrementalStakeDistr :: forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr PParams era
pp (IStake Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
credStake Map Ptr (CompactForm Coin)
ptrStake) DState era
ds PState era
ps =
  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 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 (EraCrypto era)) (CompactForm Coin)
step2)
    VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
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 (EraCrypto era)) (PoolParams (EraCrypto era))
poolParams)
  where
    UMap Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
triplesMap Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap = forall era. DState era -> UMap (EraCrypto era)
dsUnified DState era
ds
    PState {psStakePoolParams :: forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolParams} = PState era
ps
    delegs_ :: VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs_ = forall c k v. UView c k v -> VMap VB VB k v
UM.unUnifyToVMap (forall era.
DState era
-> UView
     (EraCrypto era)
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
delegations DState era
ds)
    -- A credential is active, only if it is being delegated
    activeCreds :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
activeCreds = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Credential 'Staking (EraCrypto era)
k CompactForm Coin
_ -> forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k) =>
k -> VMap kv vv k v -> Bool
VMap.member Credential 'Staking (EraCrypto era)
k VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs_) Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era)) (CompactForm Coin)
step1 =
      if Bool
ignorePtrs
        then Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era)) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
addResolvedPointer Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
activeCreds Map Ptr (CompactForm Coin)
ptrStake
    step2 :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
step2 = forall k c.
Ord k =>
Map k (UMElem c)
-> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
triplesMap Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
step1
    addResolvedPointer :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
-> Ptr
-> CompactForm Coin
-> Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
addResolvedPointer Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era))
ptrsMap of -- map of ptrs to credentials
        Just Credential 'Staking (EraCrypto era)
cred | forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k) =>
k -> VMap kv vv k v -> Bool
VMap.member Credential 'Staking (EraCrypto era)
cred VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
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 (EraCrypto era)
cred CompactForm Coin
ccoin Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
ans
        Maybe (Credential 'Staking (EraCrypto era))
_ -> Map (Credential 'Staking (EraCrypto era)) (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 c) -> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake :: forall k c.
Ord k =>
Map k (UMElem c)
-> Map k (CompactForm Coin) -> Map k (CompactForm Coin)
aggregateActiveStake Map k (UMElem c)
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 c
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
<$> forall c. UMElem c -> Maybe RDPair
UM.umElemRDActive UMElem c
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 c
trip -> RDPair -> CompactForm Coin
UM.rdReward forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. UMElem c -> Maybe RDPair
UM.umElemRDActive UMElem c
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 c)
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 (EraCrypto era) ->
  EpochState era ->
  EpochState era
applyRUpd :: forall era.
EraGov era =>
RewardUpdate (EraCrypto era) -> EpochState era -> EpochState era
applyRUpd RewardUpdate (EraCrypto era)
ru EpochState era
es =
  let (!EpochState era
es', FilteredRewards era
_) = forall era.
EraGov era =>
RewardUpdate (EraCrypto era)
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered RewardUpdate (EraCrypto era)
ru EpochState era
es
   in EpochState era
es'

-- TO IncrementalStake
applyRUpdFiltered ::
  EraGov era =>
  RewardUpdate (EraCrypto era) ->
  EpochState era ->
  (EpochState era, FilteredRewards era)
applyRUpdFiltered :: forall era.
EraGov era =>
RewardUpdate (EraCrypto era)
-> EpochState era -> (EpochState era, FilteredRewards era)
applyRUpdFiltered
  RewardUpdate (EraCrypto era)
ru
  es :: EpochState era
es@(EpochState AccountState
as LedgerState era
ls SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
_nm) = (EpochState era
epochStateAns, FilteredRewards era
filteredRewards)
    where
      !epochStateAns :: EpochState era
epochStateAns =
        forall era.
AccountState
-> LedgerState era
-> SnapShots (EraCrypto era)
-> NonMyopic (EraCrypto era)
-> EpochState era
EpochState AccountState
as' LedgerState era
ls' SnapShots (EraCrypto era)
ss NonMyopic (EraCrypto era)
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 (EraCrypto era))
  (Set (Reward (EraCrypto era)))
frRegistered :: forall era.
FilteredRewards era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
frRegistered :: Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
frRegistered
        , Coin
frTotalUnregistered :: forall era. FilteredRewards era -> Coin
frTotalUnregistered :: Coin
frTotalUnregistered
        } = forall era.
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' (forall c.
RewardUpdate c -> Map (Credential 'Staking c) (Set (Reward c))
rs RewardUpdate (EraCrypto era)
ru) ProtVer
prevProVer DState era
dState
      -- Note: domain filteredRewards is a subset of domain (rewards dstate)
      registeredAggregated :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
registeredAggregated = forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) (CompactForm Coin)
aggregateCompactRewards ProtVer
prevProVer Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
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) (forall c. RewardUpdate c -> DeltaCoin
deltaT RewardUpdate (EraCrypto era)
ru) forall a. Semigroup a => a -> a -> a
<> Coin
frTotalUnregistered
          , asReserves :: Coin
asReserves = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
asReserves AccountState
as) (forall c. RewardUpdate c -> DeltaCoin
deltaR RewardUpdate (EraCrypto era)
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` forall c. RewardUpdate c -> DeltaCoin
deltaF RewardUpdate (EraCrypto era)
ru}
          , lsCertState :: CertState era
lsCertState =
              CertState era
dpState
                { certDState :: DState era
certDState =
                    DState era
dState
                      { dsUnified :: UMap (EraCrypto era)
dsUnified = forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards DState era
dState forall c.
UView c (Credential 'Staking c) RDPair
-> Map (Credential 'Staking c) (CompactForm Coin) -> UMap c
UM.∪+ Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
registeredAggregated
                      }
                }
          }
      nm' :: NonMyopic (EraCrypto era)
nm' = forall c. RewardUpdate c -> NonMyopic c
nonMyopic RewardUpdate (EraCrypto era)
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 (EraCrypto era))
     (Set (Reward (EraCrypto era)))
frRegistered :: !(Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era))))
  -- ^ These are registered, in the current Unified map of the CertState
  , forall era.
FilteredRewards era
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
frShelleyIgnored :: Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era)))
  -- ^ 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 (EraCrypto era))
frUnregistered :: Set (Credential 'Staking (EraCrypto era))
  -- ^ 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 (EraCrypto era))
  (Set (Reward (EraCrypto era)))
a Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
b Set (Credential 'Staking (EraCrypto era))
c Coin
d) = Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
a forall a b. NFData a => a -> b -> b
`deepseq` Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
b forall a b. NFData a => a -> b -> b
`deepseq` Set (Credential 'Staking (EraCrypto era))
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 (EraCrypto era)) (Set (Reward (EraCrypto era))) ->
  ProtVer ->
  DState era ->
  FilteredRewards era
filterAllRewards' :: forall era.
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
rs ProtVer
protVer DState era
dState =
  forall era.
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> Map
     (Credential 'Staking (EraCrypto era))
     (Set (Reward (EraCrypto era)))
-> Set (Credential 'Staking (EraCrypto era))
-> Coin
-> FilteredRewards era
FilteredRewards Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
registered Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
shelleyIgnored Set (Credential 'Staking (EraCrypto era))
unregistered Coin
totalUnregistered
  where
    (Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
regRU, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
unregRU) = forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Credential 'Staking (EraCrypto era)
k Set (Reward (EraCrypto era))
_ -> forall k c v. k -> UView c k v -> Bool
member Credential 'Staking (EraCrypto era)
k (forall era.
DState era
-> UView
     (EraCrypto era) (Credential 'Staking (EraCrypto era)) RDPair
rewards DState era
dState)) Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
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
$ forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> Map (Credential 'Staking c) Coin
aggregateRewards ProtVer
protVer Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
unregRU
    unregistered :: Set (Credential 'Staking (EraCrypto era))
unregistered = forall k a. Map k a -> Set k
Map.keysSet Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
unregRU
    (Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
registered, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
shelleyIgnored) = forall c.
ProtVer
-> Map (Credential 'Staking c) (Set (Reward c))
-> (Map (Credential 'Staking c) (Set (Reward c)),
    Map (Credential 'Staking c) (Set (Reward c)))
filterRewards ProtVer
protVer Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
regRU

filterAllRewards ::
  EraGov era =>
  Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era))) ->
  EpochState era ->
  FilteredRewards era
filterAllRewards :: forall era.
EraGov era =>
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> EpochState era -> FilteredRewards era
filterAllRewards Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
mp EpochState era
epochstate = forall era.
Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
-> ProtVer -> DState era -> FilteredRewards era
filterAllRewards' Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
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