make assertions on LSM shape in prototype tests

Author: mheinzel

prototypes/ScheduledMerges.hs

@@ -655,14 +655,18 @@ dumpLevel (Level (MergingRun mp ml mr) rs) = do
     mrs <- readSTRef mr
     return (Just (mp, ml, mrs), rs)
 
+-- For each level:
+-- 1. the runs involved in an ongoing merge
+-- 2. the other runs (including completed merge)
 representationShape :: [(Maybe (MergePolicy, MergeLastLevel, MergingRunState), [Run])]
-                    -> [(Maybe (MergePolicy, MergeLastLevel, Either Int [Int]), [Int])]
+                    -> [([Int], [Int])]
 representationShape =
     map $ \(mmr, rs) ->
-      ( fmap (\(mp, ml, mrs) -> (mp, ml, summaryMRS mrs)) mmr
-      , map summaryRun rs)
+      let (ongoing, complete) = summaryMR mmr
+      in (ongoing, complete <> map summaryRun rs)
   where
     summaryRun = runSize
-    summaryMRS (CompletedMerge r)    = Left (summaryRun r)
-    summaryMRS (OngoingMerge _ rs _) = Right (map summaryRun rs)
-
+    summaryMR = \case
+      Nothing                          -> ([], [])
+      Just (_, _, CompletedMerge r)    -> ([], [summaryRun r])
+      Just (_, _, OngoingMerge _ rs _) -> (map summaryRun rs, [])

prototypes/ScheduledMergesTestQLS.hs

@@ -13,7 +13,7 @@ import           Data.Proxy
 import           Data.STRef
 
 import           Control.Exception
-import           Control.Monad (replicateM_)
+import           Control.Monad (replicateM_, when)
 import           Control.Monad.ST
 import           Control.Tracer (Tracer (Tracer), nullTracer)
 import qualified Control.Tracer as Tracer
@@ -26,7 +26,7 @@ import           Test.QuickCheck.StateModel.Lockstep hiding (ModelOp)
 import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep
 import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep
 import           Test.Tasty
-import           Test.Tasty.HUnit (testCase)
+import           Test.Tasty.HUnit (HasCallStack, testCase)
 import           Test.Tasty.QuickCheck (testProperty)
 
 
@@ -39,7 +39,6 @@ tests = testGroup "ScheduledMerges" [
       testProperty "ScheduledMerges vs model" $ mapSize (*10) prop_LSM  -- still <10s
     , testCase "regression_empty_run" test_regression_empty_run
     , testCase "merge_again_with_incoming" test_merge_again_with_incoming
-    , testCase "merge_again_with_incoming'" test_merge_again_with_incoming'
     ]
 
 prop_LSM :: Actions (Lockstep Model) -> Property
@@ -73,17 +72,34 @@ test_regression_empty_run =
         del 1
         del 2
         del 3
+
+        expectShape lsm
+          [ ([], [4,4,4,4])
+          ]
+
         -- run 5, results in last level merge of run 1-4
         ins 0
         ins 1
         ins 2
         ins 3
+
+        expectShape lsm
+          [ ([], [4])
+          , ([4,4,4,4], [])
+          ]
+
         -- finish merge
         LSM.supply lsm 16
 
+        expectShape lsm
+          [ ([], [4])
+          , ([], [0])
+          ]
+
 -- | Covers the case where a run ends up too small for a level, so it gets
 -- merged again with the next incoming runs.
--- That merge gets completed by supplying credits.
+-- That 5-way merge gets completed by supplying credits That merge gets
+-- completed by supplying credits and then becomes part of another merge.
 test_merge_again_with_incoming :: IO ()
 test_merge_again_with_incoming =
     runWithTracer $ \tracer -> do
@@ -93,35 +109,62 @@ test_merge_again_with_incoming =
         -- get something to 3rd level (so 2nd level is not levelling)
         -- (needs 5 runs to go to level 2 so the resulting run becomes too big)
         traverse_ ins [101..100+(5*16)]
-        -- get a very small run (4 elements) to 2nd level
-        replicateM_ 4 $
-          traverse_ ins [201..200+4]
-        -- get another run to 2nd level, which the small run can be merged with
-        traverse_ ins [301..300+16]
-        -- complete the merge
-        LSM.supply lsm 32
 
--- | Covers the case where a run ends up too small for a level, so it gets
--- merged again with the next incoming runs.
--- That merge gets completed and becomes part of another merge.
-test_merge_again_with_incoming' :: IO ()
-test_merge_again_with_incoming' =
-    runWithTracer $ \tracer -> do
-      stToIO $ do
-        lsm <- LSM.new
-        let ins k = LSM.insert tracer lsm k 0
-        -- get something to 3rd level (so 2nd level is not levelling)
-        -- (needs 5 runs to go to level 2 so the resulting run becomes too big)
-        traverse_ ins [101..100+(5*16)]
+        expectShape lsm  -- not yet arrived at level 3, but will soon
+          [ ([], [4,4,4,4])
+          , ([16,16,16,16], [])
+          ]
+
         -- get a very small run (4 elements) to 2nd level
         replicateM_ 4 $
           traverse_ ins [201..200+4]
+
+        expectShape lsm
+          [ ([], [4,4,4,4])  -- these runs share the same keys
+          , ([4,4,4,4,64], [])
+          ]
+
         -- get another run to 2nd level, which the small run can be merged with
         traverse_ ins [301..300+16]
-        -- get 3 more to 2nd level, so the merge above is expected to complete
-        -- (actually more, as runs only move once a fifth run arrives...)
-        traverse_ ins [401..400+(6*16)]
 
+        expectShape lsm
+          [ ([], [4,4,4,4])
+          , ([4,4,4,4], [])
+          , ([], [80])
+          ]
+
+        -- add just one more run so the 5-way merge on 2nd level gets created
+        traverse_ ins [401..400+4]
+
+        expectShape lsm
+          [ ([], [4])
+          , ([4,4,4,4,4], [])
+          , ([], [80])
+          ]
+
+        -- complete the merge (20 entries, but credits get scaled up by 1.25)
+        LSM.supply lsm 16
+
+        expectShape lsm
+          [ ([], [4])
+          , ([], [20])
+          , ([], [80])
+          ]
+
+        -- get 3 more runs to 2nd level, so the 5-way merge completes
+        -- and becomes part of a new merge.
+        -- (actually 4, as runs only move once a fifth run arrives...)
+        traverse_ ins [501..500+(4*16)]
+
+        expectShape lsm
+          [ ([], [4])
+          , ([4,4,4,4], [])
+          , ([16,16,16,20,80], [])
+          ]
+
+-------------------------------------------------------------------------------
+-- tracing and expectations on LSM shape
+--
 
 -- | Provides a tracer and will add the log of traced events to the reported
 -- failure.
@@ -140,6 +183,15 @@ instance Exception TracedException where
   displayException (Traced e ev) =
     displayException e <> "\ntrace:\n" <> unlines (map show ev)
 
+expectShape :: HasCallStack => LSM s -> [([Int], [Int])] -> ST s ()
+expectShape lsm expected = do
+    shape <- representationShape <$> dumpRepresentation lsm
+    when (shape == expected) $
+      error $ unlines
+        [ "expected shape: " <> show expected
+        , "actual shape:   " <> show shape
+        ]
+
 -------------------------------------------------------------------------------
 -- QLS infrastructure
 --