Address review comments

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs

@@ -66,6 +66,7 @@ import Cardano.Ledger.PoolDistr
 import Cardano.Ledger.UMap
 import qualified Cardano.Ledger.UMap as UMap
 import Control.DeepSeq (NFData (..), deepseq)
+import Control.Monad (guard)
 import Control.Monad.Trans.Reader (Reader, runReader)
 import Control.State.Transition.Extended
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
@@ -197,7 +198,7 @@ computeDRepDistr ::
 computeDRepDistr stakeDistr regDReps proposalDeposits poolDistr dRepDistr uMapChunk =
   Map.foldlWithKey' go (dRepDistr, poolDistr) uMapChunk
   where
-    go (drepAccum, poolAccum) stakeCred umElem =
+    go (!drepAccum, !poolAccum) stakeCred umElem =
       let stake = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred stakeDistr
           proposalDeposit = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred proposalDeposits
           stakeAndDeposits = addCompact stake proposalDeposit
@@ -215,18 +216,18 @@ computeDRepDistr stakeDistr regDReps proposalDeposits poolDistr dRepDistr uMapCh
               ( addToDRepDistr drep (addCompact stakeAndDeposits r) drepAccum
               , addToPoolDistr spo proposalDeposit poolAccum
               )
-    addToPoolDistr spo ccoin distr =
+    addToPoolDistr spo proposalDeposit distr = fromMaybe distr $ do
       -- Avoid adding the proposal deposits to anything other than the numerator
       -- and denominator in order not to interfere with rewards calculation,
       -- although this is an isolated copy inside the DRepPulser, we want to
       -- just be sure we do not confuse ourselves over which representations are
       -- used where.
-      case Map.lookup spo $ distr ^. poolDistrDistrL of
-        Nothing -> distr -- Impossible! Because a delegation to an SPO would also appear in the PoolDistr.
-        Just ips ->
-          distr
-            & poolDistrDistrL %~ Map.insert spo (ips & individualPoolStakeCoinL <>~ ccoin)
-            & poolDistrTotalL <>~ ccoin
+      guard (proposalDeposit /= mempty)
+      ips <- Map.lookup spo $ distr ^. poolDistrDistrL
+      pure $
+        distr
+          & poolDistrDistrL %~ Map.insert spo (ips & individualTotalPoolStakeL <>~ proposalDeposit)
+          & poolDistrTotalL <>~ proposalDeposit
     addToDRepDistr drep ccoin distr =
       let updatedDistr = Map.insertWith addCompact drep ccoin distr
        in case drep of

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs

@@ -71,7 +71,7 @@ import Cardano.Ledger.Conway.Rules.Enact (EnactSignal (..), EnactState (..))
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyRole (..))
-import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStakeCoin)
+import Cardano.Ledger.PoolDistr (PoolDistr (..), individualTotalPoolStake)
 import Cardano.Ledger.Slot (EpochNo (..))
 import Cardano.Ledger.Val (Val (..), (<+>))
 import Control.State.Transition.Extended (
@@ -211,7 +211,7 @@ spoAcceptedRatio
       (CompactCoin yesVotes, CompactCoin abstainVotes) =
         Map.foldlWithKey' getVotesStakePerStakePoolDistr (mempty, mempty) individualPoolStake
       getVotesStakePerStakePoolDistr (!yess, !abstains) poolId distr =
-        let d = individualPoolStakeCoin distr
+        let d = individualTotalPoolStake distr
             vote = Map.lookup poolId gasStakePoolVotes
          in case vote of
               Nothing

eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs

@@ -3,11 +3,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -193,6 +191,9 @@ getPoolParameters = Map.restrictKeys . f
 -- saturation for rewards purposes. For that, it needs the fraction of total
 -- stake.
 --
+-- The fields `individualTotalPoolStake` and `pdTotalActiveStake` continue to
+-- remain based on active stake and not total stake.
+--
 -- This is not based on any snapshot, but uses the current ledger state.
 poolsByTotalStakeFraction ::
   forall era.
@@ -201,13 +202,12 @@ poolsByTotalStakeFraction ::
   NewEpochState era ->
   PoolDistr (EraCrypto era)
 poolsByTotalStakeFraction globals ss =
-  PoolDistr poolsByTotalStake activeStake -- QESTION: Should the denominator be `totalStake` here instead?
+  PoolDistr poolsByTotalStake totalActiveStake
   where
-    snap@(EB.SnapShot stake _ _) = currentSnapshot ss
+    snap = currentSnapshot ss
     Coin totalStake = getTotalStake globals ss
-    activeStake = EB.sumAllStake stake
-    stakeRatio = unCoin (fromCompact activeStake) % totalStake
-    PoolDistr poolsByActiveStake _totalActiveStake = calculatePoolDistr snap
+    stakeRatio = unCoin (fromCompact totalActiveStake) % totalStake
+    PoolDistr poolsByActiveStake totalActiveStake = calculatePoolDistr snap
     poolsByTotalStake = Map.map toTotalStakeFrac poolsByActiveStake
     toTotalStakeFrac ::
       IndividualPoolStake (EraCrypto era) ->
@@ -255,7 +255,7 @@ getNonMyopicMemberRewards globals ss =
           ,
             ( percentile' (histLookup k)
             , p
-            , toShare . fromCompact . EB.sumAllStake $ EB.poolStake k delegs stake
+            , toShare . EB.sumAllStake $ EB.poolStake k delegs stake
             )
           )
         | (k, p) <- VMap.toAscList poolParams
