diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 7568def17..ba7ff3c4f 100644 --- a/lsm-tree.cabal +++ b/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 diff --git a/src/Database/LSMTree/Internal/Unsliced.hs b/src/Database/LSMTree/Internal/Unsliced.hs index d9a0c4314..496cd45fb 100644 --- a/src/Database/LSMTree/Internal/Unsliced.hs +++ b/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 diff --git a/test/Main.hs b/test/Main.hs index 6d89a8518..6a878e9c5 100644 --- a/test/Main.hs +++ b/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 diff --git a/test/Test/Database/LSMTree/Internal/Unsliced.hs b/test/Test/Database/LSMTree/Internal/Unsliced.hs new file mode 100644 index 000000000..bbdb2b2b1 --- /dev/null +++ b/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