HFC ledger cross-era ticking: use tick-translate-tick strategy

See #339 for
explanation/motivation.

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

@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork (
   , ShelleyPartialLedgerConfig (..)
   , forecastAcrossShelley
   , translateChainDepStateAcrossShelley
+  , translateLedgerStateAcrossShelley
   ) where
 
 import qualified Cardano.Chain.Common as CC
@@ -273,11 +274,11 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
   hardForkEraTranslation = EraTranslation {
       translateLedgerState   =
           PCons translateLedgerStateByronToShelleyWrapper
-        $ PCons translateLedgerStateShelleyToAllegraWrapper
-        $ PCons translateLedgerStateAllegraToMaryWrapper
-        $ PCons translateLedgerStateMaryToAlonzoWrapper
-        $ PCons translateLedgerStateAlonzoToBabbageWrapper
-        $ PCons translateLedgerStateBabbageToConwayWrapper
+        $ PCons translateLedgerStateAcrossShelley
+        $ PCons translateLedgerStateAcrossShelley
+        $ PCons translateLedgerStateAcrossShelley
+        $ PCons translateLedgerStateAcrossShelley
+        $ PCons translateLedgerStateAcrossShelley
         $ PNil
     , translateChainDepState =
           PCons translateChainDepStateByronToShelleyWrapper
@@ -313,8 +314,8 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
                     translateTxAllegraToMaryWrapper
                     translateValidatedTxAllegraToMaryWrapper
               )
