Implement future PParams for Shelley

This commit makes UPEC rule obsolete, because it brings into the ledger
state the future value of the PParams, which no longer need to be
computed and can be just looked up in the state.

The future PParams are being updated on each vote and whenever future
proposals are being rotated to the current proposals.

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +17,7 @@ module Cardano.Ledger.Shelley.Rules.Newpp (
   PredicateFailure,
 ) where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase)
+import Cardano.Ledger.BaseTypes (Globals (quorum), ShelleyBase)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.Era (ShelleyNEWPP)
@@ -32,18 +33,22 @@ import Cardano.Ledger.Shelley.PParams (
   emptyPPPUpdates,
   hasLegalProtVerUpdate,
  )
+import Cardano.Ledger.Shelley.Rules.Ppup (votedFuturePParams)
 import Control.DeepSeq (NFData)
 import Control.Monad (forM_)
+import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition (
   STS (..),
   TRC (..),
   TransitionRule,
   judgmentContext,
+  liftSTS,
   (?!),
  )
 import Data.Default.Class (Default, def)
+import Data.Word (Word64)
 import GHC.Generics (Generic)
-import Lens.Micro ((&), (.~), (^.))
+import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks (..))
 
 data ShelleyNewppState era
@@ -106,13 +111,14 @@ newPpTransition = do
       == utxosDeposited utxoState
         ?! UnexpectedDepositPot obligationCurr (utxosDeposited utxoState)
 
+  coreNodeQuorum <- liftSTS $ asks quorum
   case mppNew of
     Just ppNew
       | toInteger (ppNew ^. ppMaxTxSizeL)
           + toInteger (ppNew ^. ppMaxBHSizeL)
           < toInteger (ppNew ^. ppMaxBBSizeL) ->
-          pure $ NewppState ppNew $ updatePpup ppupState ppNew
-    _ -> pure $ NewppState pp $ updatePpup ppupState pp
+          pure $ NewppState ppNew $ updatePpup coreNodeQuorum ppupState ppNew
+    _ -> pure $ NewppState pp $ updatePpup coreNodeQuorum ppupState pp
 
 -- | Update the protocol parameter updates by clearing out the proposals
 -- and making the future proposals become the new proposals,
@@ -122,16 +128,19 @@ updatePpup ::
   , GovState era ~ ShelleyGovState era
   , ProtVerAtMost era 8
   ) =>
+  Word64 ->
   GovState era ->
   PParams era ->
   ShelleyGovState era
-updatePpup ppupState pp =
+updatePpup !coreNodeQuorum ppupState pp =
   ppupState
-    & proposalsL .~ ps
-    & futureProposalsL .~ emptyPPPUpdates
+    { sgsCurProposals = curProposals
+    , sgsFutureProposals = emptyPPPUpdates
+    , sgsFuturePParams = votedFuturePParams curProposals pp coreNodeQuorum
+    }
   where
     ProposedPPUpdates newProposals = sgsFutureProposals ppupState
-    ps =
+    curProposals =
       if all (hasLegalProtVerUpdate pp) newProposals
         then ProposedPPUpdates newProposals
         else emptyPPPUpdates

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -19,11 +20,12 @@ module Cardano.Ledger.Shelley.Rules.Ppup (
   PredicateFailure,
   VotingPeriod (..),
   PPUPPredFailure,
+  votedFuturePParams,
 )
 where
 
 import Cardano.Ledger.BaseTypes (
-  Globals (stabilityWindow),
+  Globals (quorum, stabilityWindow),
   ProtVer,
   ShelleyBase,
   StrictMaybe (..),
@@ -59,8 +61,9 @@ import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (dom, eval, (⊆), (⨃))
 import Control.State.Transition
 import qualified Data.Foldable as F (find)
+import qualified Data.Map as Map
 import Data.Set (Set)
-import Data.Word (Word8)
+import Data.Word (Word64, Word8)
 import GHC.Generics (Generic)
 import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks (..))
@@ -204,10 +207,13 @@ ppupTransitionNonEmpty = do
         then do
           (currentEpochNo == targetEpochNo)
             ?! PPUpdateWrongEpoch currentEpochNo targetEpochNo VoteForThisEpoch
+          let curProposals = ProposedPPUpdates (eval (pupS ⨃ pup))
+          !coreNodeQuorum <- liftSTS $ asks quorum
           pure $
             pps
-              { sgsCurProposals = ProposedPPUpdates (eval (pupS ⨃ pup))
+              { sgsCurProposals = curProposals
               , sgsFutureProposals = ProposedPPUpdates fpupS
+              , sgsFuturePParams = votedFuturePParams curProposals pp coreNodeQuorum
               }
         else do
           (succ currentEpochNo == targetEpochNo)
@@ -220,3 +226,34 @@ ppupTransitionNonEmpty = do
 
 type PPUPPredFailure era = EraRuleFailure "PPUP" era
 {-# DEPRECATED PPUPPredFailure "In favor of `EraRuleFailure` PPUP era" #-}
+
+-- | If at least @n@ nodes voted to change __the same__ protocol parameters to
+-- __the same__ values, return the given protocol parameters updated to these
+-- values. Here @n@ is the quorum needed.
+votedFuturePParams ::
+  forall era.
+  EraPParams era =>
+  ProposedPPUpdates era ->
+  -- | Protocol parameters to which the change will be applied.
+  PParams era ->
+  -- | Quorum needed to change the protocol parameters.
+  Word64 ->
+  Maybe (PParams era)
+votedFuturePParams (ProposedPPUpdates pppu) pp quorumN =
+  let votes =
+        Map.foldr
+          (\vote -> Map.insertWith (+) vote 1)
+          (Map.empty :: Map.Map (PParamsUpdate era) Word64)
+          pppu
+      consensus = Map.filter (>= quorumN) votes
+   in case Map.keys consensus of
+        -- NOTE that `quorumN` is a global constant, and that we require
+        -- it to be strictly greater than half the number of genesis nodes.
+        -- The keys in the `pup` correspond to the genesis nodes,
+        -- and therefore either:
+        --   1) `consensus` is empty, or
+        --   2) `consensus` has exactly one element.
+        [ppu] -> Just $ applyPPUpdates pp ppu
+        -- NOTE that `updatePParams` corresponds to the union override right
+        -- operation in the formal spec.
+        _ -> Nothing

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Upec.hs

