Address review comments, add dpProposalDeposits.

field to the DRepPulser to memoize a `Map` from staking credentials to
total proposal deposits made by that credential.

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

@@ -75,6 +75,7 @@ module Cardano.Ledger.Conway.Governance (
   grCommitteeL,
   grConstitutionL,
   proposalsActions,
+  proposalsDeposits,
   proposalsAddAction,
   proposalsRemoveWithDescendants,
   proposalsAddVote,
@@ -424,6 +425,7 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do
       dState = certDState certState
       vState = certVState certState
       govState = epochState ^. epochStateGovStateL
+      props = govState ^. cgsProposalsL
       -- Maximum number of blocks we are allowed to roll back
       k = securityParameter globals
       umap = dsUnified dState
@@ -446,7 +448,8 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do
                   , dpEnactState =
                       mkEnactState govState
                         & ensTreasuryL .~ epochState ^. epochStateTreasuryL
-                  , dpProposals = proposalsActions (govState ^. cgsProposalsL)
+                  , dpProposals = proposalsActions props
+                  , dpProposalDeposits = proposalsDeposits props
                   , dpGlobals = globals
                   }
               )

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
@@ -38,7 +37,6 @@ module Cardano.Ledger.Conway.Governance.DRepPulser (
   RunConwayRatify (..),
 ) where
 
-import Cardano.Ledger.Address
 import Cardano.Ledger.BaseTypes (EpochNo (..), Globals (..))
 import Cardano.Ledger.Binary (
   DecCBOR (..),
@@ -59,7 +57,7 @@ import Cardano.Ledger.CertState (CommitteeState)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Era (ConwayRATIFY)
 import Cardano.Ledger.Conway.Governance.Internal
-import Cardano.Ledger.Conway.Governance.Procedures (GovActionState, gasDepositL, gasReturnAddrL)
+import Cardano.Ledger.Conway.Governance.Procedures (GovActionState)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
@@ -72,12 +70,13 @@ import Control.Monad.Trans.Reader (Reader, runReader)
 import Control.State.Transition.Extended
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import Data.Default.Class (Default (..))
-import Data.Foldable (foldl', toList)
+import Data.Foldable (toList)
 import Data.Functor.Identity (Identity)
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
+import Data.Proxy (Proxy (Proxy))
 import Data.Pulse (Pulsable (..), pulse)
 import Data.Sequence.Strict (StrictSeq (..))
 import qualified Data.Sequence.Strict as SS
@@ -175,29 +174,16 @@ instance EraPParams era => FromCBOR (PulsingSnapshot era) where
 --   (c) is the size of the DRepDistr, this grows as the accumulator
 computeDRepDistr ::
   forall era.
+  Proxy era ->
   Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin) ->
   Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)) ->
-  StrictSeq (GovActionState era) ->
+  Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin) ->
   Map (DRep (EraCrypto era)) (CompactForm Coin) ->
   Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era)) ->
   Map (DRep (EraCrypto era)) (CompactForm Coin)
-computeDRepDistr stakeDistr regDReps gass dRepDistr uMapChunk =
+computeDRepDistr _ stakeDistr regDReps proposalDeposits dRepDistr uMapChunk =
   Map.foldlWithKey' go dRepDistr uMapChunk
   where
-    -- QUESTION: Can I memoize this as a field in DRepPulsar? That causes a
-    -- type-error, though that does _not_ get resolved even with AllowAmbiguousTypes
-    -- as `EraCrypto era` is a non-injective type-family
-    proposalDeposits =
-      foldl'
-        ( \gasMap gas ->
-            Map.insertWith
-              addCompact
-              (gas ^. gasReturnAddrL . rewardAccountCredentialL)
-              (fromMaybe (CompactCoin 0) $ toCompact $ gas ^. gasDepositL)
-              gasMap
-        )
-        mempty
-        gass
     go accum stakeCred umElem =
       let stake = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred stakeDistr
           proposalDeposit = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred proposalDeposits
