extendToSlot: always first tick across the era boundary

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

@@ -384,22 +384,22 @@ translateLedgerStateByronToShelleyWrapper ::
      )
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        ByronBlock
        (ShelleyBlock (TPraos c) (ShelleyEra c))
 translateLedgerStateByronToShelleyWrapper =
     RequireBoth $ \_ (WrapLedgerConfig cfgShelley) ->
-    Translate   $ \epochNo ledgerByron ->
+    Translate   $ \epochNo (Comp ledgerByron) ->
       ShelleyLedgerState {
         shelleyLedgerTip =
           translatePointByronToShelley
-            (ledgerTipPoint ledgerByron)
-            (byronLedgerTipBlockNo ledgerByron)
+            (castPoint $ getTip ledgerByron)
+            (untickedByronLedgerTipBlockNo ledgerByron)
       , shelleyLedgerState =
           SL.translateToShelleyLedgerState
             (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley))
             epochNo
-            (byronLedgerState ledgerByron)
+            (tickedByronLedgerState ledgerByron)
       , shelleyLedgerTransition =
           ShelleyTransitionInfo{shelleyAfterVoting = 0}
       }
@@ -509,13 +509,14 @@ translateLedgerStateShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (ShelleyEra c))
        (ShelleyBlock (TPraos c) (AllegraEra c))
 translateLedgerStateShelleyToAllegraWrapper =
     ignoringBoth $
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp
+          unComp . SL.translateEra' () . Comp
+        . untickShelleyLedgerState . unComp
 
 translateTxShelleyToAllegraWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
@@ -541,13 +542,14 @@ translateLedgerStateAllegraToMaryWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (AllegraEra c))
        (ShelleyBlock (TPraos c) (MaryEra c))
 translateLedgerStateAllegraToMaryWrapper =
     ignoringBoth $
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp
+          unComp . SL.translateEra' () . Comp
+        . untickShelleyLedgerState . unComp
 
 {-------------------------------------------------------------------------------
   Translation from Allegra to Mary
@@ -577,13 +579,14 @@ translateLedgerStateMaryToAlonzoWrapper ::
      (PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (MaryEra c))
        (ShelleyBlock (TPraos c) (AlonzoEra c))
 translateLedgerStateMaryToAlonzoWrapper =
     RequireBoth $ \_cfgMary cfgAlonzo ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp
+          unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) . Comp
+        . untickShelleyLedgerState . unComp
 
 getAlonzoTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (TPraos c) (AlonzoEra c))
@@ -618,13 +621,15 @@ translateLedgerStateAlonzoToBabbageWrapper ::
      (Praos.PraosCrypto c, TPraos.PraosCrypto c)
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (TPraos c) (AlonzoEra c))
        (ShelleyBlock (Praos c) (BabbageEra c))
 translateLedgerStateAlonzoToBabbageWrapper =
     RequireBoth $ \_cfgAlonzo _cfgBabbage ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' () . Comp . transPraosLS
+          unComp . SL.translateEra' () . Comp
+        . transPraosLS . untickShelleyLedgerState . unComp
+
   where
     transPraosLS ::
       LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c)) ->
@@ -680,13 +685,14 @@ translateLedgerStateBabbageToConwayWrapper ::
      (Praos.PraosCrypto c)
   => RequiringBoth
        WrapLedgerConfig
-       (Translate LedgerState)
+       (Translate' (Ticked :.: LedgerState) LedgerState)
        (ShelleyBlock (Praos c) (BabbageEra c))
        (ShelleyBlock (Praos c) (ConwayEra c))
 translateLedgerStateBabbageToConwayWrapper =
     RequireBoth $ \_cfgBabbage cfgConway ->
       Translate $ \_epochNo ->
-        unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
+          unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp
+        . untickShelleyLedgerState . unComp
 
 getConwayTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c))