-      $ PCons (RequireBoth $ \_cfgMary cfgAlonzo ->
-                let ctxt = getAlonzoTranslationContext cfgAlonzo
+      $ PCons (RequireBoth $ \_cfgMary (WrapLedgerConfig cfgAlonzo) ->
+                let ctxt = shelleyLedgerTranslationContext cfgAlonzo
                 in
                 Pair2
                   (translateTxMaryToAlonzoWrapper          ctxt)
@@ -327,8 +328,8 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
                   (translateTxAlonzoToBabbageWrapper          ctxt)
                   (translateValidatedTxAlonzoToBabbageWrapper ctxt)
               )
-      $ PCons (RequireBoth $ \_cfgBabbage cfgConway ->
-                let ctxt = getConwayTranslationContext cfgConway
+      $ PCons (RequireBoth $ \_cfgBabbage (WrapLedgerConfig cfgConway) ->
+                let ctxt = shelleyLedgerTranslationContext cfgConway
                 in
                 Pair2
                   (translateTxBabbageToConwayWrapper          ctxt)
@@ -383,22 +384,22 @@ translateLedgerStateByronToShelleyWrapper ::
      )
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (TickedTranslate LedgerState)
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
 translateLedgerStateByronToShelleyWrapper =
     RequireBoth $ \_ (WrapLedgerConfig cfgShelley) ->
-    Translate   $ \bound ledgerByron ->
+    Translate   $ \bound (Comp ledgerByron) ->
       ShelleyLedgerState {
         shelleyLedgerTip =
           translatePointByronToShelley
-            (ledgerTipPoint ledgerByron)
-            (byronLedgerTipBlockNo $ byronLedgerTransition ledgerByron)
+            (castPoint $ getTip ledgerByron)
+            (byronLedgerTipBlockNo $ untickedByronLedgerTransition ledgerByron)
       , shelleyLedgerState =
           SL.translateToShelleyLedgerState
             (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
             (boundEpoch bound)
-            (byronLedgerState ledgerByron)
+            (tickedByronLedgerState ledgerByron)
       , shelleyLedgerTransition =
           ShelleyTransitionInfo{shelleyAfterVoting = 0}
       }
@@ -504,18 +505,6 @@ crossEraForecastByronToShelleyWrapper =
   Translation from Shelley to Allegra
 -------------------------------------------------------------------------------}
 
-translateLedgerStateShelleyToAllegraWrapper ::
-     (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
-  => RequiringBoth
-       WrapLedgerConfig
-       (Translate LedgerState)
-       (ShelleyBlock (TPraos c) (ShelleyEra c))
-       (ShelleyBlock (TPraos c) (AllegraEra c))
-translateLedgerStateShelleyToAllegraWrapper =
-    ignoringBoth $
-      Translate $ \_bound ->
-        unComp . SL.translateEra' () . Comp
-
 translateTxShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => InjectTx
@@ -532,22 +521,6 @@ translateValidatedTxShelleyToAllegraWrapper ::
 translateValidatedTxShelleyToAllegraWrapper = InjectValidatedTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
 
-{-------------------------------------------------------------------------------
-  Translation from Shelley to Allegra
--------------------------------------------------------------------------------}
-
-translateLedgerStateAllegraToMaryWrapper ::
-     (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
-  => RequiringBoth
-       WrapLedgerConfig
-       (Translate LedgerState)
-       (ShelleyBlock (TPraos c) (AllegraEra c))
-       (ShelleyBlock (TPraos c) (MaryEra c))
-translateLedgerStateAllegraToMaryWrapper =
-    ignoringBoth $
-      Translate $ \_bound ->
-        unComp . SL.translateEra' () . Comp
-
 {-------------------------------------------------------------------------------
   Translation from Allegra to Mary
 -------------------------------------------------------------------------------}
@@ -572,24 +545,6 @@ translateValidatedTxAllegraToMaryWrapper = InjectValidatedTx $
   Translation from Mary to Alonzo
 -------------------------------------------------------------------------------}
 
-translateLedgerStateMaryToAlonzoWrapper ::
-     (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
-  => RequiringBoth
-       WrapLedgerConfig
-       (Translate LedgerState)
-       (ShelleyBlock (TPraos c) (MaryEra c))
-       (ShelleyBlock (TPraos c) (AlonzoEra c))
-translateLedgerStateMaryToAlonzoWrapper =
-    RequireBoth $ \_cfgMary cfgAlonzo ->
-      Translate $ \_bound ->
-        unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp
-
-getAlonzoTranslationContext ::
-     WrapLedgerConfig (ShelleyBlock (TPraos c) (AlonzoEra c))
-  -> SL.TranslationContext (AlonzoEra c)
-getAlonzoTranslationContext =
-    shelleyLedgerTranslationContext . unwrapLedgerConfig
-
 translateTxMaryToAlonzoWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => SL.TranslationContext (AlonzoEra c)
@@ -613,28 +568,6 @@ translateValidatedTxMaryToAlonzoWrapper ctxt = InjectValidatedTx $
   Translation from Alonzo to Babbage
 -------------------------------------------------------------------------------}
 
-translateLedgerStateAlonzoToBabbageWrapper ::
-     (Praos.PraosCrypto c, TPraos.PraosCrypto c)
-  => RequiringBoth
-       WrapLedgerConfig
-       (Translate LedgerState)
-       (ShelleyBlock (TPraos c) (AlonzoEra c))
-       (ShelleyBlock (Praos c) (BabbageEra c))
-translateLedgerStateAlonzoToBabbageWrapper =
-    RequireBoth $ \_cfgAlonzo _cfgBabbage ->
-      Translate $ \_bound ->
-        unComp . SL.translateEra' () . Comp . transPraosLS
-  where
-    transPraosLS ::
-      LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c)) ->
-      LedgerState (ShelleyBlock (Praos c)  (AlonzoEra c))
-    transPraosLS (ShelleyLedgerState wo nes st) =
-      ShelleyLedgerState
-        { shelleyLedgerTip        = fmap castShelleyTip wo
-        , shelleyLedgerState      = nes
-        , shelleyLedgerTransition = st
-        }
-
 translateTxAlonzoToBabbageWrapper ::
      (Praos.PraosCrypto c)
   => SL.TranslationContext (BabbageEra c)
@@ -675,24 +608,6 @@ translateValidatedTxAlonzoToBabbageWrapper ctxt = InjectValidatedTx $
   Translation from Babbage to Conway
 -------------------------------------------------------------------------------}
 