@@ -246,6 +232,8 @@ data DRepPulser era (m :: Type -> Type) ans where
     -- ^ Snapshot of the EnactState, Used to build the Env of the RATIFY rule
     , dpProposals :: !(StrictSeq (GovActionState era))
     -- ^ Snapshot of the proposals. This is the Signal for the RATIFY rule
+    , dpProposalDeposits :: !(Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin))
+    -- ^ Snapshot of the proposal-deposits per reward-account-staking-credential
     , dpGlobals :: !Globals
     } ->
     DRepPulser era m ans
@@ -262,7 +250,7 @@ instance Pulsable (DRepPulser era) where
     | done pulser = pure pulser {dpIndex = 0}
     | otherwise =
         let !chunk = Map.take dpPulseSize $ Map.drop dpIndex $ UMap.umElems dpUMap
-            dRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpProposals dpDRepDistr chunk
+            dRepDistr = computeDRepDistr (Proxy @era) dpStakeDistr dpDRepState dpProposalDeposits dpDRepDistr chunk
          in pure (pulser {dpIndex = dpIndex + dpPulseSize, dpDRepDistr = dRepDistr})
 
   completeM x@(DRepPulser {}) = pure (snd $ finishDRepPulser @era (DRPulsing x))
@@ -271,7 +259,7 @@ deriving instance (EraPParams era, Show ans) => Show (DRepPulser era m ans)
 
 instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era)) where
   showTypeOf _ = "DRepPulser"
-  wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _) =
+  wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _ _) =
     allNoThunks
       [ noThunks ctxt (dpPulseSize drp)
       , noThunks ctxt (dpUMap drp)
@@ -284,11 +272,12 @@ instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era))
       , noThunks ctxt (dpCommitteeState drp)
       , noThunks ctxt (dpEnactState drp)
       , noThunks ctxt (dpProposals drp)
+      , noThunks ctxt (dpProposalDeposits drp)
       , noThunks ctxt (dpGlobals drp)
       ]
 
 instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) where
-  rnf (DRepPulser n um bal stake pool drep dstate ep cs es as gs) =
+  rnf (DRepPulser n um bal stake pool drep dstate ep cs es as pds gs) =
     n `deepseq`
       um `deepseq`
         bal `deepseq`
@@ -300,7 +289,8 @@ instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) wh
                     cs `deepseq`
                       es `deepseq`
                         as `deepseq`
