SUGGESTION: test that conversion to/from unsliced keys preserves Eq/Ord

Author: jorisdral

lsm-tree.cabal

@@ -390,6 +390,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Snapshot.Codec
     Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
     Test.Database.LSMTree.Internal.Snapshot.FS
+    Test.Database.LSMTree.Internal.Unsliced
     Test.Database.LSMTree.Internal.Vector
     Test.Database.LSMTree.Internal.Vector.Growing
     Test.Database.LSMTree.Internal.WriteBufferBlobs.FS

test/Main.hs

@@ -35,6 +35,7 @@ import qualified Test.Database.LSMTree.Internal.Serialise.Class
 import qualified Test.Database.LSMTree.Internal.Snapshot.Codec
 import qualified Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
 import qualified Test.Database.LSMTree.Internal.Snapshot.FS
+import qualified Test.Database.LSMTree.Internal.Unsliced
 import qualified Test.Database.LSMTree.Internal.Vector
 import qualified Test.Database.LSMTree.Internal.Vector.Growing
 import qualified Test.Database.LSMTree.Internal.WriteBufferBlobs.FS
@@ -82,6 +83,7 @@ main = do
     , Test.Database.LSMTree.Internal.Snapshot.Codec.tests
     , Test.Database.LSMTree.Internal.Snapshot.Codec.Golden.tests
     , Test.Database.LSMTree.Internal.Snapshot.FS.tests
+    , Test.Database.LSMTree.Internal.Unsliced.tests
     , Test.Database.LSMTree.Internal.Vector.tests
     , Test.Database.LSMTree.Internal.Vector.Growing.tests
     , Test.Database.LSMTree.Internal.WriteBufferBlobs.FS.tests

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

@@ -0,0 +1,51 @@
+module Test.Database.LSMTree.Internal.Unsliced (tests) where
+
+import           Database.LSMTree.Extras.Generators ()
+import           Database.LSMTree.Internal.Serialise
+import           Database.LSMTree.Internal.Unsliced
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests = testGroup "Test.Database.LSMTree.Internal.Unsliced" [
+      testProperty "prop_makeUnslicedKeyPreservesEq" prop_makeUnslicedKeyPreservesEq
+    , testProperty "prop_fromUnslicedKeyPreservesEq" prop_fromUnslicedKeyPreservesEq
+    , testProperty "prop_makeUnslicedKeyPreservesOrd" prop_makeUnslicedKeyPreservesOrd
+    , testProperty "prop_fromUnslicedKeyPreservesOrd" prop_fromUnslicedKeyPreservesOrd
+    ]
+
+-- 'Eq' on serialised keys is preserved when converting to /unsliced/ serialised
+-- keys.
+prop_makeUnslicedKeyPreservesEq :: SerialisedKey -> SerialisedKey -> Property
+prop_makeUnslicedKeyPreservesEq k1 k2 = checkCoverage $
+    cover 1 lhs "k1 == k2" $ lhs === rhs
+  where
+    lhs = k1 == k2
+    rhs = makeUnslicedKey k1 == makeUnslicedKey k2
+
+-- 'Eq' on /unsliced/ serialised keys is preserved when converting to serialised
+-- keys.
+prop_fromUnslicedKeyPreservesEq :: Unsliced SerialisedKey -> Unsliced SerialisedKey -> Property
+prop_fromUnslicedKeyPreservesEq k1 k2 = checkCoverage $
+    cover 1 lhs "k1 == k2" $ lhs === rhs
+  where
+    lhs = k1 == k2
+    rhs = fromUnslicedKey k1 == fromUnslicedKey k2
+
+-- 'Ord' on serialised keys is preserved when converting to /unsliced/
+-- serialised keys.
+prop_makeUnslicedKeyPreservesOrd :: SerialisedKey -> SerialisedKey -> Property
+prop_makeUnslicedKeyPreservesOrd k1 k2 = checkCoverage $
+     cover 50 lhs "k1 <= k2" $ lhs === rhs
+  where
+    lhs = k1 <= k2
+    rhs = makeUnslicedKey k1 <= makeUnslicedKey k2
+
+-- 'Ord' on /unsliced/ serialised keys is preserved when converting to serialised
+-- keys.
+prop_fromUnslicedKeyPreservesOrd :: Unsliced SerialisedKey -> Unsliced SerialisedKey -> Property
+prop_fromUnslicedKeyPreservesOrd k1 k2 = checkCoverage $
+    cover 50 lhs "k1 <= k2" $ lhs === rhs
+  where
+    lhs = k1 <= k2
+    rhs = fromUnslicedKey k1 <= fromUnslicedKey k2