{-# 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 (
  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

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

-- | 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 ::
  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 =
  UTxO era
-> Coin
-> Coin
-> GovState era
-> InstantStake era
-> Coin
-> UTxOState era
forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> InstantStake era
-> Coin
-> UTxOState era
UTxOState
    UTxO era
utxo
    Coin
c1
    Coin
c2
    GovState era
st
    (UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake UTxO era
utxo InstantStake era
forall a. Monoid a => a
mempty)

-- =====================================================
-- 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 ChainAccountState for non-actively delegated stake
--   3) Adds fees to the UTxOState
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
_) = RewardUpdate
-> EpochState era -> (EpochState era, 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'

-- TO IncrementalStake
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 ChainAccountState
as LedgerState era
ls SnapShots
ss NonMyopic
_nm) = (EpochState era
epochStateAns, FilteredRewards era
filteredRewards)
    where
      !epochStateAns :: EpochState era
epochStateAns =
        ChainAccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
forall era.
ChainAccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState ChainAccountState
as' LedgerState era
ls' SnapShots
ss NonMyopic
nm'
          EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
          EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
      dpState :: CertState era
dpState = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
      dState :: DState era
dState = CertState era
dpState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
      prevPParams :: PParams era
prevPParams = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL
      prevProVer :: ProtVer
prevProVer = PParams era
prevPParams PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      filteredRewards :: FilteredRewards era
filteredRewards@FilteredRewards
        { Map (Credential 'Staking) (Set Reward)
frRegistered :: Map (Credential 'Staking) (Set Reward)
frRegistered :: forall era.
FilteredRewards era -> Map (Credential 'Staking) (Set Reward)
frRegistered
        , Coin
frTotalUnregistered :: Coin
frTotalUnregistered :: forall era. FilteredRewards era -> Coin
frTotalUnregistered
        } = Map (Credential 'Staking) (Set Reward)
-> ProtVer -> DState era -> FilteredRewards era
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' :: ChainAccountState
as' =
        ChainAccountState
as
          { casTreasury = addDeltaCoin (casTreasury as) (deltaT ru) <> frTotalUnregistered
          , casReserves = addDeltaCoin (casReserves as) (deltaR ru)
          }
      ls' :: LedgerState era
ls' =
        LedgerState era
ls
          LedgerState era
-> (LedgerState era -> LedgerState era) -> LedgerState era
forall a b. a -> (a -> b) -> b
& (UTxOState era -> Identity (UTxOState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Identity (UTxOState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Coin -> Identity Coin)
    -> UTxOState era -> Identity (UTxOState era))
-> (Coin -> Identity Coin)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> UTxOState era -> Identity (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosFeesL ((Coin -> Identity Coin)
 -> LedgerState era -> Identity (LedgerState era))
-> (Coin -> Coin) -> LedgerState era -> LedgerState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coin -> DeltaCoin -> Coin
`addDeltaCoin` RewardUpdate -> DeltaCoin
deltaF RewardUpdate
ru)
          LedgerState era
-> (LedgerState era -> LedgerState era) -> LedgerState era
forall a b. a -> (a -> b) -> b
& (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((UMap -> Identity UMap)
    -> CertState era -> Identity (CertState era))
-> (UMap -> Identity UMap)
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> LedgerState era -> Identity (LedgerState era))
-> UMap -> LedgerState era -> LedgerState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (DState era -> UView (Credential 'Staking) RDPair
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 Map (Credential 'Staking) (Set Reward) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Map (Credential 'Staking) (Set Reward)
b Map (Credential 'Staking) (Set Reward) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Set (Credential 'Staking)
c Set (Credential 'Staking) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Coin -> ()
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 =
  Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Set Reward)
-> Set (Credential 'Staking)
-> Coin
-> FilteredRewards era
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) = (Credential 'Staking -> Set Reward -> Bool)
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
    Map (Credential 'Staking) (Set Reward))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Credential 'Staking
k Set Reward
_ -> Credential 'Staking -> UView (Credential 'Staking) RDPair -> Bool
forall k v. k -> UView k v -> Bool
member Credential 'Staking
k (DState era -> UView (Credential 'Staking) RDPair
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 = Map (Credential 'Staking) Coin -> Coin
forall m. Monoid m => Map (Credential 'Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential 'Staking) Coin -> Coin)
-> Map (Credential 'Staking) Coin -> Coin
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 = Map (Credential 'Staking) (Set Reward) -> Set (Credential 'Staking)
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 = Map (Credential 'Staking) (Set Reward)
-> ProtVer -> DState era -> FilteredRewards era
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 EpochState era
-> Getting ProtVer (EpochState era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const ProtVer (PParams era))
-> EpochState era -> Const ProtVer (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Const ProtVer (PParams era))
 -> EpochState era -> Const ProtVer (EpochState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> PParams era -> Const ProtVer (PParams era))
-> Getting ProtVer (EpochState era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> PParams era -> Const ProtVer (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
    dState :: DState era
dState = EpochState era
epochstate EpochState era
-> Getting (DState era) (EpochState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. (LedgerState era -> Const (DState era) (LedgerState era))
-> EpochState era -> Const (DState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const (DState era) (LedgerState era))
 -> EpochState era -> Const (DState era) (EpochState era))
-> ((DState era -> Const (DState era) (DState era))
    -> LedgerState era -> Const (DState era) (LedgerState era))
-> Getting (DState era) (EpochState era) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const (DState era) (CertState era))
-> LedgerState era -> Const (DState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (DState era) (CertState era))
 -> LedgerState era -> Const (DState era) (LedgerState era))
-> ((DState era -> Const (DState era) (DState era))
    -> CertState era -> Const (DState era) (CertState era))
-> (DState era -> Const (DState era) (DState era))
-> LedgerState era
-> Const (DState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (DState era) (DState era))
-> CertState era -> Const (DState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL