{-# 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 =
  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)

-- =====================================================
-- 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
_) = 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 =
        forall era.
ChainAccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState ChainAccountState
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
      -- 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 :: Coin
casTreasury = Coin -> DeltaCoin -> Coin
addDeltaCoin (ChainAccountState -> Coin
casTreasury ChainAccountState
as) (RewardUpdate -> DeltaCoin
deltaT RewardUpdate
ru) forall a. Semigroup a => a -> a -> a
<> Coin
frTotalUnregistered
          , casReserves :: Coin
casReserves = Coin -> DeltaCoin -> Coin
addDeltaCoin (ChainAccountState -> Coin
casReserves ChainAccountState
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
  { -- 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, 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