WIP simplify last of the InMemory holes

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Basics.hs

@@ -334,6 +334,7 @@ data MapKind = AnnMK Type MapKind   -- TODO this one really complicates a few th
              | DiffMK
              | EmptyMK
              | KeysMK
+             | RewoundMK
              | SeqDiffMK
              | TrackingMK
              | ValuesMK
@@ -347,6 +348,7 @@ data ApplyMapKind :: MapKind -> Type -> Type -> Type where
   ApplySeqDiffMK  :: !(SeqUtxoDiff k v)                    -> ApplyMapKind SeqDiffMK    k v
   ApplyTrackingMK :: !(UtxoValues  k v) -> !(UtxoDiff k v) -> ApplyMapKind TrackingMK   k v
   ApplyValuesMK   :: !(UtxoValues  k v)                    -> ApplyMapKind ValuesMK     k v
+  ApplyRewoundMK  :: !(RewoundKeys k v)                    -> ApplyMapKind RewoundMK    k v
 
 class HasEmptyMK mk where
   emptyAppliedMK_ :: Ord k => ApplyMapKind mk k v
@@ -372,6 +374,7 @@ mapValuesAppliedMK f = \case
   ApplyTrackingMK vs diff -> ApplyTrackingMK (mapUtxoValues f vs)     (mapUtxoDiff f diff)
   ApplyDiffMK diff        -> ApplyDiffMK     (mapUtxoDiff f diff)
   ApplySeqDiffMK diffs    -> ApplySeqDiffMK  (mapSeqUtxoDiff f diffs)
