diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 452c05751e5..701da4f3527 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/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 } ) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs index f99433b4875..280e436ebfa 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs +++ b/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 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs index db4fc9886c3..bd0eb08bb2e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs +++ b/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 -> diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 41b9c0af144..8838a9ba10a 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/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 diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs index 0477e2facd7..296cd2de8cd 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs +++ b/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))) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Trace/DrepCertTx.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Trace/DrepCertTx.hs index 91bf9974f11..05d1330a1cb 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Trace/DrepCertTx.hs +++ b/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) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs index af058274df9..b0d1501f531 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs @@ -82,6 +82,8 @@ import Cardano.Ledger.Conway.Governance ( RatifyState (..), RunConwayRatify (..), Vote (..), + pPropsL, + proposalsDeposits, ) import Cardano.Ledger.Conway.TxCert (ConwayTxCert (..), Delegatee (..)) import qualified Cardano.Ledger.Core as Core @@ -107,10 +109,12 @@ import Cardano.Ledger.Val (Val ((<+>))) import Control.Monad.Identity (Identity) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Default.Class (def) import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe +import qualified Data.OMap.Strict as OMap import qualified Data.Sequence.Strict as SS import Data.Set (Set) import qualified Data.Set as Set @@ -936,12 +940,13 @@ genSizedRep _ EnactStateR = EnactState <$> arbitrary <*> arbitrary - <*> (unPParams <$> (genPParams reify)) - <*> (unPParams <$> (genPParams reify)) + <*> (unPParams <$> genPParams reify) + <*> (unPParams <$> genPParams reify) <*> arbitrary <*> arbitrary <*> arbitrary -genSizedRep _ DRepPulserR = +genSizedRep _ DRepPulserR = do + props <- SS.fromList . (: []) <$> genRep GovActionStateR DRepPulser <$> arbitrary -- pulsesize <*> arbitrary -- umap @@ -953,7 +958,8 @@ genSizedRep _ DRepPulserR = <*> arbitrary -- epoch <*> arbitrary -- committeestate <*> genRep EnactStateR - <*> (SS.fromList . (: []) <$> genRep GovActionStateR) -- proposals + <*> pure props + <*> pure (proposalsDeposits $ def & pPropsL .~ OMap.fromFoldable props) <*> pure testGlobals genSizedRep n DelegateeR = oneof diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs index 220c9991b54..d40999b4f28 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs @@ -103,6 +103,7 @@ import Data.Functor.Identity (Identity) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe) +import qualified Data.OMap.Strict as OMap import Data.Ratio ((%)) import qualified Data.Sequence.Strict as SS import Data.Set (Set) @@ -1862,6 +1863,7 @@ initPulser proof utx credDRepMap poold credDRepStateMap epoch commstate enactsta (CommitteeState commstate) enactstate (SS.fromList govstates) + (proposalsDeposits $ def & pPropsL .~ OMap.fromFoldable govstates) -- treas testGlobals