Improve safety of PParams prediction with the use of new specialize…

…d type `FuturePParams`

eras/allegra/impl/src/Cardano/Ledger/Allegra/PParams.hs

@@ -51,6 +51,6 @@ instance Crypto c => EraGov (AllegraEra c) where
 
   prevPParamsGovStateL = prevPParamsShelleyGovStateL
 
-  futurePParamsGovStateG = futurePParamsShelleyGovStateL
+  futurePParamsGovStateL = futurePParamsShelleyGovStateL
 
   obligationGovState = const mempty

eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -88,6 +89,12 @@ instance Crypto c => TranslateEra (AllegraEra c) PParams
 
 instance Crypto c => TranslateEra (AllegraEra c) PParamsUpdate
 
+instance Crypto c => TranslateEra (AllegraEra c) FuturePParams where
+  translateEra ctxt = \case
+    NoPParamsUpdate -> pure NoPParamsUpdate
+    DefinitePParamsUpdate pp -> DefinitePParamsUpdate <$> translateEra ctxt pp
+    PotentialPParamsUpdate mpp -> PotentialPParamsUpdate <$> mapM (translateEra ctxt) mpp
+
 instance Crypto c => TranslateEra (AllegraEra c) ProposedPPUpdates where
   translateEra ctxt (ProposedPPUpdates ppup) =
     return $ ProposedPPUpdates $ Map.map (translateEra' ctxt) ppup
@@ -100,7 +107,7 @@ instance Crypto c => TranslateEra (AllegraEra c) ShelleyGovState where
         , sgsFutureProposals = translateEra' ctxt $ sgsFutureProposals ps
         , sgsCurPParams = translateEra' ctxt $ sgsCurPParams ps
         , sgsPrevPParams = translateEra' ctxt $ sgsPrevPParams ps
-        , sgsFuturePParams = translateEra' ctxt <$> sgsFuturePParams ps
+        , sgsFuturePParams = translateEra' ctxt $ sgsFuturePParams ps
         }
 
 instance Crypto c => TranslateEra (AllegraEra c) ShelleyTxOut where

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs

@@ -385,7 +385,7 @@ instance Crypto c => EraGov (AlonzoEra c) where
 
   prevPParamsGovStateL = prevPParamsShelleyGovStateL
 
-  futurePParamsGovStateG = futurePParamsShelleyGovStateL
+  futurePParamsGovStateL = futurePParamsShelleyGovStateL
 
   obligationGovState = const mempty
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -68,6 +69,12 @@ instance Crypto c => TranslateEra (AlonzoEra c) NewEpochState where
 instance Crypto c => TranslateEra (AlonzoEra c) PParams where
   translateEra (AlonzoGenesisWrapper upgradeArgs) = pure . upgradePParams upgradeArgs
 
+instance Crypto c => TranslateEra (AlonzoEra c) FuturePParams where
+  translateEra ctxt = \case
+    NoPParamsUpdate -> pure NoPParamsUpdate
+    DefinitePParamsUpdate pp -> DefinitePParamsUpdate <$> translateEra ctxt pp
+    PotentialPParamsUpdate mpp -> PotentialPParamsUpdate <$> mapM (translateEra ctxt) mpp
+
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
 instance Crypto c => TranslateEra (AlonzoEra c) Tx where
@@ -152,7 +159,7 @@ instance Crypto c => TranslateEra (AlonzoEra c) ShelleyGovState where
         , sgsFutureProposals = translateEra' ctxt $ sgsFutureProposals ps
         , sgsCurPParams = translateEra' ctxt $ sgsCurPParams ps
         , sgsPrevPParams = translateEra' ctxt $ sgsPrevPParams ps
-        , sgsFuturePParams = translateEra' ctxt <$> sgsFuturePParams ps
+        , sgsFuturePParams = translateEra' ctxt $ sgsFuturePParams ps
         }
 
 instance Crypto c => TranslateEra (AlonzoEra c) ProposedPPUpdates where

eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs

@@ -271,7 +271,7 @@ instance Crypto c => EraGov (BabbageEra c) where
 
   prevPParamsGovStateL = prevPParamsShelleyGovStateL
 
-  futurePParamsGovStateG = futurePParamsShelleyGovStateL
+  futurePParamsGovStateL = futurePParamsShelleyGovStateL
 
   obligationGovState = const mempty
 

eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -93,6 +94,12 @@ instance Crypto c => TranslateEra (BabbageEra c) Tx where
 instance Crypto c => TranslateEra (BabbageEra c) PParams where
   translateEra _ = pure . upgradePParams ()
 
+instance Crypto c => TranslateEra (BabbageEra c) FuturePParams where
+  translateEra ctxt = \case
+    NoPParamsUpdate -> pure NoPParamsUpdate
+    DefinitePParamsUpdate pp -> DefinitePParamsUpdate <$> translateEra ctxt pp
+    PotentialPParamsUpdate mpp -> PotentialPParamsUpdate <$> mapM (translateEra ctxt) mpp
+
 instance Crypto c => TranslateEra (BabbageEra c) EpochState where
   translateEra ctxt es =
     pure
@@ -158,7 +165,7 @@ instance Crypto c => TranslateEra (BabbageEra c) ShelleyGovState where
         , sgsFutureProposals = translateEra' ctxt $ sgsFutureProposals ps
         , sgsCurPParams = translateEra' ctxt $ sgsCurPParams ps
         , sgsPrevPParams = translateEra' ctxt $ sgsPrevPParams ps
-        , sgsFuturePParams = translateEra' ctxt <$> sgsFuturePParams ps
+        , sgsFuturePParams = translateEra' ctxt $ sgsFuturePParams ps
         }
 
 instance Crypto c => TranslateEra (BabbageEra c) ProposedPPUpdates where

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

