Use MKs on the HFC

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -88,7 +88,7 @@ class ( LedgerSupportsProtocol blk
   singleEraTransition :: PartialLedgerConfig blk
                       -> EraParams -- ^ Current era parameters
                       -> Bound     -- ^ Start of this era
-                      -> LedgerState blk
+                      -> LedgerState blk mk
                       -> Maybe EpochNo
 
   -- | Era information (for use in error messages)
@@ -101,7 +101,7 @@ singleEraTransition' :: SingleEraBlock blk
                      => WrapPartialLedgerConfig blk
                      -> EraParams
                      -> Bound
-                     -> LedgerState blk -> Maybe EpochNo
+                     -> LedgerState blk mk -> Maybe EpochNo
 singleEraTransition' = singleEraTransition . unwrapPartialLedgerConfig
 
 {-------------------------------------------------------------------------------

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
@@ -18,7 +19,9 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics (
     -- * Hard fork protocol, block, and ledger state
     HardForkBlock (..)
   , HardForkProtocol
+  , InjectLedgerTables (..)
   , LedgerState (..)
+  , LedgerTablesCanHardFork (..)
     -- * Config
   , BlockConfig (..)
   , CodecConfig (..)
@@ -59,6 +62,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.State.Instances ()
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
 
 {-------------------------------------------------------------------------------
   Hard fork protocol, block, and ledger state
@@ -76,13 +80,23 @@ instance Typeable xs => ShowProxy (HardForkBlock xs) where
 type instance BlockProtocol (HardForkBlock xs) = HardForkProtocol xs
 type instance HeaderHash    (HardForkBlock xs) = OneEraHash       xs
 
-newtype instance LedgerState (HardForkBlock xs) = HardForkLedgerState {
-      hardForkLedgerStatePerEra :: HardForkState LedgerState xs
+newtype instance LedgerState (HardForkBlock xs) mk = HardForkLedgerState {
+      hardForkLedgerStatePerEra :: HardForkState (Flip LedgerState mk) xs
     }
 
-deriving stock   instance CanHardFork xs => Show (LedgerState (HardForkBlock xs))
-deriving stock   instance CanHardFork xs => Eq   (LedgerState (HardForkBlock xs))
-deriving newtype instance CanHardFork xs => NoThunks (LedgerState (HardForkBlock xs))
+deriving stock   instance (IsMapKind mk, CanHardFork xs) => Show     (LedgerState (HardForkBlock xs) mk)
+deriving stock   instance (IsMapKind mk, CanHardFork xs) => Eq       (LedgerState (HardForkBlock xs) mk)
+deriving newtype instance (IsMapKind mk, CanHardFork xs) => NoThunks (LedgerState (HardForkBlock xs) mk)
+
+-- | How to inject each era's ledger tables into their shared ledger tables
+class LedgerTablesCanHardFork xs where
+  hardForkInjectLedgerTablesKeysMK :: NP (InjectLedgerTables xs) xs
+
+newtype InjectLedgerTables xs x = InjectLedgerTables {
+      applyInjectLedgerTables :: forall mk. IsMapKind mk =>
+           LedgerTables (LedgerState                  x) mk
+        -> LedgerTables (LedgerState (HardForkBlock xs)) mk
+    }
 
 {-------------------------------------------------------------------------------
   Protocol config

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
 {-# LANGUAGE PatternSynonyms      #-}
+{-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -52,6 +53,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseDisk ()
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToClient ()
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToNode ()
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 
 {-------------------------------------------------------------------------------
   Simple patterns
@@ -169,11 +172,11 @@ pattern DegenBlockConfig x <- (project -> x)
 
 pattern DegenLedgerState ::
      NoHardForks b
-  => LedgerState b
-  -> LedgerState (HardForkBlock '[b])
-pattern DegenLedgerState x <- (project -> x)
+  => LedgerState b mk
+  -> LedgerState (HardForkBlock '[b]) mk
+pattern DegenLedgerState x <- (unFlip . project . Flip -> x)
   where
-    DegenLedgerState x = inject x
+    DegenLedgerState x = unFlip $ inject $ Flip x
 
 {-------------------------------------------------------------------------------
   Dealing with the config

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

@@ -12,6 +12,8 @@ import           Data.These (These (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
 import           Ouroboros.Consensus.Ledger.Extended
@@ -79,7 +81,7 @@ protocolInfoBinary protocolInfo1 eraParams1 toPartialConsensusConfig1 toPartialL
       , pInfoInitLedger = ExtLedgerState {
             ledgerState =
               HardForkLedgerState $
-                initHardForkState initLedgerState1
+                initHardForkState (Flip initLedgerState1)
           , headerState =
               genesisHeaderState $
                 initHardForkState $

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

@@ -29,7 +29,9 @@ import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..),
                      genesisHeaderState)
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
+import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util ((.:))
@@ -38,6 +40,8 @@ import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Combinator
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
 
 {-------------------------------------------------------------------------------
@@ -46,7 +50,7 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
 
 class Inject f where
   inject ::
-       forall x xs. CanHardFork xs
+       forall x xs. (CanHardFork xs, LedgerTablesCanHardFork xs)
     => Exactly xs History.Bound
        -- ^ Start bound of each era
     -> Index xs x
@@ -57,6 +61,7 @@ inject' ::
      forall f a b x xs.
      ( Inject f
      , CanHardFork xs
+     , LedgerTablesCanHardFork xs
      , Coercible a (f x)
      , Coercible b (f (HardForkBlock xs))
      )
@@ -77,10 +82,10 @@ injectNestedCtxt_ idx nc = case idx of
     IS idx' -> NCS (injectNestedCtxt_ idx' nc)
 
 injectQuery ::
-     forall x xs result.
+     forall x xs fp result.
      Index xs x
-  -> BlockQuery x result
-  -> QueryIfCurrent xs result
+  -> BlockQuery x      fp result
+  -> QueryIfCurrent xs fp result
 injectQuery idx q = case idx of
     IZ      -> QZ q
     IS idx' -> QS (injectQuery idx' q)
@@ -149,9 +154,9 @@ instance Inject (SomeSecond BlockQuery) where
 instance Inject AnnTip where
   inject _ = undistribAnnTip .: injectNS' (Proxy @AnnTip)
 
-instance Inject LedgerState where
+instance Inject (Flip LedgerState mk) where
   inject startBounds idx =
-      HardForkLedgerState . injectHardForkState startBounds idx
+      Flip . HardForkLedgerState . injectHardForkState startBounds idx
 
 instance Inject WrapChainDepState where
   inject startBounds idx =
@@ -165,9 +170,9 @@ instance Inject HeaderState where
                             $ WrapChainDepState headerStateChainDep
       }
 
-instance Inject ExtLedgerState where
-  inject startBounds idx ExtLedgerState {..} = ExtLedgerState {
-        ledgerState = inject startBounds idx ledgerState
+instance Inject (Flip ExtLedgerState mk) where
+  inject startBounds idx (Flip ExtLedgerState {..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ inject startBounds idx (Flip ledgerState)
       , headerState = inject startBounds idx headerState
       }
 
@@ -186,10 +191,10 @@ instance Inject ExtLedgerState where
 -- problematic, but extending 'ledgerViewForecastAt' is a lot more subtle; see
 -- @forecastNotFinal@.
 injectInitialExtLedgerState ::
-     forall x xs. CanHardFork (x ': xs)
+     forall x xs. (CanHardFork (x ': xs), HasLedgerTables (LedgerState (HardForkBlock (x : xs))))
   => TopLevelConfig (HardForkBlock (x ': xs))
-  -> ExtLedgerState x
-  -> ExtLedgerState (HardForkBlock (x ': xs))
+  -> ExtLedgerState x ValuesMK
+  -> ExtLedgerState (HardForkBlock (x ': xs)) ValuesMK
 injectInitialExtLedgerState cfg extLedgerState0 =
     ExtLedgerState {
         ledgerState = targetEraLedgerState
@@ -204,15 +209,17 @@ injectInitialExtLedgerState cfg extLedgerState0 =
              (hardForkLedgerStatePerEra targetEraLedgerState))
           cfg
 
-    targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs))
+    targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs)) ValuesMK
     targetEraLedgerState =
-        HardForkLedgerState $
-          -- We can immediately extend it to the right slot, executing any
-          -- scheduled hard forks in the first slot
-          State.extendToSlot
-            (configLedger cfg)
-            (SlotNo 0)
-            (initHardForkState (ledgerState extLedgerState0))
+       applyLedgerTablesDiffs
+         (HardForkLedgerState . initHardForkState . Flip . ledgerState $ extLedgerState0)
+         (HardForkLedgerState
+           -- We can immediately extend it to the right slot, executing any
+           -- scheduled hard forks in the first slot
+             (State.extendToSlot
+                (configLedger cfg)
+                (SlotNo 0)
+                (initHardForkState $ Flip $ forgetLedgerTables $ ledgerState extLedgerState0)))
 
     firstEraChainDepState :: HardForkChainDepState (x ': xs)
     firstEraChainDepState =

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

@@ -48,6 +48,7 @@ import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -70,6 +71,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.Protocol
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope
 
 {-------------------------------------------------------------------------------
@@ -198,7 +201,7 @@ instance Isomorphic StorageConfig where
   project = defaultProjectNP
   inject  = defaultInjectNP
 
-instance Isomorphic LedgerState where
+instance Isomorphic (Flip LedgerState mk) where
   project = defaultProjectSt
   inject  = defaultInjectSt
 
@@ -337,29 +340,29 @@ instance Isomorphic HeaderState where
       , headerStateChainDep = inject' (Proxy @(WrapChainDepState blk)) headerStateChainDep
       }
 
-instance Isomorphic (Ticked :.: LedgerState) where
+instance Isomorphic (FlipTickedLedgerState mk) where
   project =
         State.currentState
       . Telescope.fromTZ
       . getHardForkState
       . tickedHardForkLedgerStatePerEra
-      . unComp
+      . getFlipTickedLedgerState
 
   inject =
-        Comp
+        FlipTickedLedgerState
       . TickedHardForkLedgerState TransitionImpossible
       . HardForkState
       . Telescope.TZ
       . State.Current History.initBound
 
-instance Isomorphic ExtLedgerState where
-  project ExtLedgerState{..} = ExtLedgerState {
-        ledgerState = project ledgerState
+instance Isomorphic (Flip ExtLedgerState mk) where
+  project (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ project $ Flip ledgerState
       , headerState = project headerState
       }
 
-  inject ExtLedgerState{..} = ExtLedgerState {
-        ledgerState = inject ledgerState
+  inject (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ inject $ Flip ledgerState
       , headerState = inject headerState
       }
 
@@ -372,11 +375,11 @@ instance Isomorphic AnnTip where
 instance Functor m => Isomorphic (InitChainDB m) where
   project :: forall blk. NoHardForks blk
           => InitChainDB m (HardForkBlock '[blk]) -> InitChainDB m blk
-  project = InitChainDB.map (inject' (Proxy @(I blk))) project
+  project = InitChainDB.map (inject' (Proxy @(I blk))) (unFlip . project . Flip)
 
   inject :: forall blk. NoHardForks blk
          => InitChainDB m blk -> InitChainDB m (HardForkBlock '[blk])
-  inject = InitChainDB.map (project' (Proxy @(I blk))) inject
+  inject = InitChainDB.map (project' (Proxy @(I blk))) (unFlip . inject . Flip)
 
 instance Isomorphic ProtocolClientInfo where
   project ProtocolClientInfo{..} = ProtocolClientInfo {
@@ -443,7 +446,7 @@ instance Functor m => Isomorphic (BlockForging m) where
                                    (inject cfg)
                                    bno
                                    sno
-                                   (unComp (inject (Comp tickedLgrSt)))
+                                   (getFlipTickedLedgerState (inject (FlipTickedLedgerState tickedLgrSt)))
                                    (inject' (Proxy @(WrapValidatedGenTx blk)) <$> txs)
                                    (inject' (Proxy @(WrapIsLeader blk)) isLeader)
       }
@@ -486,7 +489,7 @@ instance Functor m => Isomorphic (BlockForging m) where
                                    (project cfg)
                                    bno
                                    sno
-                                   (unComp (project (Comp tickedLgrSt)))
+                                   (getFlipTickedLedgerState (project (FlipTickedLedgerState tickedLgrSt)))
                                    (project' (Proxy @(WrapValidatedGenTx blk)) <$> txs)
                                    (project' (Proxy @(WrapIsLeader blk)) isLeader)
       }
@@ -505,15 +508,15 @@ instance Functor m => Isomorphic (ProtocolInfo m) where
           => ProtocolInfo m (HardForkBlock '[blk]) -> ProtocolInfo m blk
   project ProtocolInfo {..} = ProtocolInfo {
         pInfoConfig       = project pInfoConfig
-      , pInfoInitLedger   = project pInfoInitLedger
+      , pInfoInitLedger   = unFlip $ project $ Flip pInfoInitLedger
       , pInfoBlockForging = fmap project <$> pInfoBlockForging
       }
 
   inject :: forall blk. NoHardForks blk
          => ProtocolInfo m blk -> ProtocolInfo m (HardForkBlock '[blk])
   inject ProtocolInfo {..} = ProtocolInfo {
         pInfoConfig       = inject pInfoConfig
-      , pInfoInitLedger   = inject pInfoInitLedger
+      , pInfoInitLedger   = unFlip $ inject $ Flip pInfoInitLedger
       , pInfoBlockForging = fmap inject <$> pInfoBlockForging
       }
 

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

@@ -34,7 +34,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.HardFork.Combinator.Basics
 import           Ouroboros.Consensus.HardFork.Combinator.InjectTxs
-import           Ouroboros.Consensus.HardFork.Combinator.Ledger (Ticked (..))
+import           Ouroboros.Consensus.HardFork.Combinator.Ledger
 import           Ouroboros.Consensus.HardFork.Combinator.Mempool
 import           Ouroboros.Consensus.HardFork.Combinator.Protocol
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
@@ -286,12 +286,12 @@ hardForkCheckCanForge blockForging
 -- This follows from the postcondition of 'check' and the fact that the ticked
 -- 'ChainDepState' and ticked 'LedgerState' are from the same era.
 hardForkForgeBlock ::
-     forall m xs empty. (CanHardFork xs, Monad m)
+     forall m xs mk empty. (CanHardFork xs, Monad m)
   => OptNP empty (BlockForging m) xs
   -> TopLevelConfig (HardForkBlock xs)
   -> BlockNo
   -> SlotNo
-  -> TickedLedgerState (HardForkBlock xs)
+  -> TickedLedgerState (HardForkBlock xs) mk
   -> [Validated (GenTx (HardForkBlock xs))]
   -> HardForkIsLeader xs
   -> m (HardForkBlock xs)
@@ -358,15 +358,15 @@ hardForkForgeBlock blockForging
       -> Product
            (Product
               WrapIsLeader
-              (Ticked :.: LedgerState))
+              (FlipTickedLedgerState mk))
            ([] :.: WrapValidatedGenTx)
            blk
       -> m blk
     forgeBlockOne index
                   cfg'
                   (Comp mBlockForging')
                   (Pair
-                    (Pair (WrapIsLeader isLeader') (Comp ledgerState'))
+                    (Pair (WrapIsLeader isLeader') (FlipTickedLedgerState ledgerState'))
                     (Comp txs')) =
         forgeBlock
           (fromMaybe