@@ -23,7 +23,7 @@ module Cardano.Ledger.Shelley.Rules.Upec (
   votedValue,
 ) where
 
-import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase)
+import Cardano.Ledger.BaseTypes (ShelleyBase)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.Era (ShelleyUPEC)
 import Cardano.Ledger.Shelley.Governance
@@ -39,19 +39,16 @@ import Cardano.Ledger.Shelley.Rules.Newpp (
   ShelleyNewppPredFailure,
   ShelleyNewppState (..),
  )
+import Cardano.Ledger.Shelley.Rules.Ppup (votedFuturePParams)
 import Control.DeepSeq (NFData)
-import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition (
   Embed (..),
   STS (..),
   TRC (..),
   judgmentContext,
-  liftSTS,
   trans,
  )
 import Data.Default.Class (Default)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 
@@ -97,50 +94,26 @@ instance
             ) <-
           judgmentContext
 
-        coreNodeQuorum <- liftSTS $ asks quorum
-
         let utxoState = lsUTxOState ls
-            pup = sgsCurProposals ppupState
-            ppNew = votedValue pup pp (fromIntegral coreNodeQuorum)
+            ppNew = sgsFuturePParams ppupState
         NewppState pp' ppupState' <-
           trans @(ShelleyNEWPP era) $
             TRC (NewppEnv (lsCertState ls) utxoState, NewppState pp ppupState, ppNew)
         pure $! UpecState pp' ppupState'
     ]
 
--- | If at least @n@ nodes voted to change __the same__ protocol parameters to
--- __the same__ values, return the given protocol parameters updated to these
--- values. Here @n@ is the quorum needed.
+instance
+  (Era era, STS (ShelleyNEWPP era)) =>
+  Embed (ShelleyNEWPP era) (ShelleyUPEC era)
+  where
+  wrapFailed = NewPpFailure
+
 votedValue ::
   forall era.
   EraPParams era =>
   ProposedPPUpdates era ->
-  -- | Protocol parameters to which the change will be applied.
   PParams era ->
-  -- | Quorum needed to change the protocol parameters.
   Int ->
   Maybe (PParams era)
-votedValue (ProposedPPUpdates pppu) pp quorumN =
-  let votes =
-        Map.foldr
-          (\vote -> Map.insertWith (+) vote 1)
-          (Map.empty :: Map (PParamsUpdate era) Int)
-          pppu
-      consensus = Map.filter (>= quorumN) votes
-   in case Map.keys consensus of
-        -- NOTE that `quorumN` is a global constant, and that we require
-        -- it to be strictly greater than half the number of genesis nodes.
-        -- The keys in the `pup` correspond to the genesis nodes,
-        -- and therefore either:
-        --   1) `consensus` is empty, or
-        --   2) `consensus` has exactly one element.
-        [ppu] -> Just $ applyPPUpdates pp ppu
-        -- NOTE that `updatePParams` corresponds to the union override right
-        -- operation in the formal spec.
-        _ -> Nothing
-
-instance
-  (Era era, STS (ShelleyNEWPP era)) =>
-  Embed (ShelleyNEWPP era) (ShelleyUPEC era)
-  where
-  wrapFailed = NewPpFailure
+votedValue ppups pp = votedFuturePParams ppups pp . fromIntegral
+{-# DEPRECATED votedValue "In favo of `votedFuturePParams`" #-}

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

@@ -57,9 +57,7 @@ import Cardano.Ledger.Shelley.LedgerState (
   rs,
  )
 import Cardano.Ledger.Shelley.Rewards (sumRewards)
-import Cardano.Ledger.Shelley.Rules (
-  votedValue,
- )
+import Cardano.Ledger.Shelley.Rules (votedFuturePParams)
 import Cardano.Ledger.Shelley.Rules.Reports (
   showCred,
   showIR,
@@ -242,7 +240,7 @@ checkPreservation SourceSignalTarget {source, target, signal} count =
     oldPoolDeposit = psDeposits . certPState . lsCertState $ lsOld
     newPoolDeposit = psDeposits . certPState . lsCertState $ lsNew
 
-    proposal = votedValue (sgsCurProposals . utxosGovState . lsUTxOState $ lsOld) currPP 5
+    proposal = votedFuturePParams (sgsCurProposals . utxosGovState $ lsUTxOState lsOld) currPP 5
     obligationMsgs = case proposal of
       Nothing -> []
       Just proposal' ->