HFC: generalize cross era ticking

Co-authored-by: Nicolas Frisby <[email protected]>

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -83,6 +83,7 @@ import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.PBFT
+import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util (ShowProxy (..), (..:))
 
 {-------------------------------------------------------------------------------
@@ -164,6 +165,7 @@ getByronTip state =
 -- | The ticked Byron ledger state
 data instance Ticked (LedgerState ByronBlock) = TickedByronLedgerState {
       tickedByronLedgerState        :: !CC.ChainValidationState
+    , untickedByronLedgerTipBlockNo :: !(WithOrigin BlockNo)
     , untickedByronLedgerTransition :: !ByronTransition
     }
   deriving (Generic, NoThunks)
@@ -178,6 +180,8 @@ instance IsLedger (LedgerState ByronBlock) where
       TickedByronLedgerState {
           tickedByronLedgerState =
             CC.applyChainTick cfg (toByronSlotNo slotNo) byronLedgerState
+        , untickedByronLedgerTipBlockNo =
+            byronLedgerTipBlockNo
         , untickedByronLedgerTransition =
             byronLedgerTransition
         }

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

@@ -25,7 +25,9 @@ module Ouroboros.Consensus.Cardano.CanHardFork (
     -- * Re-exports of Shelley code
   , ShelleyPartialLedgerConfig (..)
   , crossEraForecastAcrossShelley
-  , translateChainDepStateAcrossShelley
+  , forecastAcrossShelley
+  , tickChainDepStateAcrossShelley
+  , tickLedgerStateAcrossShelley
   , translateLedgerStateByronToShelley
   ) where
 
@@ -53,7 +55,8 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe (listToMaybe, mapMaybe)
 import           Data.Proxy
 import           Data.SOP.BasicFunctors
-import           Data.SOP.InPairs (RequiringBoth (..), ignoringBoth)
+import           Data.SOP.InPairs (RequiringBoth, RequiringBoth' (..),
+                     ignoringBoth)
 import qualified Data.SOP.Strict as SOP
 import           Data.SOP.Tails (Tails (..))
 import qualified Data.SOP.Tails as Tails
@@ -68,8 +71,7 @@ import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
-import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot),
-                     addSlots)
+import           Ouroboros.Consensus.HardFork.History (Bound (..), addSlots)
 import           Ouroboros.Consensus.HardFork.Simple
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32,
@@ -282,23 +284,23 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
   type HardForkTxMeasure (CardanoEras c) = ConwayMeasure
 
   hardForkEraTranslation = EraTranslation {
-      translateLedgerState   =
-          PCons translateLedgerStateByronToShelleyWrapper
-        $ PCons translateLedgerStateShelleyToAllegraWrapper
-        $ PCons translateLedgerStateAllegraToMaryWrapper
-        $ PCons translateLedgerStateMaryToAlonzoWrapper
-        $ PCons translateLedgerStateAlonzoToBabbageWrapper
-        $ PCons translateLedgerStateBabbageToConwayWrapper
+      crossEraTickLedgerState   =
+          PCons tickLedgerStateByronToShelley
+        $ PCons tickLedgerStateAcrossShelley
+        $ PCons tickLedgerStateAcrossShelley
+        $ PCons tickLedgerStateAcrossShelley
+        $ PCons tickLedgerStateAcrossShelley
+        $ PCons tickLedgerStateAcrossShelley
         $ PNil
-    , translateChainDepState =
-          PCons translateChainDepStateByronToShelleyWrapper
-        $ PCons translateChainDepStateAcrossShelley
-        $ PCons translateChainDepStateAcrossShelley
-        $ PCons translateChainDepStateAcrossShelley
-        $ PCons translateChainDepStateAcrossShelley
-        $ PCons translateChainDepStateAcrossShelley
+    , crossEraTickChainDepState =
+          PCons tickChainDepStateByronToShelley
+        $ PCons tickChainDepStateAcrossShelley
+        $ PCons tickChainDepStateAcrossShelley
+        $ PCons tickChainDepStateAcrossShelley
+        $ PCons tickChainDepStateAcrossShelley
+        $ PCons tickChainDepStateAcrossShelley
         $ PNil
-    , crossEraForecast       =
+    , crossEraForecast          =
           PCons crossEraForecastByronToShelleyWrapper
         $ PCons crossEraForecastAcrossShelley
         $ PCons crossEraForecastAcrossShelley
@@ -324,8 +326,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)
@@ -338,8 +340,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)
@@ -415,31 +417,34 @@ translatePointByronToShelley point bNo =
       _otherwise ->
         error "translatePointByronToShelley: invalid Byron state"
 
