TO SQUASH WIP Change the type of applyChainTick ...

... to reflect that it does not change the table kinds and can involve any table.
IntersectMBO · Jan 6, 2022 · 9ad036a · 9ad036a
1 parent d21ed7c
commit 9ad036a
Show file tree

Hide file tree

Showing 4 changed files with 23 additions and 15 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs
@@ -16,6 +16,9 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
+
+{-# LANGUAGE InstanceSigs       #-}
+
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.HardFork.Combinator.Ledger (
@@ -130,6 +133,12 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
 
   type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs
 
+  applyChainTickLedgerResult :: forall mk . LedgerCfg (LedgerState (HardForkBlock xs))
+                                    -> SlotNo
+                                    -> LedgerState (HardForkBlock xs) mk
+                                    -> LedgerResult
+                                         (LedgerState (HardForkBlock xs))
+                                         (Ticked1 (LedgerState (HardForkBlock xs)) mk)
   applyChainTickLedgerResult cfg@HardForkLedgerConfig{..} slot (HardForkLedgerState st) =
       sequenceHardForkState
         (hcizipWith proxySingle (tickOne ei slot) cfgs extended) <&> \l' ->
@@ -162,17 +171,17 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
       cfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra
       ei   = State.epochInfoLedger cfg st
 
-      extended :: HardForkState (Flip LedgerState EmptyMK) xs
+      extended :: HardForkState (Flip LedgerState mk) xs
       extended = State.extendToSlot cfg slot st
 
 tickOne :: SingleEraBlock blk
         => EpochInfo (Except PastHorizonException)
         -> SlotNo
         -> Index xs                                           blk
         -> WrapPartialLedgerConfig                            blk
-        -> Flip LedgerState EmptyMK                           blk
+        -> Flip LedgerState mk                                blk
         -> (    LedgerResult (LedgerState (HardForkBlock xs))
-            :.: FlipTickedLedgerState EmptyMK
+            :.: FlipTickedLedgerState mk
            )                                                  blk
 tickOne ei slot index pcfg (Flip st) = Comp $ fmap FlipTickedLedgerState $
       embedLedgerResult (injectLedgerEvent index)

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs
@@ -172,10 +172,10 @@ epochInfoPrecomputedTransitionInfo shape transition st =
 -------------------------------------------------------------------------------}
 
 -- | Extend the telescope until the specified slot is within the era at the tip
-extendToSlot :: forall xs. CanHardFork xs
+extendToSlot :: forall xs mk . CanHardFork xs
              => HardForkLedgerConfig xs
              -> SlotNo
-             -> HardForkState (Flip LedgerState EmptyMK) xs -> HardForkState (Flip LedgerState EmptyMK) xs
+             -> HardForkState (Flip LedgerState mk) xs -> HardForkState (Flip LedgerState mk) xs
 extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st) =
       HardForkState . unI
     . Telescope.extend
@@ -216,8 +216,8 @@ extendToSlot ledgerCfg@HardForkLedgerConfig{..} slot ledgerSt@(HardForkState st)
 
     howExtend :: TranslateLedgerState blk blk'
               -> History.Bound
-              -> Current (Flip LedgerState EmptyMK) blk
-              -> (K Past blk, Current (Flip LedgerState EmptyMK) blk')
+              -> Current (Flip LedgerState mk) blk
+              -> (K Past blk, Current (Flip LedgerState mk) blk')
     howExtend f currentEnd cur = (
           K Past {
               pastStart    = currentStart cur

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State/Types.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
 
@@ -101,10 +102,10 @@ newtype TranslateForecast f g x y = TranslateForecast {
     }
 
 newtype TranslateLedgerState x y = TranslateLedgerState {
-      translateLedgerStateWith ::
+      translateLedgerStateWith :: forall mk .
            EpochNo
-        -> LedgerState x EmptyMK
-        -> LedgerState y EmptyMK
+        -> LedgerState x mk
+        -> LedgerState y mk
     }
 
 -- | Knowledge in a particular era of the transition to the next era

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Basics.hs
@@ -211,10 +211,8 @@ class ( -- Requirements on the ledger state itself
   applyChainTickLedgerResult ::
        LedgerCfg l
     -> SlotNo
-    -- TODO while the only " large " the UTxO map, ticking involve any tables
-    -> l EmptyMK
-    -> LedgerResult l (Ticked1 l EmptyMK)
-
+    -> l mk
+    -> LedgerResult l (Ticked1 l mk)
 
   -- | Given a block, get the key-sets that we need to apply it to a ledger
   -- state.
@@ -273,7 +271,7 @@ class TableStuff l => TickedTableStuff (l :: LedgerStateKind) where
   trackingTablesToDiffs :: l TrackingMK -> l DiffMK
 
 -- | 'lrResult' after 'applyChainTickLedgerResult'
-applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked1 l EmptyMK
+applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l mk -> Ticked1 l mk
 applyChainTick = lrResult ..: applyChainTickLedgerResult
 
 {-------------------------------------------------------------------------------