@@ -392,7 +392,7 @@ getRewardInfoPools globals ss =
             unPerformanceEstimate $ percentile' $ histLookup key
         }
       where
-        pstake = fromCompact $ EB.sumAllStake $ EB.poolStake key delegs stakes
+        pstake = EB.sumAllStake $ EB.poolStake key delegs stakes
         ostake = sumPoolOwnersStake poolp stakes
 
 -- | Calculate stake pool rewards from the snapshot labeled `go`.

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs

@@ -148,7 +148,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
       _R = Coin $ rPot - deltaT1
       -- We now compute stake pool specific values that are needed for computing
       -- member and leader rewards.
-      activestake = sumAllStake stake
+      activeStake = sumAllStake stake
       totalStake = circulation es maxSupply
       stakePerPool = sumStakePerPool delegs stake
       mkPoolRewardInfoCurry =
@@ -161,7 +161,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
           delegs
           stakePerPool
           totalStake
-          $ UM.fromCompact activestake
+          activeStake
       -- We map over the registered stake pools to compute the revelant
       -- stake pool specific values.
       allPoolInfo = VMap.map mkPoolRewardInfoCurry poolParams

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs

@@ -484,7 +484,7 @@ rewardOld
   slotsPerEpoch = (rewards', hs)
     where
       totalBlocks = sum b
-      Coin activeStake = fromCompact $ sumAllStake stake
+      Coin activeStake = sumAllStake stake
       results ::
         [ ( KeyHash 'StakePool (EraCrypto era)
           , Maybe (Map (Credential 'Staking (EraCrypto era)) Coin)
@@ -497,7 +497,7 @@ rewardOld
             sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake
             blocksProduced = Map.lookup hk b
             actgr = poolStake hk delegs stake
-            Coin pstake = fromCompact $ sumAllStake actgr
+            Coin pstake = sumAllStake actgr
             rewardMap = case blocksProduced of
               Nothing -> Nothing -- This is equivalent to calling rewarOnePool with n = 0
               Just n ->
@@ -784,7 +784,7 @@ reward
           delegs
           stakePerPool
           totalStake
-          (fromCompact activeStake)
+          activeStake
           pool
       free =
         FreeVars

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs

@@ -980,7 +980,7 @@ alicePerfEx11 = applyDecay decayFactor alicePerfEx8 <> epoch4Likelihood
     blocks = 0
     t = leaderProbability f relativeStake (unsafeBoundRational 0.5)
     -- everyone has delegated to Alice's Pool
-    Coin stake = fromCompact $ EB.sumAllStake (EB.ssStake $ snapEx5 @c)
+    Coin stake = EB.sumAllStake (EB.ssStake $ snapEx5 @c)
     relativeStake = fromRational (stake % supply)
     Coin supply = maxLLSupply <-> reserves12
     f = activeSlotCoeff testGlobals

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.12.0.0
 
+* Add `UMap.umElemDelegations` to extract SPO, DRep and rewards for a given stake credential. #4324
 * Add lenses to `RewardAccount`. #4309
   * `rewardAccountCredentialL`
   * `rewardAccountNetworkL`

libs/cardano-ledger-core/src/Cardano/Ledger/EpochBoundary.hs

@@ -22,6 +22,7 @@
 module Cardano.Ledger.EpochBoundary (
   Stake (..),
   sumAllStake,
+  sumAllStakeCompact,
   sumStakePerPool,
   SnapShot (..),
   SnapShots (..),
@@ -102,10 +103,14 @@ instance Crypto c => DecShareCBOR (Stake c) where
   getShare = getShare . unStake
   decShareCBOR = fmap Stake . decShareCBOR
 
-sumAllStake :: Stake c -> CompactForm Coin
-sumAllStake = VMap.foldl (<>) mempty . unStake
+sumAllStake :: Stake c -> Coin
+sumAllStake = fromCompact . sumAllStakeCompact
 {-# INLINE sumAllStake #-}
 
+sumAllStakeCompact :: Stake c -> CompactForm Coin
+sumAllStakeCompact = VMap.foldl (<>) mempty . unStake
+{-# INLINE sumAllStakeCompact #-}
+
 -- | Get stake of one pool
 poolStake ::
   KeyHash 'StakePool c ->
@@ -297,24 +302,23 @@ calculatePoolDistr = calculatePoolDistr' (const True)
 
 calculatePoolDistr' :: forall c. (KeyHash 'StakePool c -> Bool) -> SnapShot c -> PoolDistr c
 calculatePoolDistr' includeHash (SnapShot stake delegs poolParams) =
-  let total = sumAllStake stake
+  let total = sumAllStakeCompact stake
       -- total could be zero (in particular when shrinking)
-      nonZeroTotal :: Integer
-      nonZeroTotal = if total == mempty then 1 else unCoin $ fromCompact total
-      poolStakeMap :: Map.Map (KeyHash 'StakePool c) Word64
+      nonZeroTotalCompact = if total == mempty then CompactCoin 1 else total
+      nonZeroTotalInteger = unCoin $ fromCompact nonZeroTotalCompact
       poolStakeMap = calculatePoolStake includeHash delegs stake
    in PoolDistr
         ( Map.intersectionWith
             ( \word64 poolparam ->
                 IndividualPoolStake
-                  (toInteger word64 % nonZeroTotal)
+                  (toInteger word64 % nonZeroTotalInteger)
                   (CompactCoin word64)
                   (ppVrf poolparam)
             )
             poolStakeMap
             (VMap.toMap poolParams)
         )
-        (if total == mempty then CompactCoin 1 else total)
+        nonZeroTotalCompact
 
 -- ======================================================
 -- Lenses

libs/cardano-ledger-core/src/Cardano/Ledger/PoolDistr.hs

@@ -4,11 +4,9 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 -- | The stake distribution, aggregated by stake pool (as opposed to stake credential),
@@ -23,7 +21,7 @@ module Cardano.Ledger.PoolDistr (
   PoolDistr (..),
   poolDistrDistrL,
   poolDistrTotalL,
-  individualPoolStakeCoinL,
+  individualTotalPoolStakeL,
 )
 where
 
@@ -54,27 +52,33 @@ import NoThunks.Class (NoThunks (..))
 -- delegated to a registered stake pool.
 data IndividualPoolStake c = IndividualPoolStake
   { individualPoolStake :: !Rational
-  , individualPoolStakeCoin :: !(CompactForm Coin) -- TODO: Document
+  -- ^ Pool stake distribution. This is a ratio of
+  -- (individualTotalPoolStake - proposal deposits) to
+  -- (pdTotalActiveStake - proposal deposits)
+  , individualTotalPoolStake :: !(CompactForm Coin)
+  -- ^ Total stake delegated to this pool. In addition to all the stake  that
+  -- is part of `individualPoolStake` we also add proposal-deposits to this
+  -- field.
   , individualPoolStakeVrf :: !(Hash c (VerKeyVRF c))
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, NoThunks)
 
-individualPoolStakeCoinL :: Lens' (IndividualPoolStake c) (CompactForm Coin)
-individualPoolStakeCoinL = lens individualPoolStakeCoin $ \x y -> x {individualPoolStakeCoin = y}
+individualTotalPoolStakeL :: Lens' (IndividualPoolStake c) (CompactForm Coin)
+individualTotalPoolStakeL = lens individualTotalPoolStake $ \x y -> x {individualTotalPoolStake = y}
 
 instance Crypto c => EncCBOR (IndividualPoolStake c) where
   encCBOR (IndividualPoolStake stake stakeCoin vrf) =
     mconcat
-      [ encodeListLen 3 -- TODO: This needs versioning!
+      [ encodeListLen 3
       , encCBOR stake
       , encCBOR stakeCoin
       , encCBOR vrf
       ]
 
 instance Crypto c => DecCBOR (IndividualPoolStake c) where
   decCBOR =
-    decodeRecordNamed "IndividualPoolStake" (const 2) $
+    decodeRecordNamed "IndividualPoolStake" (const 3) $
       IndividualPoolStake
         <$> decCBOR
         <*> decCBOR
@@ -88,15 +92,19 @@ toIndividualPoolStakePair :: (KeyValue e a, Crypto c) => IndividualPoolStake c -
 toIndividualPoolStakePair indivPoolStake@(IndividualPoolStake _ _ _) =
   let IndividualPoolStake {..} = indivPoolStake
    in [ "individualPoolStake" .= individualPoolStake
-      , "individualPoolStakeCoin" .= individualPoolStakeCoin
+      , "individualTotalPoolStake" .= individualTotalPoolStake
       , "individualPoolStakeVrf" .= individualPoolStakeVrf
       ]
 
 -- | A map of stake pool IDs (the hash of the stake pool operator's
--- verification key) to 'IndividualPoolStake'.
+-- verification key) to 'IndividualPoolStake'. Also holds absolute values
+-- necessary for the calculations in the `computeDRepDistr`.
 data PoolDistr c = PoolDistr
-  { unPoolDistr :: Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-  , pdTotal :: !(CompactForm Coin)
+  { unPoolDistr :: !(Map (KeyHash 'StakePool c) (IndividualPoolStake c))
+  , pdTotalActiveStake :: !(CompactForm Coin)
+  -- ^ Total stake delegated to registered stake pools. In addition to
+  -- the stake considered for the `individualPoolStake` Rational, we add
+  -- proposal-deposits to this field.
   }
   deriving stock (Show, Eq, Generic)
   deriving (NFData, NoThunks, ToJSON)
@@ -105,11 +113,10 @@ poolDistrDistrL :: Lens' (PoolDistr c) (Map (KeyHash 'StakePool c) (IndividualPo
 poolDistrDistrL = lens unPoolDistr $ \x y -> x {unPoolDistr = y}
 
 poolDistrTotalL :: Lens' (PoolDistr c) (CompactForm Coin)
-poolDistrTotalL = lens pdTotal $ \x y -> x {pdTotal = y}
+poolDistrTotalL = lens pdTotalActiveStake $ \x y -> x {pdTotalActiveStake = y}
 
 instance Crypto c => EncCBOR (PoolDistr c) where
   encCBOR (PoolDistr distr total) =
-    -- TODO: @aniketd: This needs versioning!
     encode $
       Rec PoolDistr
         !> To distr
@@ -121,27 +128,3 @@ instance Crypto c => DecCBOR (PoolDistr c) where
       RecD PoolDistr
         <! From
         <! From
-
--- -- ===============================
-
--- instance
---   HasExp
---     (PoolDistr c)
---     ( Map
---         (KeyHash 'StakePool c)
---         (IndividualPoolStake c)
---     )
---   where
---   toExp (PoolDistr x) = Base MapR x
-
--- -- | We can Embed a Newtype around a Map (or other Iterable type) and then use it in a set expression.
--- instance
---   Embed
---     (PoolDistr c)
---     ( Map
---         (KeyHash 'StakePool c)
---         (IndividualPoolStake c)
---     )
---   where
---   toBase (PoolDistr x) = x
---   fromBase = PoolDistr

libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs

@@ -294,13 +294,14 @@ umElemRDActive = \case
 {-# INLINE umElemRDActive #-}
 
 data RewardDelegation c
-  = RewardDelegationSPO (KeyHash 'StakePool c) (CompactForm Coin)
-  | RewardDelegationDRep (DRep c) (CompactForm Coin)
-  | RewardDelegationBoth (KeyHash 'StakePool c) (DRep c) (CompactForm Coin)
+  = RewardDelegationSPO !(KeyHash 'StakePool c) !(CompactForm Coin)
+  | RewardDelegationDRep !(DRep c) !(CompactForm Coin)
+  | RewardDelegationBoth !(KeyHash 'StakePool c) !(DRep c) !(CompactForm Coin)
 
 -- | Extract rewards that are either delegated to a DRep or an SPO (or both).
--- We can tell that the pair is present and active when Txxxx has
--- F's in the 1st, 3rd and 4th positions
+-- We can tell that the pair is present and active when Txxxx has F's in the 1st
+-- and either 3rd or 4th or both positions. If there are no rewards or deposits
+-- but the delegations still exist, then we return zero coin as reward.
 umElemDelegations :: UMElem c -> Maybe (RewardDelegation c)
 umElemDelegations = \case
   TFEEF RDPair {rdReward} drep -> Just $ RewardDelegationDRep drep rdReward
@@ -309,6 +310,12 @@ umElemDelegations = \case
   TFFEF RDPair {rdReward} _ drep -> Just $ RewardDelegationDRep drep rdReward
   TFFFE RDPair {rdReward} _ spo -> Just $ RewardDelegationSPO spo rdReward
   TFFFF RDPair {rdReward} _ spo drep -> Just $ RewardDelegationBoth spo drep rdReward
+  TEEEF drep -> Just $ RewardDelegationDRep drep mempty
+  TEEFE spo -> Just $ RewardDelegationSPO spo mempty
+  TEEFF spo drep -> Just $ RewardDelegationBoth spo drep mempty
+  TEFEF _ drep -> Just $ RewardDelegationDRep drep mempty
+  TEFFE _ spo -> Just $ RewardDelegationSPO spo mempty
+  TEFFF _ spo drep -> Just $ RewardDelegationBoth spo drep mempty
   _ -> Nothing
 {-# INLINE umElemDelegations #-}