-translateLedgerStateByronToShelleyWrapper ::
+tickLedgerStateByronToShelley ::
      ( ShelleyCompatible (TPraos c) (ShelleyEra c)
      , HASH     c ~ Blake2b_256
      , ADDRHASH c ~ Blake2b_224
      )
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       CrossEraTickLedgerState
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
-translateLedgerStateByronToShelleyWrapper =
-    RequireBoth $ \_ (WrapLedgerConfig cfgShelley) -> Translate $
-      translateLedgerStateByronToShelley
-        (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
+tickLedgerStateByronToShelley =
+    RequireBoth $ \_ (WrapLedgerConfig cfgShelley) ->
+    CrossEraTickLedgerState $ \bound slot ->
+        applyChainTickLedgerResult cfgShelley slot
+      . translateLedgerStateByronToShelley
+          (shelleyLedgerTranslationContext cfgShelley)
+          bound
 
 translateLedgerStateByronToShelley ::
      ( ShelleyCompatible (TPraos c) (ShelleyEra c)
      , HASH     c ~ Blake2b_256
      , ADDRHASH c ~ Blake2b_224
      )
   => SL.FromByronTranslationContext c
-  -> EpochNo -- ^ Start of the new era
+  -> Bound -- ^ Start of the new era
   -> LedgerState ByronBlock
   -> LedgerState (ShelleyBlock (TPraos c) (ShelleyEra c))
-translateLedgerStateByronToShelley ctx epochNo ledgerByron =
+translateLedgerStateByronToShelley ctx bound ledgerByron =
     ShelleyLedgerState {
       shelleyLedgerTip =
         translatePointByronToShelley
@@ -448,23 +453,24 @@ translateLedgerStateByronToShelley ctx epochNo ledgerByron =
     , shelleyLedgerState =
         SL.translateToShelleyLedgerState
           ctx
-          epochNo
+          (boundEpoch bound)
           (byronLedgerState ledgerByron)
     , shelleyLedgerTransition =
         ShelleyTransitionInfo{shelleyAfterVoting = 0}
     }
 
-translateChainDepStateByronToShelleyWrapper ::
-     RequiringBoth
+tickChainDepStateByronToShelley ::
+     ConsensusProtocol (TPraos c)
+  => RequiringBoth
        WrapConsensusConfig
-       (Translate WrapChainDepState)
+       CrossEraTickChainDepState
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
-translateChainDepStateByronToShelleyWrapper =
+tickChainDepStateByronToShelley =
     RequireBoth $ \_ (WrapConsensusConfig cfgShelley) ->
-      Translate $ \_ (WrapChainDepState pbftState) ->
-        WrapChainDepState $
-          translateChainDepStateByronToShelley cfgShelley pbftState
+    CrossEraTickChainDepState $ \_bound view slot ->
+        tickChainDepState cfgShelley view slot
+      . translateChainDepStateByronToShelley cfgShelley
 
 translateChainDepStateByronToShelley ::
      forall bc c.
@@ -555,18 +561,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 $ \_epochNo ->
-        unComp . SL.translateEra' SL.NoGenesis . Comp
-
 translateTxShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => InjectTx
@@ -587,18 +581,6 @@ translateValidatedTxShelleyToAllegraWrapper = InjectValidatedTx $
   Translation from Allegra to Mary
 -------------------------------------------------------------------------------}
 
-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 $ \_epochNo ->
-        unComp . SL.translateEra' SL.NoGenesis . Comp
-
 translateTxAllegraToMaryWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => InjectTx
@@ -619,24 +601,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 $ \_epochNo ->
-        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)
@@ -660,28 +624,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 $ \_epochNo ->
-        unComp . SL.translateEra' SL.NoGenesis . 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)
@@ -722,24 +664,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 $ \_epochNo ->
-        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/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -1021,12 +1021,13 @@ protocolInfoCardano paramsCardano
              PNil
            where
              byronToShelleyTranslation =
-                 Translate $ translateLedgerStateByronToShelley ctx
+                 CrossEra $ \(Current bound _) ->
+                   translateLedgerStateByronToShelley ctx bound
                where
                  ctx = SL.toFromByronTranslationContext genesisShelley
 
              interShelleyTranslation transitionConfig =
-                 Translate $ \_ -> translateShelleyLedgerState ctx
+                 CrossEra $ \_ -> translateShelleyLedgerState ctx
                where
                  ctx = transitionConfig ^. L.tcTranslationContextL
 

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

@@ -91,6 +91,7 @@ import           Ouroboros.Consensus.Shelley.Ledger.Config
 import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract
                      (EnvelopeCheckError, envelopeChecks, mkHeaderView)
+import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util ((..:))
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                      encodeWithOrigin)