-translateLedgerStateBabbageToConwayWrapper ::
-     (Praos.PraosCrypto c)
-  => RequiringBoth
-       WrapLedgerConfig
-       (Translate LedgerState)
-       (ShelleyBlock (Praos c) (BabbageEra c))
-       (ShelleyBlock (Praos c) (ConwayEra c))
-translateLedgerStateBabbageToConwayWrapper =
-    RequireBoth $ \_cfgBabbage cfgConway ->
-      Translate $ \_bound ->
-        unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
-
-getConwayTranslationContext ::
-     WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c))
-  -> SL.TranslationContext (ConwayEra c)
-getConwayTranslationContext =
-    shelleyLedgerTranslationContext . unwrapLedgerConfig
-
 translateTxBabbageToConwayWrapper ::
      (Praos.PraosCrypto c)
   => SL.TranslationContext (ConwayEra c)

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
@@ -21,6 +22,7 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC (
   , crossEraForecastAcrossShelley
   , forecastAcrossShelley
   , translateChainDepStateAcrossShelley
+  , translateLedgerStateAcrossShelley
   ) where
 
 import qualified Cardano.Ledger.BaseTypes as SL (mkVersion)
@@ -280,6 +282,59 @@ forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom
                (SL.stabilityWindow (shelleyLedgerGlobals cfgFrom))
                (SL.stabilityWindow (shelleyLedgerGlobals cfgTo))
 
+translateLedgerStateAcrossShelley ::
+     forall eraFrom eraTo protoFrom protoTo.
+     ( SL.TranslateEra eraTo (LedgerState :.: ShelleyBlock protoTo)
+     , SL.PreviousEra eraTo ~ eraFrom
+     , HeaderHash (ShelleyBlock protoFrom eraFrom) ~ HeaderHash (ShelleyBlock protoTo eraFrom)
+     )
+  => RequiringBoth
+       WrapLedgerConfig
+       (TickedTranslate LedgerState)
+       (ShelleyBlock protoFrom eraFrom)
+       (ShelleyBlock protoTo   eraTo)
+translateLedgerStateAcrossShelley =
+    RequireBoth $ \_cfgFrom (WrapLedgerConfig cfgTo) ->
+      Translate $ \_bound ->
+          unComp
+        . SL.translateEra' (shelleyLedgerTranslationContext cfgTo)
+        . Comp
+        . changeLedgerStateProto
+        . untickShelleyLedgerState
+        . unComp
+  where
+     changeLedgerStateProto ::
+          LedgerState (ShelleyBlock protoFrom eraFrom)
+       -> LedgerState (ShelleyBlock protoTo   eraFrom)
+     changeLedgerStateProto st = ShelleyLedgerState {
+           shelleyLedgerTip        = castShelleyTip <$> shelleyLedgerTip
+         , shelleyLedgerState
+         , shelleyLedgerTransition
+         }
+       where
+         ShelleyLedgerState {
+             shelleyLedgerTip
+           , shelleyLedgerState
+           , shelleyLedgerTransition
+           } = st
+
+     -- See 'translateLedgerState' in 'EraTranslation' for why we get a /ticked/
+     -- ledger state as an input here.
+     untickShelleyLedgerState ::
+          Ticked (LedgerState (ShelleyBlock proto era))
+       -> LedgerState         (ShelleyBlock proto era)
+     untickShelleyLedgerState st = ShelleyLedgerState {
+           shelleyLedgerTip        = untickedShelleyLedgerTip
+         , shelleyLedgerState      = tickedShelleyLedgerState
+         , shelleyLedgerTransition = tickedShelleyLedgerTransition
+         }
+       where
+         TickedShelleyLedgerState {
+             untickedShelleyLedgerTip
+           , tickedShelleyLedgerState
+           , tickedShelleyLedgerTransition
+           } = st
+
 translateChainDepStateAcrossShelley ::
      forall eraFrom eraTo protoFrom protoTo.
      ( TranslateProto protoFrom protoTo

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -37,15 +37,16 @@ import           Data.Void (Void)
 import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.Cardano.CanHardFork
                      (ShelleyPartialLedgerConfig (..), forecastAcrossShelley,
-                     translateChainDepStateAcrossShelley)
+                     translateChainDepStateAcrossShelley,
+                     translateLedgerStateAcrossShelley)
 import           Ouroboros.Consensus.Cardano.Node
                      (ProtocolTransitionParams (..), TriggerHardFork (..))
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Embed.Binary
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
 import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as HFC
 import qualified Ouroboros.Consensus.HardFork.History as History
