Add a prop_isStructurallyEmpty for MergingTree

This ensures the property that any structurally empty tree can be
immediately recognised as a structurally empty.

Author: dcoutts

lsm-tree.cabal

@@ -366,6 +366,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Index.Ordinary
     Test.Database.LSMTree.Internal.Lookup
     Test.Database.LSMTree.Internal.Merge
+    Test.Database.LSMTree.Internal.MergingTree
     Test.Database.LSMTree.Internal.Monkey
     Test.Database.LSMTree.Internal.PageAcc
     Test.Database.LSMTree.Internal.PageAcc1

test/Main.hs

@@ -17,6 +17,7 @@ import qualified Test.Database.LSMTree.Internal.Index.Compact
 import qualified Test.Database.LSMTree.Internal.Index.Ordinary
 import qualified Test.Database.LSMTree.Internal.Lookup
 import qualified Test.Database.LSMTree.Internal.Merge
+import qualified Test.Database.LSMTree.Internal.MergingTree
 import qualified Test.Database.LSMTree.Internal.Monkey
 import qualified Test.Database.LSMTree.Internal.PageAcc
 import qualified Test.Database.LSMTree.Internal.PageAcc1
@@ -57,6 +58,7 @@ main = do
     , Test.Database.LSMTree.Internal.Entry.tests
     , Test.Database.LSMTree.Internal.Lookup.tests
     , Test.Database.LSMTree.Internal.Merge.tests
+    , Test.Database.LSMTree.Internal.MergingTree.tests
     , Test.Database.LSMTree.Internal.Monkey.tests
     , Test.Database.LSMTree.Internal.PageAcc.tests
     , Test.Database.LSMTree.Internal.PageAcc1.tests

test/Test/Database/LSMTree/Internal/MergingTree.hs

@@ -0,0 +1,65 @@
+module Test.Database.LSMTree.Internal.MergingTree (tests) where
+
+import           Control.Exception (bracket)
+import           Control.RefCount
+import           Database.LSMTree.Internal.MergingTree
+import           Test.QuickCheck
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests = testGroup "Test.Database.LSMTree.Internal.MergingTree"
+    [ testProperty "prop_isStructurallyEmpty" prop_isStructurallyEmpty
+    ]
+
+-- | Check that the merging tree constructor functions preserve the property
+-- that if the inputs are obviously empty, the output is also obviously empty.
+--
+prop_isStructurallyEmpty :: EmptyMergingTree -> Property
+prop_isStructurallyEmpty emt =
+    ioProperty $
+      bracket (mkEmptyMergingTree emt)
+              releaseRef
+              isStructurallyEmpty
+
+-- | An expression to specify the shape of an empty 'MergingTree'
+--
+data EmptyMergingTree = ObviouslyEmptyLevelMerge
+                      | ObviouslyEmptyUnionMerge
+                      | NonObviouslyEmptyLevelMerge EmptyMergingTree
+                      | NonObviouslyEmptyUnionMerge [EmptyMergingTree]
+  deriving stock (Eq, Show)
+
+instance Arbitrary EmptyMergingTree where
+    arbitrary =
+      sized $ \sz ->
+        frequency $
+        take (1 + sz)
+        [ (1, pure ObviouslyEmptyLevelMerge)
+        , (1, pure ObviouslyEmptyUnionMerge)
+        , (2, NonObviouslyEmptyLevelMerge <$> resize (sz `div` 2) arbitrary)
+        , (2, NonObviouslyEmptyUnionMerge <$> resize (sz `div` 2) arbitrary)
+        ]
+    shrink ObviouslyEmptyLevelMerge         = []
+    shrink ObviouslyEmptyUnionMerge         = [ObviouslyEmptyLevelMerge]
+    shrink (NonObviouslyEmptyLevelMerge mt) = ObviouslyEmptyLevelMerge
+                                            : [ NonObviouslyEmptyLevelMerge mt'
+                                              | mt' <- shrink mt ]
+    shrink (NonObviouslyEmptyUnionMerge mt) = ObviouslyEmptyUnionMerge
+                                            : [ NonObviouslyEmptyUnionMerge mt'
+                                              | mt' <- shrink mt ]
+
+mkEmptyMergingTree :: EmptyMergingTree -> IO (Ref (MergingTree IO h))
+mkEmptyMergingTree ObviouslyEmptyLevelMerge = newPendingLevelMerge [] Nothing
+mkEmptyMergingTree ObviouslyEmptyUnionMerge = newPendingUnionMerge []
+mkEmptyMergingTree (NonObviouslyEmptyLevelMerge emt) = do
+    mt  <- mkEmptyMergingTree emt
+    mt' <- newPendingLevelMerge [] (Just mt)
+    releaseRef mt
+    return mt'
+mkEmptyMergingTree (NonObviouslyEmptyUnionMerge emts) = do
+    mts <- mapM mkEmptyMergingTree emts
+    mt' <- newPendingUnionMerge mts
+    mapM_ releaseRef mts
+    return mt'
+