Cover supplying 0 union credits as a unit test and remove QLS coverage

Same principle as previous patches. Keep the precious coverage space in
the QLS tests for the non-trivial cases, and cover the trivial case in a
unit test.

Author: dcoutts

src/Database/LSMTree/Internal.hs

@@ -1649,4 +1649,9 @@ supplyUnionCredits t credits = do
       RW.withWriteAccess (tableContent tEnv) $ \tableContent ->
         case tableUnionLevel tableContent of
           NoUnion -> pure (tableContent, credits) -- all leftovers
-          Union{} -> error "supplyUnionCredits: not yet implemented"
+          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"

test/Database/LSMTree/Model/Session.hs

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

test/Test/Database/LSMTree/StateMachine.hs

@@ -1999,15 +1999,10 @@ arbitraryActionWithVars _ label ctx (ModelState st _stats) =
         , isJust (eqT @h @ModelIO.Table)
         ]
       where
-        -- TODO: tweak distribution once table unions are implemented
-        genUnionCredits = QC.frequency [
-            -- The typical, interesting case is to supply a positive number of
-            -- union credits.
-            (9, R.UnionCredits . QC.getPositive <$> QC.arbitrary)
-            -- Supplying 0 or less credits is a no-op, so we generate it only
-            -- rarely.
-          , (1, R.UnionCredits <$> QC.arbitrary)
-          ]
+        -- The typical, interesting case is to supply a positive number of
+        -- union credits. Supplying 0 or less credits is a no-op. We cover
+        -- it in UnitTests so we don't have to cover it here.
+        genUnionCredits = R.UnionCredits . QC.getPositive <$> QC.arbitrary
 
         -- TODO: tweak distribution once table unions are implemented
         genPortion = Portion <$> QC.elements [1, 2, 3]

test/Test/Database/LSMTree/UnitTests.hs

@@ -35,6 +35,7 @@ tests =
       , testCase      "unit_snapshots"      unit_snapshots
       , testCase      "unit_unions_1"       unit_unions_1
       , testCase      "unit_union_credits"  unit_union_credits
+      , testCase      "unit_union_credit_0" unit_union_credit_0
       ]
 
 unit_blobs :: (String -> IO ()) -> Assertion
@@ -191,6 +192,27 @@ unit_union_credits =
       UnionCredits leftover <- supplyUnionCredits table (UnionCredits 42)
       leftover @?= 42
 
+-- | Supplying zero or negative credits to union tables works, but does nothing.
+unit_union_credit_0 :: Assertion
+unit_union_credit_0 =
+    withTempIOHasBlockIO "test" $ \hfs hbio ->
+    withSession nullTracer hfs hbio (FS.mkFsPath []) $ \sess ->
+    withTable @_ @Key1 @Value1 @Blob1 sess defaultTableConfig $ \table -> do
+      inserts table [(Key1 17, Value1 42, Nothing)]
+
+      bracket (table `union` table) close $ \table' -> do
+        -- Supplying 0 credits works and returns 0 leftovers.
+        UnionCredits leftover <- supplyUnionCredits table' (UnionCredits 0)
+        leftover @?= 0
+
+        -- Supplying negative credits also works and returns 0 leftovers.
+        UnionCredits leftover' <- supplyUnionCredits table' (UnionCredits (-42))
+        leftover' @?= 0
+
+        -- And the table is still vaguely cromulent
+        r <- lookups table' [Key1 17]
+        V.map ignoreBlobRef r @?= [Found (Value1 42)]
+
 ignoreBlobRef :: Functor f => f (BlobRef m b) -> f ()
 ignoreBlobRef = fmap (const ())