@@ -712,3 +718,17 @@ translateValidatedTxBabbageToConwayWrapper ::
        (ShelleyBlock (Praos c) (ConwayEra c))
 translateValidatedTxBabbageToConwayWrapper ctxt = InjectValidatedTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp
+
+{-------------------------------------------------------------------------------
+  Auxiliary
+-------------------------------------------------------------------------------}
+
+-- TODO abstract this out more
+untickShelleyLedgerState ::
+     TickedLedgerState (ShelleyBlock proto era)
+  -> LedgerState       (ShelleyBlock proto era)
+untickShelleyLedgerState st = ShelleyLedgerState {
+     shelleyLedgerTip        = untickedShelleyLedgerTip      st
+   , shelleyLedgerState      = tickedShelleyLedgerState      st
+   , shelleyLedgerTransition = tickedShelleyLedgerTransition st
+   }

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,11 @@ injectInitialExtLedgerState cfg extLedgerState0 =
 
     targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs))
     targetEraLedgerState =
-        HardForkLedgerState $
+        -- TODO discarding ledger events, probably fine?
+        HardForkLedgerState . lrResult $
           -- We can immediately extend it to the right slot, executing any
           -- scheduled hard forks in the first slot
-          State.extendToSlot
+          extendToSlot
             (configLedger cfg)
             (SlotNo 0)
             (initHardForkState (ledgerState extLedgerState0))

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
@@ -26,23 +27,27 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger (
   , Ticked (..)
     -- * Low-level API (exported for the benefit of testing)
   , AnnForecast (..)
+  , extendToSlot
   , mkHardForkForecast
   ) where
 
 import           Control.Monad (guard)
 import           Control.Monad.Except (throwError, withExcept)
-import           Data.Functor ((<&>))
+import           Control.Monad.Trans.Writer.CPS
+import           Data.Foldable (toList)
 import           Data.Functor.Product
 import           Data.Proxy
+import           Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
 import           Data.SOP.Counting (getExactly)
 import           Data.SOP.Index
-import           Data.SOP.InPairs (InPairs (..))
+import           Data.SOP.InPairs (InPairs (..), Requiring (..))
 import qualified Data.SOP.InPairs as InPairs
 import qualified Data.SOP.Match as Match
 import           Data.SOP.Strict
