More consistent naming of snapshot merging and incoming run types

Author: dcoutts

src/Database/LSMTree/Internal/Snapshot.hs

@@ -7,7 +7,7 @@ module Database.LSMTree.Internal.Snapshot (
   , SnapLevels (..)
   , SnapLevel (..)
   , SnapIncomingRun (..)
-  , SnapMergingRunState (..)
+  , SnapMergingRun (..)
     -- * MergeTree snapshot format
   , SnapMergingTree(..)
   , SnapMergingTreeState(..)
@@ -170,31 +170,32 @@ instance NFData r => NFData (SnapLevel r) where
 -- both to zero).
 --
 data SnapIncomingRun r =
-    SnapMergingRun !MergePolicyForLevel
-                   !NominalDebt
-                   !NominalCredits -- ^ The nominal credits supplied, and that
-                                   -- need to be supplied on snapshot open.
-                   !(SnapMergingRunState MR.LevelMergeType r)
-  | SnapSingleRun !r
+    SnapIncomingMergingRun
+      !MergePolicyForLevel
+      !NominalDebt
+      !NominalCredits -- ^ The nominal credits supplied, and that
+                     -- need to be supplied on snapshot open.
+      !(SnapMergingRun MR.LevelMergeType r)
+  | SnapIncomingSingleRun !r
   deriving stock (Eq, Functor, Foldable, Traversable)
 
 instance NFData r => NFData (SnapIncomingRun r) where
-  rnf (SnapMergingRun a b c d) =
+  rnf (SnapIncomingMergingRun a b c d) =
       rnf a `seq` rnf b `seq` rnf c `seq` rnf d
-  rnf (SnapSingleRun a) = rnf a
+  rnf (SnapIncomingSingleRun a) = rnf a
 
 -- | The total number of supplied credits. This total is used on snapshot load
 -- to restore merging work that was lost when the snapshot was created.
 newtype SuppliedCredits = SuppliedCredits { getSuppliedCredits :: Int }
   deriving stock (Eq, Read)
   deriving newtype NFData
 
-data SnapMergingRunState t r =
+data SnapMergingRun t r =
     SnapCompletedMerge !NumRuns !MergeDebt !r
   | SnapOngoingMerge   !RunParams !MergeCredits !(V.Vector r) !t
   deriving stock (Eq, Functor, Foldable, Traversable)
 