-                          rnf gs
+                          pds `deepseq`
+                            rnf gs
 
 class
   ( STS (ConwayRATIFY era)
@@ -328,19 +318,13 @@ class
                   : map show (toList ps)
           Right ratifyState' -> ratifyState'
 
-finishDRepPulser :: DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
+finishDRepPulser :: forall era. DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
 finishDRepPulser (DRComplete snap ratifyState) = (snap, ratifyState)
 finishDRepPulser (DRPulsing (DRepPulser {..})) =
   (PulsingSnapshot dpProposals finalDRepDistr dpDRepState, ratifyState')
   where
-    !finalDRepDistr =
-      computeDRepDistr
-        dpStakeDistr
-        dpDRepState
-        dpProposals
-        dpDRepDistr
-        $ Map.drop dpIndex
-        $ umElems dpUMap
+    !leftOver = Map.drop dpIndex $ umElems dpUMap
+    !finalDRepDistr = computeDRepDistr (Proxy @era) dpStakeDistr dpDRepState dpProposalDeposits dpDRepDistr leftOver
     !ratifyEnv =
       RatifyEnv
         { reStakeDistr = dpStakeDistr

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

@@ -110,8 +110,10 @@ module Cardano.Ledger.Conway.Governance.Proposals (
   peChildrenL,
   PGraph (..),
   pGraphNodesL,
+  proposalsDeposits,
 ) where
 
+import Cardano.Ledger.Address (rewardAccountCredentialL)
 import Cardano.Ledger.BaseTypes (
   StrictMaybe (..),
   isSJust,
@@ -123,8 +125,12 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (..),
   EncCBOR (..),
  )
+import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
 import Cardano.Ledger.Conway.Governance.Procedures
 import Cardano.Ledger.Core
+import Cardano.Ledger.Credential (Credential)
+import Cardano.Ledger.Keys (KeyRole (Staking))
+import Cardano.Ledger.UMap (addCompact, toCompact)
 import Control.DeepSeq (NFData)
 import Control.Exception (assert)
 import Control.Monad (unless)
@@ -134,6 +140,7 @@ import Data.Either (partitionEithers)
 import Data.Foldable (foldl', foldrM, toList)
 import qualified Data.Map as Map
 import Data.Map.Strict (Map)
+import Data.Maybe (fromMaybe)
 import qualified Data.OMap.Strict as OMap
 import qualified Data.OSet.Strict as OSet
 import Data.Pulse (foldlM')
@@ -476,6 +483,23 @@ proposalsActions ::
   StrictSeq (GovActionState era)
 proposalsActions (Proposals omap _ _) = OMap.toStrictSeq omap
 
+-- | Get a mapping from the reward-account staking credentials to deposits of
+-- all proposals.
+proposalsDeposits ::
+  Proposals era ->
+  Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
+proposalsDeposits =
+  foldl'
+    ( \gasMap gas ->
+        Map.insertWith
+          addCompact
+          (gas ^. gasReturnAddrL . rewardAccountCredentialL)
+          (fromMaybe (CompactCoin 0) $ toCompact $ gas ^. gasDepositL)
+          gasMap
+    )
+    mempty
+    . proposalsActions
+
 -- | Get the sequence of `GovActionId`s
 proposalsIds ::
   Proposals era ->

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs

@@ -633,11 +633,7 @@ votingSpec =
             modifyPParams $ \pp ->
               pp
                 & ppDRepVotingThresholdsL
-                  .~ def
-                    { dvtCommitteeNormal = 51 %! 100
-                    , dvtCommitteeNoConfidence = 51 %! 100
-                    }
-                & ppCommitteeMaxTermLengthL .~ EpochInterval 20
+                  .~ def {dvtCommitteeNormal = 51 %! 100}
                 & ppGovActionDepositL .~ Coin 600_000
             -- Setup DRep delegation without stake #1
             (drepKH1, stakingKH1) <- setupDRepWithoutStake
@@ -666,14 +662,13 @@ votingSpec =
             -- Submit another proposal to bump up the active voting stake
             anotherCC <- KeyHashObj <$> freshKeyHash
             let anotherAddCCAction = UpdateCommittee SNothing mempty (Map.singleton anotherCC 10) (75 %! 100)
-            _anotherAddCCGaid <-
-              submitProposal $
-                ProposalProcedure
-                  { pProcDeposit = Coin 600_000
-                  , pProcReturnAddr = dRepRewardAccount
-                  , pProcGovAction = anotherAddCCAction
-                  , pProcAnchor = def
-                  }
+            submitProposal_ $
+              ProposalProcedure
+                { pProcDeposit = Coin 600_000
+                , pProcReturnAddr = dRepRewardAccount
+                , pProcGovAction = anotherAddCCAction
+                , pProcAnchor = def
+                }
             passNEpochs 2
             -- The same vote should now successfully ratify the proposal
             getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
@@ -682,11 +677,7 @@ votingSpec =
             modifyPParams $ \pp ->
               pp
                 & ppDRepVotingThresholdsL
-                  .~ def
-                    { dvtCommitteeNormal = 51 %! 100
-                    , dvtCommitteeNoConfidence = 51 %! 100
-                    }
-                & ppCommitteeMaxTermLengthL .~ EpochInterval 20
+                  .~ def {dvtCommitteeNormal = 51 %! 100}
                 & ppGovActionDepositL .~ Coin 1_000_000
             -- Setup DRep delegation without stake #1
             (drepKH1, stakingKH1) <- setupDRepWithoutStake
@@ -712,14 +703,13 @@ votingSpec =
                   }
             anotherCC <- KeyHashObj <$> freshKeyHash
             let anotherAddCCAction = UpdateCommittee SNothing mempty (Map.singleton anotherCC 10) (75 %! 100)
-            _anotherAddCCGaid <-
-              submitProposal $
-                ProposalProcedure
-                  { pProcDeposit = Coin 1_000_000
-                  , pProcReturnAddr = dRepRewardAccount3
-                  , pProcGovAction = anotherAddCCAction
-                  , pProcAnchor = def
-                  }
+            submitProposal_ $
+              ProposalProcedure
+                { pProcDeposit = Coin 1_000_000
+                , pProcReturnAddr = dRepRewardAccount3
+                , pProcGovAction = anotherAddCCAction
+                , pProcAnchor = def
+                }
             -- Submit the vote from DRep #1
             submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
             passNEpochs 2

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs

@@ -1225,6 +1225,7 @@ type DRepPulserTypes =
    , CommitteeState (ConwayEra StandardCrypto)
    , EnactState (ConwayEra StandardCrypto)
    , StrictSeq (GovActionState (ConwayEra StandardCrypto))
+   , Map (Credential 'Staking StandardCrypto) (CompactForm Coin)
    ]
 instance
   HasSimpleRep
@@ -1246,11 +1247,12 @@ instance
       dpCommitteeState
       dpEnactState
       dpProposals
+      dpProposalDeposits
   fromSimpleRep rep =
     algebra @'["DRepPulser" ::: DRepPulserTypes]
       rep
-      $ \ps um b sd spd dd ds ce cs es p ->
-        DRepPulser ps um b sd spd dd ds ce cs es p testGlobals
+      $ \ps um b sd spd dd ds ce cs es p pds ->
+        DRepPulser ps um b sd spd dd ds ce cs es p pds testGlobals
 instance
   IsConwayUniv fn =>
   HasSpec fn (DRepPulser (ConwayEra StandardCrypto) Identity (RatifyState (ConwayEra StandardCrypto)))

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Trace/DrepCertTx.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | Generate a Simple Tx with 1 inout, 1 output, and 1 DRep related Cert
 module Test.Cardano.Ledger.Constrained.Trace.DrepCertTx where
@@ -18,8 +19,8 @@ import Cardano.Ledger.Conway.Governance (
   curPParamsGovStateL,
   finishDRepPulser,
   newEpochStateDRepPulsingStateL,
-  proposalsActions,
   proposalsActionsMap,
+  proposalsDeposits,
   proposalsGovStateL,
  )
 import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..), ConwayTxCert (..))
@@ -45,6 +46,7 @@ import qualified Cardano.Ledger.UMap as UMap
 import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import Data.Maybe.Strict (StrictMaybe (..))
+import Data.Proxy (Proxy (Proxy))
 import qualified Data.Set as Set
 import Debug.Trace (trace)
 import Lens.Micro
@@ -216,11 +218,14 @@ pulserWorks mcsfirst mcslast =
     (bruteForceDRepDistr (mcsTickNes mcsfirst) === extractPulsingDRepDistr (mcsNes mcslast))
 
 bruteForceDRepDistr ::
-  ConwayEraGov era => NewEpochState era -> Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
-bruteForceDRepDistr nes = computeDRepDistr incstk dreps props Map.empty $ UMap.umElems umap
+  forall era.
+  ConwayEraGov era =>
+  NewEpochState era ->
+  Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
+bruteForceDRepDistr nes = computeDRepDistr (Proxy @era) incstk dreps propDeps Map.empty $ UMap.umElems umap
   where
     ls = esLState (nesEs nes)
-    props = proposalsActions $ ls ^. lsUTxOStateL . utxosGovStateL . proposalsGovStateL
+    propDeps = proposalsDeposits $ ls ^. lsUTxOStateL . utxosGovStateL . proposalsGovStateL
     cs = lsCertState ls
     IStake incstk _ = utxosStakeDistr (lsUTxOState ls)
     umap = dsUnified (certDState cs)