@@ -89,6 +89,7 @@ module Cardano.Ledger.Conway.Governance (
   cgsDRepPulsingStateL,
   cgsCurPParamsL,
   cgsPrevPParamsL,
+  cgsFuturePParamsL,
   cgsCommitteeL,
   cgsConstitutionL,
   ensCommitteeL,
@@ -235,6 +236,7 @@ data ConwayGovState era = ConwayGovState
   , cgsConstitution :: !(Constitution era)
   , cgsCurPParams :: !(PParams era)
   , cgsPrevPParams :: !(PParams era)
+  , cgsFuturePParams :: !(FuturePParams era)
   , cgsDRepPulsingState :: !(DRepPulsingState era)
   -- ^ The 'cgsDRepPulsingState' field is a pulser that incrementally computes the stake
   -- distribution of the DReps over the Epoch following the close of voting at end of
@@ -266,6 +268,10 @@ cgsCurPParamsL = lens cgsCurPParams (\x y -> x {cgsCurPParams = y})
 cgsPrevPParamsL :: Lens' (ConwayGovState era) (PParams era)
 cgsPrevPParamsL = lens cgsPrevPParams (\x y -> x {cgsPrevPParams = y})
 
+cgsFuturePParamsL :: Lens' (ConwayGovState era) (FuturePParams era)
+cgsFuturePParamsL =
+  lens cgsFuturePParams (\cgs futurePParams -> cgs {cgsFuturePParams = futurePParams})
+
 govStatePrevGovActionIds :: ConwayEraGov era => GovState era -> GovRelation StrictMaybe era
 govStatePrevGovActionIds = view $ proposalsGovStateL . pRootsL . to toPrevGovActionIds
 
@@ -276,11 +282,25 @@ conwayGovStateDRepDistrG = to (\govst -> (psDRepDistr . fst) $ finishDRepPulser
 getRatifyState :: ConwayGovState era -> RatifyState era
 getRatifyState (ConwayGovState {cgsDRepPulsingState}) = snd $ finishDRepPulser cgsDRepPulsingState
 
-predictFuturePParams :: ConwayGovState era -> Maybe (PParams era)
-predictFuturePParams govState = do
-  guard (any hasChangesToPParams (rsEnacted ratifyState))
-  pure (ensCurPParams (rsEnactState ratifyState))
+-- | This function updates the thunk, which will contain new PParams once evaluated or
+-- Nothing when there was no update. At the same time if we already know the future of
+-- PParams, then it will act as an identity function.
+predictFuturePParams :: ConwayGovState era -> ConwayGovState era
+predictFuturePParams govState =
+  case cgsFuturePParams govState of
+    NoPParamsUpdate -> govState
+    DefinitePParamsUpdate _ -> govState
+    _ ->
+      govState
+        { cgsFuturePParams = PotentialPParamsUpdate newFuturePParams
+        }
   where
+    -- This binding is not forced until a call to `solidifyNextEpochPParams` in the TICK
+    -- rule two stability windows before the end of the epoch, therefore it is safe to
+    -- create thunks here throughout the epoch
+    newFuturePParams = do
+      guard (any hasChangesToPParams (rsEnacted ratifyState))
+      pure (ensCurPParams (rsEnactState ratifyState))
     ratifyState = extractDRepPulsingState (cgsDRepPulsingState govState)
     hasChangesToPParams gas =
       case pProcGovAction (gasProposalProcedure gas) of
@@ -311,6 +331,7 @@ instance EraPParams era => DecShareCBOR (ConwayGovState era) where
         <! From
         <! From
         <! From
+        <! From
 
 instance EraPParams era => DecCBOR (ConwayGovState era) where
   decCBOR = decNoShareCBOR
@@ -324,6 +345,7 @@ instance EraPParams era => EncCBOR (ConwayGovState era) where
         !> To cgsConstitution
         !> To cgsCurPParams
         !> To cgsPrevPParams
+        !> To cgsFuturePParams
         !> To cgsDRepPulsingState
 
 instance EraPParams era => ToCBOR (ConwayGovState era) where
@@ -333,7 +355,7 @@ instance EraPParams era => FromCBOR (ConwayGovState era) where
   fromCBOR = fromEraCBOR @era
 
 instance EraPParams era => Default (ConwayGovState era) where
-  def = ConwayGovState def def def def def (DRComplete def def)
+  def = ConwayGovState def def def def def def (DRComplete def def)
 
 instance EraPParams era => NFData (ConwayGovState era)
 
@@ -344,14 +366,15 @@ instance EraPParams era => ToJSON (ConwayGovState era) where
   toEncoding = pairs . mconcat . toConwayGovPairs
 
 toConwayGovPairs :: (KeyValue e a, EraPParams era) => ConwayGovState era -> [a]
-toConwayGovPairs cg@(ConwayGovState _ _ _ _ _ _) =
+toConwayGovPairs cg@(ConwayGovState _ _ _ _ _ _ _) =
   let ConwayGovState {..} = cg
    in [ "proposals" .= cgsProposals
       , "nextRatifyState" .= extractDRepPulsingState cgsDRepPulsingState
       , "committee" .= cgsCommittee
       , "constitution" .= cgsConstitution
       , "currentPParams" .= cgsCurPParams
       , "previousPParams" .= cgsPrevPParams
+      , "futurePParams" .= cgsFuturePParams
       ]
 
 instance EraPParams (ConwayEra c) => EraGov (ConwayEra c) where
@@ -361,7 +384,7 @@ instance EraPParams (ConwayEra c) => EraGov (ConwayEra c) where
 
   prevPParamsGovStateL = cgsPrevPParamsL
 
-  futurePParamsGovStateG = to predictFuturePParams
+  futurePParamsGovStateL = cgsFuturePParamsL
 
   obligationGovState st =
     Obligations

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

@@ -52,6 +52,7 @@ import Cardano.Ledger.Conway.Governance (
   cgsCommitteeL,
   cgsConstitutionL,
   cgsCurPParamsL,
+  cgsFuturePParamsL,
   cgsPrevPParamsL,
   cgsProposalsL,
   dormantEpoch,
@@ -334,8 +335,9 @@ epochTransition = do
         & cgsProposalsL .~ newProposals
         & cgsCommitteeL .~ ensCommittee
         & cgsConstitutionL .~ ensConstitution
-        & cgsCurPParamsL .~ ensCurPParams
+        & cgsCurPParamsL .~ nextEpochPParams govState0
         & cgsPrevPParamsL .~ curPParams
+        & cgsFuturePParamsL .~ PotentialPParamsUpdate Nothing
 
     allRemovedGovActions = expiredActions `Map.union` enactedActions
     (newUMap, unclaimed) =

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

@@ -36,6 +36,7 @@ import Cardano.Ledger.Conway.Governance (
   RatifySignal (..),
   RatifyState (..),
   newEpochStateDRepPulsingStateL,
+  predictFuturePParams,
   pulseDRepPulsingState,
  )
 import Cardano.Ledger.Conway.Rules.Epoch (ConwayEpochEvent)
@@ -170,7 +171,11 @@ newEpochTransition = do
       ) <-
     judgmentContext
   if eNo /= succ eL
-    then pure $ nes & newEpochStateDRepPulsingStateL %~ pulseDRepPulsingState
+    then
+      pure $
+        nes
+          & newEpochStateDRepPulsingStateL %~ pulseDRepPulsingState
+          & newEpochStateGovStateL %~ predictFuturePParams
     else do
       es1 <- case ru of -- Here is where we extract the result of Reward pulsing.
         SNothing -> pure es0

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

@@ -10,14 +10,13 @@ module Cardano.Ledger.Conway.Rules.Tickf (
 )
 where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase, SlotNo, epochInfoPure)
+import Cardano.Ledger.BaseTypes (ShelleyBase, SlotNo)
 import Cardano.Ledger.Conway.Era
 import Cardano.Ledger.Core
 import Cardano.Ledger.EpochBoundary (SnapShots (ssStakeMarkPoolDistr))
 import Cardano.Ledger.Shelley.Governance
 import Cardano.Ledger.Shelley.LedgerState
-import Cardano.Ledger.Slot (epochInfoEpoch)
-import Control.Monad.Trans.Reader (asks)
+import Cardano.Ledger.Shelley.Rules (solidifyNextEpochPParams)
 import Control.State.Transition
 import GHC.Generics (Generic)
 import Lens.Micro ((&), (.~), (^.))
@@ -60,34 +59,25 @@ instance
 
   initialRules = []
   transitionRules = pure $ do
-    TRC ((), nes, slot) <- judgmentContext
+    TRC ((), nes0, slot) <- judgmentContext
     -- This whole function is a specialization of an inlined 'NEWEPOCH'.
     --
     -- The ledger view, 'LedgerView', is built entirely from the 'nesPd' and 'esPp' and
     -- 'dsGenDelegs', so the correctness of 'validatingTickTransitionFORECAST' only
     -- depends on getting these three fields correct.
 
-    epoch <- liftSTS $ do
-      ei <- asks epochInfoPure
-      epochInfoEpoch ei slot
+    (curEpochNo, nes) <- liftSTS $ solidifyNextEpochPParams nes0 slot
 
     let es = nesEs nes
         ss = esSnapshots es
 
     -- the relevant 'NEWEPOCH' logic
     let pd' = ssStakeMarkPoolDistr ss
 
-    if epoch /= succ (nesEL nes)
+    if curEpochNo /= succ (nesEL nes)
       then pure nes
       else do
         let govState = nes ^. newEpochStateGovStateL
-            -- TICKF is only ever called at most one stability window into the future,
-            -- which means that `futurePParamsGovStateG` will be known at this point at
-            -- will be O(1) lookup.
-            newPParams =
-              case govState ^. futurePParamsGovStateG of
-                Nothing -> govState ^. curPParamsGovStateL
-                Just futurePParams -> futurePParams
         -- We can skip 'SNAP'; we already have the equivalent pd'.
 
         -- We can skip 'POOLREAP';
@@ -97,4 +87,7 @@ instance
         -- return value here was used to validate their headers.
 
         pure $!
-          nes {nesPd = pd'} & newEpochStateGovStateL . curPParamsGovStateL .~ newPParams
+          nes {nesPd = pd'}
+            & newEpochStateGovStateL . curPParamsGovStateL .~ nextEpochPParams govState
+            & newEpochStateGovStateL . prevPParamsGovStateL .~ (govState ^. curPParamsGovStateL)
+            & newEpochStateGovStateL . futurePParamsGovStateL .~ NoPParamsUpdate

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -28,6 +29,7 @@ import Cardano.Ledger.Conway.Governance (
   cgsCommitteeL,
   cgsConstitutionL,
   cgsCurPParamsL,
+  cgsFuturePParamsL,
   cgsPrevPParamsL,
   mkEnactState,
   rsEnactStateL,
@@ -119,6 +121,12 @@ instance Crypto c => TranslateEra (ConwayEra c) Tx where
 instance Crypto c => TranslateEra (ConwayEra c) PParams where
   translateEra ConwayGenesis {cgUpgradePParams} = pure . upgradePParams cgUpgradePParams
 
+instance Crypto c => TranslateEra (ConwayEra c) FuturePParams where
+  translateEra ctxt = \case
+    NoPParamsUpdate -> pure NoPParamsUpdate
+    DefinitePParamsUpdate pp -> DefinitePParamsUpdate <$> translateEra ctxt pp
+    PotentialPParamsUpdate mpp -> PotentialPParamsUpdate <$> mapM (translateEra ctxt) mpp
+
 instance Crypto c => TranslateEra (ConwayEra c) EpochState where
   translateEra ctxt es =
     pure $
@@ -168,9 +176,11 @@ translateGovState ::
 translateGovState ctxt@ConwayGenesis {..} sgov =
   let curPParams = translateEra' ctxt (sgov ^. curPParamsGovStateL)
       prevPParams = translateEra' ctxt (sgov ^. prevPParamsGovStateL)
+      futurePParams = translateEra' ctxt (sgov ^. futurePParamsGovStateL)
    in emptyGovState
         & cgsCurPParamsL .~ curPParams
         & cgsPrevPParamsL .~ prevPParams
+        & cgsFuturePParamsL .~ futurePParams
         & cgsCommitteeL .~ SJust cgCommittee
         & cgsConstitutionL .~ cgConstitution
 
@@ -181,9 +191,7 @@ instance Crypto c => TranslateEra (ConwayEra c) UTxOState where
         { API.utxosUtxo = translateEra' ctxt $ API.utxosUtxo us
         , API.utxosDeposited = API.utxosDeposited us
         , API.utxosFees = API.utxosFees us
-        , API.utxosGovState =
-            translateGovState ctxt $
-              API.utxosGovState us
+        , API.utxosGovState = translateGovState ctxt $ API.utxosGovState us
         , API.utxosStakeDistr = API.utxosStakeDistr us
         , API.utxosDonation = API.utxosDonation us
         }

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs

@@ -166,6 +166,7 @@ instance
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
+      <*> arbitrary
 
 instance
   (Era era, Arbitrary (PParams era), Arbitrary (PParamsUpdate era)) =>

eras/mary/impl/src/Cardano/Ledger/Mary/PParams.hs

@@ -58,6 +58,6 @@ instance Crypto c => EraGov (MaryEra c) where
 
   prevPParamsGovStateL = prevPParamsShelleyGovStateL
 
-  futurePParamsGovStateG = futurePParamsShelleyGovStateL
+  futurePParamsGovStateL = futurePParamsShelleyGovStateL
 
   obligationGovState = const mempty