+  ApplyRewoundMK rew      -> ApplyRewoundMK  (mapRewoundKeys f rew)
 
 {-
 instance (Ord k, Eq v) => Eq (ApplyMapKind mk k v) where
@@ -391,6 +394,7 @@ instance (Ord k, NoThunks k, NoThunks v) => NoThunks (ApplyMapKind mk k v) where
     ApplyTrackingMK vs diff -> [noThunks ctxt vs, noThunks ctxt diff]
     ApplyDiffMK diff        -> [noThunks ctxt diff]
     ApplySeqDiffMK diffs    -> [noThunks ctxt diffs]
+    ApplyRewoundMK rew      -> [noThunks ctxt rew]
 
   showTypeOf _ = "ApplyMapKind"
 
@@ -403,6 +407,7 @@ data instance Sing (mk :: MapKind) :: Type where
   STrackingMK :: Sing TrackingMK
   SDiffMK     :: Sing DiffMK
   SSeqDiffMK  :: Sing SeqDiffMK
+  SRewoundMK  :: Sing RewoundMK
 
 type SMapKind = Sing :: MapKind -> Type
 
@@ -414,6 +419,7 @@ instance SingI ValuesMK   where sing = SValuesMK
 instance SingI TrackingMK where sing = STrackingMK
 instance SingI DiffMK     where sing = SDiffMK
 instance SingI SeqDiffMK  where sing = SSeqDiffMK
+instance SingI RewoundMK  where sing = SRewoundMK
 
 toSMapKind :: SingI mk => proxy mk k v -> SMapKind mk
 toSMapKind _ = sing
@@ -432,6 +438,7 @@ instance Show (Sing (mk :: MapKind)) where
     STrackingMK -> "STrackingMK"
     SDiffMK     -> "SDiffMK"
     SSeqDiffMK  -> "SSeqDiffMK"
+    SRewoundMK  -> "SRewoundMK"
 
 deriving via OnlyCheckWhnfNamed "Sing @MapKind" (Sing (mk :: MapKind)) instance NoThunks (Sing mk)
 

ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/HD.hs

@@ -22,7 +22,9 @@ module Ouroboros.Consensus.Storage.LedgerDB.HD (
   , UtxoEntryDiffState (..)
   , UtxoEntryDiff (..)
     -- * Combinators
+  , RewoundKeys (..)
   , forwardValues
+  , mapRewoundKeys
   , rewindKeys
     -- * Backing store interface
   , BackingStore (..)
@@ -194,6 +196,15 @@ data RewoundKeys k v = RewoundKeys {
     -- determined by the diff
   , rkUnknown :: UtxoKeys k v
   }
+  deriving (Generic, NoThunks)
+
+mapRewoundKeys :: (v -> v') -> RewoundKeys k v -> RewoundKeys k v'
+mapRewoundKeys f rew =
+    RewoundKeys {
+        rkAbsent  = castUtxoKeys    (rkAbsent  rew)
+      , rkPresent = mapUtxoValues f (rkPresent rew)
+      , rkUnknown = castUtxoKeys    (rkUnknown rew)
+      }
 
 -- | Transport a set of keys backwards through a difference
 --

ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/InMemory.hs

@@ -92,6 +92,7 @@ import           Control.Exception
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Storage.LedgerDB.HD
 import           Ouroboros.Consensus.Storage.LedgerDB.Types (PushGoal (..),
                      PushStart (..), Pushing (..),
                      UpdateLedgerDbTraceEvent (..))
@@ -191,7 +192,7 @@ ledgerDbWithAnchor :: GetTip (l ValuesMK) => l ValuesMK -> LedgerDB l
 ledgerDbWithAnchor anchor = LedgerDB {
       ledgerDbCheckpoints = Empty (Checkpoint anchor)
     , ledgerDbChangelog   =
-        -- TODO function is called from some unpatched initilization code and
+        -- TODO function is called from some unpatched initialization code and
         -- from tests
         undefined
     , runDual = True -- TODO: This is not yet implemented.
@@ -417,17 +418,42 @@ applyBlock cfg ap db = case ap of
   HD Interface that I need (Could be moved to  Ouroboros.Consensus.Ledger.Basics )
 -------------------------------------------------------------------------------}
 
-newtype RewoundTableKeySets l = RewoundTableKeySets (AnnTableKeySets l ()) -- KeySetSanityInfo l
+newtype RewoundTableKeySets l =
+  RewoundTableKeySets (LedgerTables l RewoundMK) -- TODO KeySetSanityInfo l
 
-rewindTableKeySets
-  :: DbChangelog l -> TableKeySets l -> RewoundTableKeySets l
-rewindTableKeySets = undefined
-
-newtype UnforwardedReadSets l = UnforwardedReadSets (AnnTableReadSets l ())
-
-forwardTableKeySets
-  :: DbChangelog l -> UnforwardedReadSets l -> Maybe (TableReadSets l)
-forwardTableKeySets = undefined
+rewindTableKeySets ::
+     TableStuff l
+  => DbChangelog l -> TableKeySets l -> RewoundTableKeySets l
+rewindTableKeySets dblog = \keys ->
+      RewoundTableKeySets
+    $ zipLedgerTables rewind keys
+    $ changelogDiffs dblog
+  where
+    rewind ::
+         Ord k
+      => ApplyMapKind KeysMK    k v
+      -> ApplyMapKind SeqDiffMK k v
+      -> ApplyMapKind RewoundMK k v
+    rewind (ApplyKeysMK keys) (ApplySeqDiffMK diffs) =
+      ApplyRewoundMK $ rewindKeys keys (cumulativeDiffSeqUtxoDiff diffs)
+
+newtype UnforwardedReadSets l = UnforwardedReadSets (LedgerTables l ValuesMK)
+
+forwardTableKeySets ::
+     TableStuff l
+  => DbChangelog l -> UnforwardedReadSets l -> Maybe (TableReadSets l)
+forwardTableKeySets dblog = \(UnforwardedReadSets values) ->
+      Just   -- TODO sanity check
+    $ zipLedgerTables forward values
+    $ changelogDiffs dblog
+  where
+    forward ::
+         Ord k
+      => ApplyMapKind ValuesMK  k v
+      -> ApplyMapKind SeqDiffMK k v
+      -> ApplyMapKind ValuesMK  k v
+    forward (ApplyValuesMK values) (ApplySeqDiffMK diffs) =
+      ApplyValuesMK $ forwardValues values (cumulativeDiffSeqUtxoDiff diffs)
 
 dbChangelogVolatileCheckpoints ::
      DbChangelog l