-instance (NFData t, NFData r) => NFData (SnapMergingRunState t r) where
+instance (NFData t, NFData r) => NFData (SnapMergingRun t r) where
   rnf (SnapCompletedMerge a b c)   = rnf a `seq` rnf b `seq` rnf c
   rnf (SnapOngoingMerge   a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
 
@@ -208,9 +209,8 @@ newtype SnapMergingTree r = SnapMergingTree (SnapMergingTreeState r)
 
 data SnapMergingTreeState r =
     SnapCompletedTreeMerge !r
-  | SnapPendingTreeMerge !(SnapPendingMerge r)
-  | SnapOngoingTreeMerge
-      !(SnapMergingRunState MR.TreeMergeType r)
+  | SnapPendingTreeMerge   !(SnapPendingMerge r)
+  | SnapOngoingTreeMerge   !(SnapMergingRun MR.TreeMergeType r)
   deriving stock (Eq, Functor, Foldable, Traversable)
 
 instance NFData r => NFData (SnapMergingTreeState r) where
@@ -231,9 +231,8 @@ instance NFData r => NFData (SnapPendingMerge r) where
   rnf (SnapPendingUnionMerge a)   = rnf a
 
 data SnapPreExistingRun r =
-    SnapPreExistingRun !r
-  | SnapPreExistingMergingRun
-      !(SnapMergingRunState MR.LevelMergeType r)
+    SnapPreExistingRun        !r
+  | SnapPreExistingMergingRun !(SnapMergingRun MR.LevelMergeType r)
   deriving stock (Eq, Functor, Foldable, Traversable)
 
 instance NFData r => NFData (SnapPreExistingRun r) where
@@ -307,7 +306,7 @@ fromSnapMergingTree hfs hbio uc resolve dir =
 
     go reg (SnapMergingTree (SnapOngoingTreeMerge smrs)) = do
       mr <- withRollback reg
-               (fromSnapMergingRunState hfs hbio uc resolve dir smrs)
+               (fromSnapMergingRun hfs hbio uc resolve dir smrs)
                releaseRef
       mt <- withRollback reg
               (MT.newOngoingMerge mr)
@@ -325,7 +324,7 @@ fromSnapMergingTree hfs hbio uc resolve dir =
     fromSnapPreExistingRun reg (SnapPreExistingMergingRun smrs) =
       MT.PreExistingMergingRun <$>
         withRollback reg
-          (fromSnapMergingRunState hfs hbio uc resolve dir smrs)
+          (fromSnapMergingRun hfs hbio uc resolve dir smrs)
           releaseRef
 
     releasePER (MT.PreExistingRun         r) = releaseRef r
@@ -351,7 +350,7 @@ toSnapMergingTreeState ::
 toSnapMergingTreeState (MT.CompletedTreeMerge r) = pure $ SnapCompletedTreeMerge r
 toSnapMergingTreeState (MT.PendingTreeMerge p) = SnapPendingTreeMerge <$> toSnapPendingMerge p
 toSnapMergingTreeState (MT.OngoingTreeMerge mergingRun) =
-  SnapOngoingTreeMerge <$> toSnapMergingRunState mergingRun
+  SnapOngoingTreeMerge <$> toSnapMergingRun mergingRun
 
 {-# SPECIALISE toSnapPendingMerge :: MT.PendingMerge IO h -> IO (SnapPendingMerge (Ref (Run IO h))) #-}
 toSnapPendingMerge ::
@@ -372,7 +371,7 @@ toSnapPreExistingRun ::
   -> m (SnapPreExistingRun (Ref (Run m h)))
 toSnapPreExistingRun (MT.PreExistingRun run) = pure $ SnapPreExistingRun run
 toSnapPreExistingRun (MT.PreExistingMergingRun peMergingRun) =
-  SnapPreExistingMergingRun <$> toSnapMergingRunState peMergingRun
+  SnapPreExistingMergingRun <$> toSnapMergingRun peMergingRun
 
 {-------------------------------------------------------------------------------
   Conversion to levels snapshot format
@@ -408,24 +407,24 @@ toSnapIncomingRun ::
 toSnapIncomingRun ir = do
     s <- snapshotIncomingRun ir
     case s of
-      Left r -> pure $! SnapSingleRun r
+      Left r -> pure $! SnapIncomingSingleRun r
       Right (mergePolicy,
              nominalDebt,
              nominalCredits,
              mergingRun) -> do
         -- We need to know how many credits were supplied so we can restore merge
         -- work on snapshot load.
-        smrs <- toSnapMergingRunState mergingRun
-        pure $! SnapMergingRun mergePolicy nominalDebt nominalCredits smrs
+        smrs <- toSnapMergingRun mergingRun
+        pure $! SnapIncomingMergingRun mergePolicy nominalDebt nominalCredits smrs
 
-{-# SPECIALISE toSnapMergingRunState ::
+{-# SPECIALISE toSnapMergingRun ::
      Ref (MR.MergingRun t IO h)
-  -> IO (SnapMergingRunState t (Ref (Run IO h))) #-}
-toSnapMergingRunState ::
+  -> IO (SnapMergingRun t (Ref (Run IO h))) #-}
+toSnapMergingRun ::
      (PrimMonad m, MonadMVar m)
   => Ref (MR.MergingRun t m h)
-  -> m (SnapMergingRunState t (Ref (Run m h)))
-toSnapMergingRunState !mr = do
+  -> m (SnapMergingRun t (Ref (Run m h)))
+toSnapMergingRun !mr = do
     -- TODO: MR.snapshot needs to return duplicated run references, and we
     -- need to arrange to release them when the snapshotting is done.
     (numRuns, mergeDebt, mergeCredits, state) <- MR.snapshot mr
@@ -680,47 +679,46 @@ fromSnapLevels hfs hbio uc conf resolve reg dir (SnapLevels levels) =
          LevelNo
       -> SnapIncomingRun (Ref (Run m h))
       -> m (IncomingRun m h)
-    fromSnapIncomingRun _ln (SnapSingleRun run) =
+    fromSnapIncomingRun _ln (SnapIncomingSingleRun run) =
         newIncomingSingleRun run
 
-    fromSnapIncomingRun ln (SnapMergingRun mergePolicy nominalDebt
-                                           nominalCredits smrs) =
+    fromSnapIncomingRun ln (SnapIncomingMergingRun mergePolicy nominalDebt
+                                                   nominalCredits smrs) =
       bracket
-        (fromSnapMergingRunState hfs hbio uc resolve dir smrs)
+        (fromSnapMergingRun hfs hbio uc resolve dir smrs)
         releaseRef $ \mr -> do
 
         ir <- newIncomingMergingRun mergePolicy nominalDebt mr
         -- This will set the correct nominal credits, but it will not do any
-        -- more merging work because fromSnapMergingRunState already supplies
+        -- more merging work because fromSnapMergingRun already supplies
         -- all the merging credits already.
         supplyCreditsIncomingRun conf ln ir nominalCredits
         return ir
 
-{-# SPECIALISE fromSnapMergingRunState ::
+{-# SPECIALISE fromSnapMergingRun ::
      MR.IsMergeType t
   => HasFS IO h
   -> HasBlockIO IO h
   -> UniqCounter IO
   -> ResolveSerialisedValue
   -> ActiveDir
-  -> SnapMergingRunState t (Ref (Run IO h))
+  -> SnapMergingRun t (Ref (Run IO h))
   -> IO (Ref (MR.MergingRun t IO h)) #-}
-fromSnapMergingRunState ::
+fromSnapMergingRun ::
      (MonadMask m, MonadMVar m, MonadSTM m, MonadST m, MR.IsMergeType t)
   => HasFS m h
   -> HasBlockIO m h
   -> UniqCounter m
   -> ResolveSerialisedValue
   -> ActiveDir
-  -> SnapMergingRunState t (Ref (Run m h))
+  -> SnapMergingRun t (Ref (Run m h))
   -> m (Ref (MR.MergingRun t m h))
-fromSnapMergingRunState _hfs _hbio _uc _resolve _dir
-                        (SnapCompletedMerge numRuns mergeDebt r) =
+fromSnapMergingRun _hfs _hbio _uc _resolve _dir
+                   (SnapCompletedMerge numRuns mergeDebt r) =
     MR.newCompleted numRuns mergeDebt r
 
-fromSnapMergingRunState hfs hbio uc resolve dir
-                        (SnapOngoingMerge runParams mergeCredits
-                                          rs mergeType) = do
+fromSnapMergingRun hfs hbio uc resolve dir
+                   (SnapOngoingMerge runParams mergeCredits rs mergeType) = do
     bracketOnError
       (do uniq <- incrUniqCounter uc
           let runPaths = runPath dir (uniqueToRunNumber uniq)

src/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -560,14 +560,14 @@ instance DecodeVersioned RunNumber where
 -- SnapIncomingRun
 
 instance Encode r => Encode (SnapIncomingRun r) where
-  encode (SnapMergingRun mpfl nd nc smrs) =
+  encode (SnapIncomingMergingRun mpfl nd nc smrs) =
        encodeListLen 5
     <> encodeWord 0
     <> encode mpfl
     <> encode nd
     <> encode nc
     <> encode smrs
-  encode (SnapSingleRun x) =
+  encode (SnapIncomingSingleRun x) =
        encodeListLen 2
     <> encodeWord 1
     <> encode x
@@ -577,10 +577,11 @@ instance DecodeVersioned r => DecodeVersioned (SnapIncomingRun r) where
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
-        (5, 0) -> SnapMergingRun <$> decodeVersioned v <*> decodeVersioned v
-                                 <*> decodeVersioned v <*> decodeVersioned v
-        (2, 1) -> SnapSingleRun <$> decodeVersioned v
-        _ -> fail ("[SnapMergingRun] Unexpected combination of list length and tag: " <> show (n, tag))
+        (5, 0) -> SnapIncomingMergingRun
+                    <$> decodeVersioned v <*> decodeVersioned v
+                    <*> decodeVersioned v <*> decodeVersioned v
+        (2, 1) -> SnapIncomingSingleRun <$> decodeVersioned v
+        _ -> fail ("[SnapIncomingRun] Unexpected combination of list length and tag: " <> show (n, tag))
 
 -- NumRuns
 
@@ -604,9 +605,9 @@ instance DecodeVersioned MergePolicyForLevel where
         1 -> pure LevelLevelling
         _ -> fail ("[MergePolicyForLevel] Unexpected tag: " <> show tag)
 
--- SnapMergingRunState
+-- SnapMergingRun
 
-instance (Encode t, Encode r) => Encode (SnapMergingRunState t r) where
+instance (Encode t, Encode r) => Encode (SnapMergingRun t r) where
   encode (SnapCompletedMerge nr md r) =
          encodeListLen 4
       <> encodeWord 0
@@ -621,7 +622,7 @@ instance (Encode t, Encode r) => Encode (SnapMergingRunState t r) where
       <> encode rs
       <> encode mt
 
-instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingRunState t r) where
+instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingRun t r) where
   decodeVersioned v@V0 = do
       n <- decodeListLen
       tag <- decodeWord
@@ -631,7 +632,7 @@ instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingR
                                      <*> decodeVersioned v
         (5, 1) -> SnapOngoingMerge <$> decodeVersioned v <*> decodeVersioned v
                                    <*> decodeVersioned v <*> decodeVersioned v
-        _ -> fail ("[SnapMergingRunState] Unexpected combination of list length and tag: " <> show (n, tag))
+        _ -> fail ("[SnapMergingRun] Unexpected combination of list length and tag: " <> show (n, tag))
 
 -- NominalDebt, NominalCredits, MergeDebt and MergeCredits
 

test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -177,7 +177,7 @@ testAll test = [
     , test (Proxy @RunBloomFilterAlloc)
     , test (Proxy @IndexType)
     , test (Proxy @RunParams)
-    , test (Proxy @(SnapMergingRunState LevelMergeType SnapshotRun))
+    , test (Proxy @(SnapMergingRun LevelMergeType SnapshotRun))
     , test (Proxy @MergeDebt)
     , test (Proxy @MergeCredits)
     , test (Proxy @NominalDebt)
@@ -298,22 +298,22 @@ deriving newtype instance Arbitrary RunNumber
 
 instance Arbitrary r => Arbitrary (SnapIncomingRun r) where
   arbitrary = oneof [
-        SnapMergingRun <$> arbitrary <*> arbitrary
-                       <*> arbitrary <*> arbitrary
-      , SnapSingleRun <$> arbitrary
+        SnapIncomingMergingRun <$> arbitrary <*> arbitrary
+                               <*> arbitrary <*> arbitrary
+      , SnapIncomingSingleRun <$> arbitrary
       ]
-  shrink (SnapMergingRun a b c d) =
-      [ SnapMergingRun a' b' c' d'
+  shrink (SnapIncomingMergingRun a b c d) =
+      [ SnapIncomingMergingRun a' b' c' d'
       | (a', b', c', d') <- shrink (a, b, c, d) ]
-  shrink (SnapSingleRun a)  = SnapSingleRun <$> shrink a
+  shrink (SnapIncomingSingleRun a)  = SnapIncomingSingleRun <$> shrink a
 
 deriving newtype instance Arbitrary NumRuns
 
 instance Arbitrary MergePolicyForLevel where
   arbitrary = elements [LevelTiering, LevelLevelling]
   shrink _ = []
 
-instance (Arbitrary t, Arbitrary r) => Arbitrary (SnapMergingRunState t r) where
+instance (Arbitrary t, Arbitrary r) => Arbitrary (SnapMergingRun t r) where
   arbitrary = oneof [
         SnapCompletedMerge <$> arbitrary <*> arbitrary <*> arbitrary
       , SnapOngoingMerge <$> arbitrary <*> arbitrary
@@ -370,7 +370,7 @@ deriving stock instance Show SnapshotRun
 deriving stock instance Show r => Show (SnapLevels r)
 deriving stock instance Show r => Show (SnapLevel r)
 deriving stock instance Show r => Show (SnapIncomingRun r)
-deriving stock instance (Show t, Show r) => Show (SnapMergingRunState t r)
+deriving stock instance (Show t, Show r) => Show (SnapMergingRun t r)
 
 deriving stock instance Show r => Show (SnapMergingTree r)
 deriving stock instance Show r => Show (SnapMergingTreeState r)

test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs

@@ -236,21 +236,22 @@ enumerateSnapIncomingRun =
   let
       inSnaps =
         [ (fuseAnnotations ["R1", a, b],
-           SnapMergingRun policy nominalDebt nominalCredits sState)
+           SnapIncomingMergingRun policy nominalDebt nominalCredits sState)
         | (a, policy ) <- [("P0", LevelTiering), ("P1", LevelLevelling)]
         , nominalDebt    <- NominalDebt    <$> [ magicNumber2 ]
         , nominalCredits <- NominalCredits <$> [ magicNumber1 ]
-        , (b, sState ) <- enumerateSnapMergingRunState enumerateLevelMergeType
+        , (b, sState ) <- enumerateSnapMergingRun enumerateLevelMergeType
         ]
   in  fold
-      [ [(fuseAnnotations $ "R0" : replicate 4 blank, SnapSingleRun enumerateOpenRunInfo)]
+      [ [(fuseAnnotations $ "R0" : replicate 4 blank,
+          SnapIncomingSingleRun enumerateOpenRunInfo)]
       , inSnaps
       ]
 
-enumerateSnapMergingRunState ::
+enumerateSnapMergingRun ::
      [(ComponentAnnotation, t)]
-  -> [(ComponentAnnotation, SnapMergingRunState t SnapshotRun)]
-enumerateSnapMergingRunState mTypes =
+  -> [(ComponentAnnotation, SnapMergingRun t SnapshotRun)]
+enumerateSnapMergingRun mTypes =
     [ (fuseAnnotations ["C0", blank, blank],
        SnapCompletedMerge numRuns mergeDebt enumerateOpenRunInfo)
     | numRuns   <- NumRuns <$> [ magicNumber1 ]
@@ -302,7 +303,7 @@ enumerateSnapMergingTreeState expandable =
 
 enumerateSnapOngoingTreeMerge :: [(ComponentAnnotation, SnapMergingTreeState SnapshotRun)]
 enumerateSnapOngoingTreeMerge = do
-  (tagX, valX) <- enumerateSnapMergingRunState enumerateTreeMergeType
+  (tagX, valX) <- enumerateSnapMergingRun enumerateTreeMergeType
   let value = SnapOngoingTreeMerge valX
   pure ( fuseAnnotations $ ["G0", blank, tagX] <> replicate 5 blank, value )
 
@@ -328,7 +329,7 @@ enumerateSnapPreExistingRun :: [(ComponentAnnotation, SnapPreExistingRun Snapsho
 enumerateSnapPreExistingRun =
     ( fuseAnnotations ("E0" : replicate 3 blank), SnapPreExistingRun enumerateOpenRunInfo)
   : [ (fuseAnnotations ["E1", tagX], SnapPreExistingMergingRun valX)
-    | (tagX, valX) <- enumerateSnapMergingRunState enumerateLevelMergeType
+    | (tagX, valX) <- enumerateSnapMergingRun enumerateLevelMergeType
     ]
 
 enumerateTreeMergeType :: [(ComponentAnnotation, MR.TreeMergeType)]