Merge pull request #658 from IntersectMBO/jeltsch/efficient-unsliced-comparison

Make comparison of `Unsliced` values more efficient

Author: jorisdral

lsm-tree.cabal

@@ -393,6 +393,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

src/Database/LSMTree/Internal/Unsliced.hs

@@ -16,6 +16,7 @@ module Database.LSMTree.Internal.Unsliced (
 
 import           Control.DeepSeq (NFData)
 import           Control.Exception (assert)
+import           Data.ByteString.Short (ShortByteString (SBS))
 import           Data.Primitive.ByteArray
 import qualified Data.Vector.Primitive as VP
 import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
@@ -69,7 +70,13 @@ instance Show (Unsliced SerialisedKey) where
   show x = show (fromUnslicedKey x)
 
 instance Eq (Unsliced SerialisedKey) where
-  x == y = fromUnslicedKey x == fromUnslicedKey y
+  Unsliced ba1 == Unsliced ba2 = SBS ba1' == SBS ba2'
+    where
+      !(ByteArray ba1') = ba1
+      !(ByteArray ba2') = ba2
 
 instance Ord (Unsliced SerialisedKey) where
-  x <= y = fromUnslicedKey x <= fromUnslicedKey y
+  compare (Unsliced ba1) (Unsliced ba2) = compare (SBS ba1') (SBS ba2')
+    where
+      !(ByteArray ba1') = ba1
+      !(ByteArray ba2') = ba2

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