-import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
                      (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.Mempool (TxLimits)
@@ -146,26 +147,11 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
 instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
       => CanHardFork (ShelleyBasedHardForkEras proto1 era1 proto2 era2) where
   hardForkEraTranslation = EraTranslation {
-        translateLedgerState   = PCons translateLedgerState                PNil
+        translateLedgerState   = PCons translateLedgerStateAcrossShelley   PNil
       , translateChainDepState = PCons translateChainDepStateAcrossShelley PNil
       , crossEraForecast       = PCons forecastAcrossShelleyWrapper        PNil
       }
     where
-      translateLedgerState ::
-           InPairs.RequiringBoth
-             WrapLedgerConfig
-             (HFC.Translate LedgerState)
-             (ShelleyBlock proto1 era1)
-             (ShelleyBlock proto2 era2)
-      translateLedgerState =
-          InPairs.RequireBoth
-        $ \_cfg1 cfg2 -> HFC.Translate
-        $ \_bound ->
-              unComp
-            . SL.translateEra'
-                (shelleyLedgerTranslationContext (unwrapLedgerConfig cfg2))
-            . Comp
-
       forecastAcrossShelleyWrapper ::
            InPairs.RequiringBoth
               WrapLedgerConfig

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

@@ -16,6 +16,7 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -361,11 +362,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} =
     prop_finalProtVers :: Property
     prop_finalProtVers =
         counterexample ("final protocol versions: " <> show finalProtVers) $
-        -- TODO This property is showcasing a problem with the HFC: even though
-        -- we will definitely end up in era B (and hence, the protocol version
-        -- should be @'succ' 'initProtVer'@), this is currently not the case.
-        -- Subsequent commits will fix this.
-        all (== initProtVer) finalProtVers
+        all (== succ initProtVer) finalProtVers
 
     finalProtVers :: Map.Map NodeId Integer
     finalProtVers = getProtVer `Map.map` testOutputNodes testOutput
@@ -429,12 +426,12 @@ instance SerialiseHFC '[BlockA, BlockB]
 ledgerState_AtoB ::
      RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (TickedTranslate LedgerState)
        BlockA
        BlockB
-ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ LgrA{..} -> LgrB {
-      lgrB_tip = castPoint lgrA_tip
-    , lgrB_protVer = lgrA_protVer
+ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ (Comp st) -> LgrB {
+      lgrB_tip = castPoint . lgrA_tip . getTickedLedgerStateA $ st
+    , lgrB_protVer = lgrA_protVer . getTickedLedgerStateA $ st
     }
 
 chainDepState_AtoB ::

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

@@ -35,6 +35,7 @@ module Test.Consensus.HardFork.Combinator.A (
   , LedgerState (..)
   , NestedCtxt_ (..)
   , StorageConfig (..)
+  , Ticked (..)
   , TxId (..)
   ) where
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs

@@ -34,6 +34,7 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..),
                      genesisHeaderState)
+import           Ouroboros.Consensus.Ledger.Abstract (LedgerResult (..))
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -205,10 +206,14 @@ injectInitialExtLedgerState cfg extLedgerState0 =
 
     targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs))
     targetEraLedgerState =
-        HardForkLedgerState $
+        -- Note that we are discarding the ledger events here that might arise
+        -- via the ticking (by zero slots) performed in 'extendToEraOfSlot'. Usually,
+        -- only testnets and benchmark scenarios have hard forks scheduled for
+        -- the first slot, so this seems acceptable.
+        HardForkLedgerState . lrResult $
           -- We can immediately extend it to the right slot, executing any
           -- scheduled hard forks in the first slot
-          extendToSlot
+          extendToEraOfSlot
             (configLedger cfg)
             (SlotNo 0)
             (initHardForkState (ledgerState extLedgerState0))