Merge #2312

2312: Fix #2310 r=edsko a=edsko



Co-authored-by: Edsko de Vries <[email protected]>

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -300,8 +300,8 @@ instance TPraosCrypto sc => HasPartialLedgerConfig (ShelleyBlock sc) where
 instance TPraosCrypto c => CanHardFork (CardanoEras c) where
   hardForkEraTranslation = EraTranslation {
       translateLedgerState   = PCons translateLedgerStateByronToShelleyWrapper   PNil
-    , translateLedgerView    = PCons translateLedgerViewByronToShelleyWrapper    PNil
     , translateChainDepState = PCons translateChainDepStateByronToShelleyWrapper PNil
+    , translateLedgerView    = PCons translateLedgerViewByronToShelleyWrapper    PNil
     }
 
 {-------------------------------------------------------------------------------
@@ -486,12 +486,13 @@ translateLedgerViewByronToShelleyWrapper
   :: forall sc.
      RequiringBoth
        WrapLedgerConfig
-       (Translate WrapLedgerView)
+       (TranslateForecast WrapLedgerView)
        ByronBlock
        (ShelleyBlock sc)
 translateLedgerViewByronToShelleyWrapper =
-    RequireBoth $ \_ (WrapLedgerConfig shelleyCfg) -> Translate $ \epochNo _ ->
-      WrapLedgerView (translateLedgerViewByronToShelley shelleyCfg epochNo)
+    RequireBoth $ \_ (WrapLedgerConfig shelleyCfg) ->
+      TranslateForecast $ \epochNo _forecastFor _finalByronView ->
+        WrapLedgerView (translateLedgerViewByronToShelley shelleyCfg epochNo)
 
 -- | We construct a 'SL.LedgerView' using the Shelley genesis config in the
 -- same way as 'translateLedgerStateByronToShelley'.

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs

@@ -332,13 +332,13 @@ data AnnForecast f blk = AnnForecast {
     }
 
 -- | Change a telescope of a forecast into a forecast of a telescope
-mkHardForkForecast :: InPairs (Translate f) xs
+mkHardForkForecast :: InPairs (TranslateForecast f) xs
                    -> Telescope (Past g) (Current (AnnForecast f)) xs
                    -> Forecast (HardForkLedgerView_ f xs)
 mkHardForkForecast =
     go
   where
-    go :: InPairs (Translate f) xs
+    go :: InPairs (TranslateForecast f) xs
        -> Telescope (Past g) (Current (AnnForecast f)) xs
        -> Forecast (HardForkLedgerView_ f xs)
     go PNil         (TZ f)      = forecastFinalEra f
@@ -376,43 +376,56 @@ forecastFinalEra (Current start AnnForecast{..}) =
 -- NOTE 3: We assume that we only ever have to translate to the /next/
 -- era (as opposed to /any/ subsequent era).
 forecastNotFinal :: forall f blk blk' blks.
-                    Translate f blk blk'
+                    TranslateForecast f blk blk'
                  -> Current (AnnForecast f) blk
                  -> Forecast (HardForkLedgerView_ f (blk ': blk' ': blks))
 forecastNotFinal g (Current start AnnForecast{..}) =
     Forecast (forecastAt annForecast) $ \for ->
-      translateIf annForecastNext for <$> forecastFor annForecast for
+      case mEnd of
+        Just end | for >= boundSlot end -> do
+          -- The forecast is trying to emulate what happens "in reality", where
+          -- the translation from the ledger state of the first era to the next
+          -- era will happen precisely at the transition point. So, we do the
+          -- same in the forecast: we ask the first era for its final ledger
+          -- view (i.e., the view in the final slot in this era), and then
+          -- translate that to a ledger view in the next era. We pass 'for' to
+          -- that translation function so that if any other changes were still
+          -- scheduled to happen in the final ledger view of the first era, it
+          -- can take those into account.
+          --
+          -- NOTE: Upper bound is exclusive so the final slot in this era is
+          -- the predecessor of @boundSlot end@.
+          final :: f blk <- forecastFor annForecast (pred (boundSlot end))
+          let translated :: f blk'
+              translated = translateForecastWith g (boundEpoch end) for final
+
+          return $ HardForkLedgerView {
+              hardForkLedgerViewPerEra = HardForkState $
+                TS (Past start end NoSnapshot) $
+                TZ (Current end translated)
+              -- See documentation of 'TransitionImpossible' for motivation
+            , hardForkLedgerViewTransition =
+                TransitionImpossible
+            }
+
+        _otherwise -> do
+          -- The end of this era is not yet known, or the slot we're
+          -- constructing a forecast for is still within this era.
+          view :: f blk <- forecastFor annForecast for
+
+          return HardForkLedgerView {
+              hardForkLedgerViewPerEra = HardForkState $
+                TZ (Current start view)
+
+              -- We pretend that the anchor of the forecast is the tip.
+            , hardForkLedgerViewTransition =
+                case annForecastNext of
+                  Nothing -> TransitionUnknown (forecastAt annForecast)
+                  Just t  -> TransitionKnown t
+            }
   where
-    -- Translate if the slot is past the end of the epoch
-    translateIf :: Maybe EpochNo
-                -> SlotNo
-                -> f blk
-                -> HardForkLedgerView_ f (blk ': blk' ': blks)
-    translateIf (Just transition) for view | for >= boundSlot end =
-        HardForkLedgerView {
-            hardForkLedgerViewPerEra = HardForkState $
-              TS (Past start end NoSnapshot) $
-              TZ (Current end view')
-          , hardForkLedgerViewTransition =
-              TransitionImpossible
-          }
-      where
-        end :: Bound
-        end = History.mkUpperBound annForecastEraParams start transition
-
-        view' :: f blk'
-        view' = translateWith g (boundEpoch end) view
-
-    -- We pretend that the anchor of the forecast is the tip
-    translateIf mTransition _for view =
-       HardForkLedgerView {
-           hardForkLedgerViewPerEra = HardForkState $
-             TZ (Current start view)
-         , hardForkLedgerViewTransition =
-             case mTransition of
-               Nothing -> TransitionUnknown (forecastAt annForecast)
-               Just t  -> TransitionKnown t
-         }
+    mEnd :: Maybe Bound
+    mEnd = History.mkUpperBound annForecastEraParams start <$> annForecastNext
 
 shiftView :: Past g blk
           -> HardForkLedgerView_ f (blk' : blks)

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs

@@ -9,6 +9,7 @@ module Ouroboros.Consensus.HardFork.Combinator.State.Types (
   , Snapshot(..)
     -- * Supporting types
   , Translate(..)
+  , TranslateForecast(..)
   , TransitionInfo(..)
   ) where
 
@@ -101,10 +102,30 @@ data Snapshot f blk =
   Supporting types
 -------------------------------------------------------------------------------}
 
+-- | Translate @f x@ to @f y@ across an era transition
+--
+-- Typically @f@ will be 'LedgerState' or 'WrapChainDepState'.
 newtype Translate f x y = Translate {
       translateWith :: EpochNo -> f x -> f y
     }
 
+-- | Translate (a forecast of) @f x@ to (a forecast of) @f y@
+-- across an era transition.
+--
+-- Typically @f@ will be 'WrapLedgerView'.
+--
+-- In addition to the 'EpochNo' of the transition, this is also told the
+-- 'SlotNo' we're constructing a forecast for. This enables the translation
+-- function to take into account any scheduled changes that the final ledger
+-- view in the preceding era might have.
+newtype TranslateForecast f x y = TranslateForecast {
+      translateForecastWith ::
+           EpochNo  -- 'EpochNo' of the transition
+        -> SlotNo   -- 'SlotNo' we're constructing a forecast for
+        -> f x
+        -> f y
+    }
+
 -- | Knowledge in a particular era of the transition to the next era
 data TransitionInfo =
     -- | No transition is yet known for this era

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Translation.hs

@@ -12,7 +12,7 @@ import           Cardano.Prelude (NoUnexpectedThunks, OnlyCheckIsWHNF (..))
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
-import           Ouroboros.Consensus.HardFork.Combinator.State.Types (Translate)
+import           Ouroboros.Consensus.HardFork.Combinator.State.Types
 import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
                      (InPairs (..), RequiringBoth (..))
 
@@ -21,9 +21,9 @@ import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
 -------------------------------------------------------------------------------}
 
 data EraTranslation xs = EraTranslation {
-      translateLedgerState   :: InPairs (RequiringBoth WrapLedgerConfig    (Translate LedgerState))       xs
-    , translateLedgerView    :: InPairs (RequiringBoth WrapLedgerConfig    (Translate WrapLedgerView))    xs
-    , translateChainDepState :: InPairs (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState)) xs
+      translateLedgerState   :: InPairs (RequiringBoth WrapLedgerConfig    (Translate LedgerState))            xs
+    , translateChainDepState :: InPairs (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))      xs
+    , translateLedgerView    :: InPairs (RequiringBoth WrapLedgerConfig    (TranslateForecast WrapLedgerView)) xs
     }
   deriving NoUnexpectedThunks
        via OnlyCheckIsWHNF "EraTranslation" (EraTranslation xs)

ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator.hs

@@ -368,8 +368,8 @@ type TestBlock = HardForkBlock '[BlockA, BlockB]
 instance CanHardFork '[BlockA, BlockB] where
   hardForkEraTranslation = EraTranslation {
         translateLedgerState   = PCons ledgerState_AtoB   PNil
-      , translateLedgerView    = PCons ledgerView_AtoB    PNil
       , translateChainDepState = PCons chainDepState_AtoB PNil
+      , translateLedgerView    = PCons ledgerView_AtoB    PNil
       }
 
 versionN2N :: BlockNodeToNodeVersion TestBlock
@@ -418,8 +418,8 @@ ledgerState_AtoB = RequireBoth $ \_ _ -> Translate $ \_ LgrA{..} -> LgrB {
       lgrB_tip = castPoint lgrA_tip
     }
 
-ledgerView_AtoB :: RequiringBoth WrapLedgerConfig (Translate WrapLedgerView) BlockA BlockB
-ledgerView_AtoB = RequireBoth $ \_ _ -> Translate $ \_ _ -> WrapLedgerView ()
-
 chainDepState_AtoB :: RequiringBoth WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
 chainDepState_AtoB = RequireBoth $ \_ _ -> Translate $ \_ _ -> WrapChainDepState ()
+
+ledgerView_AtoB :: RequiringBoth WrapLedgerConfig (TranslateForecast WrapLedgerView) BlockA BlockB
+ledgerView_AtoB = RequireBoth $ \_ _ -> TranslateForecast $ \_ _ _ -> WrapLedgerView ()

ouroboros-consensus/test-consensus/Test/Consensus/HardFork/History.hs

@@ -818,7 +818,7 @@ mockHardForkLedgerView :: SListI xs
                        -> Forecast (HardForkLedgerView_ (K ()) xs)
 mockHardForkLedgerView = \(HF.Shape pss) (HF.Transitions ts) (Chain ess) ->
     mkHardForkForecast
-      (InPairs.hpure $ Translate $ \_epoch (K ()) -> K ())
+      (InPairs.hpure $ TranslateForecast $ \_epoch _slot (K ()) -> K ())
       (mockState HF.initBound pss ts ess)
   where
     mockState :: HF.Bound