-import           Data.SOP.Telescope (Telescope (..))
+import           Data.SOP.Telescope (Extend (..), Telescope (..))
 import qualified Data.SOP.Telescope as Telescope
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks (..))
@@ -69,6 +74,7 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.TypeFamilyWrappers
+import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.Condense
 
 {-------------------------------------------------------------------------------
@@ -119,9 +125,9 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
   type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs
 
   applyChainTickLedgerResult cfg@HardForkLedgerConfig{..} slot (HardForkLedgerState st) =
-      sequenceHardForkState
-        (hcizipWith proxySingle (tickOne ei slot) cfgs extended) <&> \l' ->
-      TickedHardForkLedgerState {
+      LedgerResult {
+        lrEvents = lrEvents extended <> lrEvents ticked
+      , lrResult = TickedHardForkLedgerState {
           tickedHardForkLedgerStateTransition =
             -- We are bundling a 'TransitionInfo' with a /ticked/ ledger state,
             -- but /derive/ that 'TransitionInfo' from the /unticked/  (albeit
@@ -143,15 +149,23 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
             --   in the final era, in which case ticking certainly won't be able
             --   to change that, or we're forecasting, which is simply not
             --   applicable here.
-            State.mostRecentTransitionInfo cfg extended
-        , tickedHardForkLedgerStatePerEra = l'
+            State.mostRecentTransitionInfo cfg (lrResult extended)
+        , tickedHardForkLedgerStatePerEra = lrResult ticked
         }
+      }
     where
       cfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra
       ei   = State.epochInfoLedger cfg st
 
-      extended :: HardForkState LedgerState xs
-      extended = State.extendToSlot cfg slot st
+      extended ::
+           LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs)
+      extended = extendToSlot cfg slot st
+
+      ticked ::
+           LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState (Ticked :.: LedgerState) xs)
+      ticked =
+          sequenceHardForkState
+            (hcizipWith proxySingle (tickOne ei slot) cfgs (lrResult extended))
 
 tickOne :: SingleEraBlock blk
         => EpochInfo (Except PastHorizonException)
@@ -732,6 +746,103 @@ shiftUpdate = go
           (eraIndexSucc ix)
           (eraIndexSucc ix')
 
+{-------------------------------------------------------------------------------
+  Extending
+-------------------------------------------------------------------------------}
+
+-- | Extend the telescope until the specified slot is within the era at the tip
+--
+-- TODO documentation (in particular that this now does ticking!)
+extendToSlot ::
+     forall xs. CanHardFork xs
+  => HardForkLedgerConfig xs
+  -> SlotNo
+  -> HardForkState LedgerState xs
+  -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs)
+extendToSlot  ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) =
+      writerToLedgerResult
+    . fmap HardForkState
+    . Telescope.extend
+        ( InPairs.requiring (hzipWith Pair cfgs indices)
+        . InPairs.hcmap
+            proxySingle
+            (\f -> Require $ \(Pair cfg index)
+                -> Require $ \(K t)
+                -> Extend  $ \cur
+                -> howExtend index cfg f t cur)
+        $ translate
+        )
+        (hczipWith
+           proxySingle
+           (fn .: whenExtend)
+           pcfgs
+           (getExactly (History.getShape hardForkLedgerConfigShape)))
+    $ st
+  where
+    pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra
+    cfgs  = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs
+    ei    = State.epochInfoLedger ledgerCfg ledgerSt
+
+    writerToLedgerResult :: Writer (Seq (AuxLedgerEvent l)) a -> LedgerResult l a
+    writerToLedgerResult w =
+        LedgerResult {lrEvents = toList evs, lrResult = a}
+      where
+        (a, evs) = runWriter w
+
+    -- Return the end of this era if we should transition to the next
+    whenExtend :: SingleEraBlock              blk
+               => WrapPartialLedgerConfig     blk
+               -> K History.EraParams         blk
+               -> Current LedgerState         blk
+               -> (Maybe :.: K History.Bound) blk
+    whenExtend pcfg (K eraParams) cur = Comp $ K <$> do
+        transition <- singleEraTransition'
+                        pcfg
+                        eraParams
+                        (currentStart cur)
+                        (currentState cur)
+        let endBound = History.mkUpperBound
+                         eraParams
+                         (currentStart cur)
+                         transition
+        guard (slot >= History.boundSlot endBound)
+        return endBound
+
+    howExtend ::
+         IsLedger (LedgerState blk)
+      => Index xs blk
+      -> WrapLedgerConfig blk
+      -> Translate' (Ticked :.: LedgerState) LedgerState blk blk'
+      -> History.Bound
+      -> Current LedgerState blk
+      -> Writer
+           (Seq (AuxLedgerEvent (LedgerState (HardForkBlock xs))))
+           (K Past blk, Current LedgerState blk')
+    howExtend index cfg f currentEnd cur = do
+        let LedgerResult{lrEvents, lrResult} =
+              applyChainTickLedgerResult
+                (unwrapLedgerConfig cfg)
+                (History.boundSlot currentEnd)
+                (currentState cur)
+        tell $ injectLedgerEvent index <$> Seq.fromList lrEvents
+        pure
+          (
+            K Past {
+                pastStart    = currentStart cur
+              , pastEnd      = currentEnd
+              }
+          , Current {
+                currentStart = currentEnd
+              , currentState = translateWith f
+                                 (History.boundEpoch currentEnd)
+                                 (Comp lrResult)
+              }
+          )
+
+    translate :: InPairs (Translate' (Ticked :.: LedgerState) LedgerState) xs
+    translate = InPairs.requiringBoth cfgs $
+                  translateLedgerState hardForkEraTranslation
+
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}