extendToSlot: move to ledger sibling module

This doesn't actually change any code, and is mostly done to highlight the changes to this function in the next commit.
IntersectMBO · Sep 19, 2023 · c9d48e6 · c9d48e6
1 parent 2f88679
commit c9d48e6
Show file tree

Hide file tree

Showing 3 changed files with 75 additions and 79 deletions.
diff --git a/...s-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/...s-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs
@@ -208,7 +208,7 @@ injectInitialExtLedgerState cfg extLedgerState0 =
         HardForkLedgerState $
           -- 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))

diff --git a/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs
@@ -26,6 +26,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger (
   , Ticked (..)
     -- * Low-level API (exported for the benefit of testing)
   , AnnForecast (..)
+  , extendToSlot
   , mkHardForkForecast
   ) where
 
@@ -38,11 +39,11 @@ 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 +70,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
 
 {-------------------------------------------------------------------------------
@@ -151,7 +153,7 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
       ei   = State.epochInfoLedger cfg st
 
       extended :: HardForkState LedgerState xs
-      extended = State.extendToSlot cfg slot st
+      extended = extendToSlot cfg slot st
 
 tickOne :: SingleEraBlock blk
         => EpochInfo (Except PastHorizonException)
@@ -732,6 +734,74 @@ shiftUpdate = go
           (eraIndexSucc ix)
           (eraIndexSucc ix')
 
+{-------------------------------------------------------------------------------
+  Extending
+-------------------------------------------------------------------------------}
+
+-- | Extend the telescope until the specified slot is within the era at the tip
+extendToSlot :: forall xs. CanHardFork xs
+             => HardForkLedgerConfig xs
+             -> SlotNo
+             -> HardForkState LedgerState xs -> HardForkState LedgerState xs
+extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) =
+      HardForkState . unI
+    . Telescope.extend
+        ( InPairs.hmap (\f -> Require $ \(K t)
+                           -> Extend  $ \cur
+                           -> I $ howExtend 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
+
+    -- 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 >= boundSlot endBound)
+        return endBound
+
+    howExtend :: Translate LedgerState blk blk'
+              -> History.Bound
+              -> Current LedgerState blk
+              -> (K Past blk, Current LedgerState blk')
+    howExtend f currentEnd cur = (
+          K Past {
+              pastStart    = currentStart cur
+            , pastEnd      = currentEnd
+            }
+        , Current {
+              currentStart = currentEnd
+            , currentState = translateWith f
+                               currentEnd
+                               (currentState cur)
+            }
+        )
+
+    translate :: InPairs (Translate LedgerState) xs
+    translate = InPairs.requiringBoth cfgs $
+                  translateLedgerState hardForkEraTranslation
+
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs
@@ -25,20 +25,16 @@ module Ouroboros.Consensus.HardFork.Combinator.State (
   , epochInfoPrecomputedTransitionInfo
   , mostRecentTransitionInfo
   , reconstructSummaryLedger
-    -- * Ledger specific functionality
-  , extendToSlot
   ) where
 
-import           Control.Monad (guard)
 import           Data.Functor.Product
 import           Data.Proxy
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
 import           Data.SOP.Counting (getExactly)
-import           Data.SOP.InPairs (InPairs, Requiring (..))
 import qualified Data.SOP.InPairs as InPairs
 import           Data.SOP.Strict
-import           Data.SOP.Telescope (Extend (..), ScanNext (..), Telescope)
+import           Data.SOP.Telescope (ScanNext (..), Telescope)
 import qualified Data.SOP.Telescope as Telescope
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
@@ -48,10 +44,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.State.Infra as X
 import           Ouroboros.Consensus.HardFork.Combinator.State.Instances as X ()
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types as X
-import           Ouroboros.Consensus.HardFork.Combinator.Translation
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.Ledger.Abstract hiding (getTip)
-import           Ouroboros.Consensus.Util ((.:))
 import           Prelude hiding (sequence)
 
 {-------------------------------------------------------------------------------
@@ -164,71 +158,3 @@ epochInfoPrecomputedTransitionInfo ::
 epochInfoPrecomputedTransitionInfo shape transition st =
     History.summaryToEpochInfo $
       reconstructSummary shape transition st
-
-{-------------------------------------------------------------------------------
-  Extending
--------------------------------------------------------------------------------}
-
--- | Extend the telescope until the specified slot is within the era at the tip
-extendToSlot :: forall xs. CanHardFork xs
-             => HardForkLedgerConfig xs
-             -> SlotNo
-             -> HardForkState LedgerState xs -> HardForkState LedgerState xs
-extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) =
-      HardForkState . unI
-    . Telescope.extend
-        ( InPairs.hmap (\f -> Require $ \(K t)
-                           -> Extend  $ \cur
-                           -> I $ howExtend 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    = epochInfoLedger ledgerCfg ledgerSt
-
-    -- 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 :: Translate LedgerState blk blk'
-              -> History.Bound
-              -> Current LedgerState blk
-              -> (K Past blk, Current LedgerState blk')
-    howExtend f currentEnd cur = (
-          K Past {
-              pastStart    = currentStart cur
-            , pastEnd      = currentEnd
-            }
-        , Current {
-              currentStart = currentEnd
-            , currentState = translateWith f
-                               currentEnd
-                               (currentState cur)
-            }
-        )
-
-    translate :: InPairs (Translate LedgerState) xs
-    translate = InPairs.requiringBoth cfgs $
-                  translateLedgerState hardForkEraTranslation