Merge pull request #614 from IntersectMBO/mheinzel/qls-enable-unions

Enable unions in lockstep tests

Author: dcoutts

src/Database/LSMTree/Internal.hs

@@ -1631,8 +1631,10 @@ remainingUnionDebt :: (MonadSTM m, MonadThrow m) => Table m h -> m UnionDebt
 remainingUnionDebt t = do
     traceWith (tableTracer t) TraceRemainingUnionDebt
     withOpenTable t $ \tEnv -> do
-      RW.withReadAccess (tableContent tEnv) $ \_tableContent -> do
-        error "remainingUnionDebt: not yet implemented"
+      RW.withReadAccess (tableContent tEnv) $ \tableContent ->
+        case tableUnionLevel tableContent of
+          NoUnion -> pure (UnionDebt 0)
+          Union{} -> error "remainingUnionDebt: not yet implemented"
 
 -- | See 'Database.LSMTree.Normal.UnionCredits'.
 newtype UnionCredits = UnionCredits Int
@@ -1645,5 +1647,12 @@ supplyUnionCredits t credits = do
     traceWith (tableTracer t) $ TraceSupplyUnionCredits credits
     withOpenTable t $ \tEnv -> do
       -- TODO: should this be acquiring read or write access?
-      RW.withWriteAccess (tableContent tEnv) $ \_tableContent -> do
-        error "supplyUnionCredits: not yet implemented"
+      RW.withWriteAccess (tableContent tEnv) $ \tableContent ->
+        case tableUnionLevel tableContent of
+          NoUnion -> pure (tableContent, credits) -- all leftovers
+          Union{}
+           | credits <= UnionCredits 0 -> pure (tableContent, UnionCredits 0)
+           --TODO: remove this 0 special case once the general case covers it.
+           -- We do not need to optimise the 0 case. It is just here to
+           -- simplify test coverage.
+           | otherwise -> error "supplyUnionCredits: not yet implemented"

src/Database/LSMTree/Internal/MergeSchedule.hs

@@ -352,10 +352,7 @@ iforLevelM_ lvls k = V.iforM_ lvls $ \i lvl -> k (LevelNo (i + 1)) lvl
 -- of multiple runs, but a nested tree of merges.
 --
 -- TODO: So far, this is
--- * never created
--- * not stored in snapshots
--- * not loaded from snapshots
--- * ignored in lookups
+-- * not considered when creating cursors (also used for range lookups)
 -- * never made merge progress on (by supplying credits to it)
 -- * never merged into the regular levels
 data UnionLevel m h =

test/Database/LSMTree/Model/Session.hs

@@ -844,7 +844,9 @@ supplyUnionCredits ::
   -> UnionCredits
   -> m UnionCredits
 supplyUnionCredits t@Table{..} c@(UnionCredits credits)
-  | credits <= 0 = pure c
+  | credits <= 0 = do
+      _ <- guardTableIsOpen t
+      pure (UnionCredits 0) -- always 0, not negative
   | otherwise = do
       (updc, table) <- guardTableIsOpen t
       when (isUnionDescendant == IsUnionDescendant) $