lsm-tree 1.1.0.0 → 1.1.1.0
raw patch · 33 files changed
+328/−192 lines, 33 filesdep ~data-elevatordep ~randomPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: data-elevator, random
API changes (from Hackage documentation)
Files
- CHANGELOG.md +25/−0
- bench-unions/Bench/Unions.hs +6/−6
- bench/macro/lsm-tree-bench-bloomfilter.hs +5/−3
- bench/macro/lsm-tree-bench-lookups.hs +6/−5
- bench/macro/utxo-bench.hs +5/−4
- bench/micro/Bench/Database/LSMTree.hs +5/−4
- bench/micro/Bench/Database/LSMTree/Internal/BloomFilter.hs +2/−2
- bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs +11/−11
- bench/micro/Bench/Database/LSMTree/Internal/Merge.hs +9/−10
- bench/micro/Bench/Database/LSMTree/Internal/Serialise.hs +2/−1
- bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs +9/−8
- lsm-tree.cabal +9/−4
- src-core/Database/LSMTree/Internal/Arena.hs +0/−1
- src-core/Database/LSMTree/Internal/MergeSchedule.hs +3/−3
- src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs +9/−7
- src-core/Database/LSMTree/Internal/Run.hs +55/−36
- src-core/Database/LSMTree/Internal/RunReader.hs +50/−46
- src-core/Database/LSMTree/Internal/Unsafe.hs +6/−6
- src-core/Database/LSMTree/Internal/Vector.hs +8/−0
- src-extras/Database/LSMTree/Extras/Random.hs +41/−5
- test/Database/LSMTree/Model/Session.hs +1/−1
- test/Test/Database/LSMTree/Internal.hs +2/−1
- test/Test/Database/LSMTree/Internal/BloomFilter.hs +3/−2
- test/Test/Database/LSMTree/Internal/Index/Compact.hs +3/−2
- test/Test/Database/LSMTree/Internal/Lookup.hs +3/−3
- test/Test/Database/LSMTree/Internal/Merge.hs +5/−10
- test/Test/Database/LSMTree/Internal/MergingTree.hs +3/−3
- test/Test/Database/LSMTree/Internal/RawBytes.hs +3/−2
- test/Test/Database/LSMTree/Internal/Run.hs +2/−2
- test/Test/Database/LSMTree/Internal/RunBloomFilterAlloc.hs +1/−1
- test/Test/Database/LSMTree/Internal/RunReader.hs +1/−1
- test/Test/Database/LSMTree/Resolve.hs +3/−2
- test/Test/Util/QC/Compat.hs +32/−0
CHANGELOG.md view
@@ -1,5 +1,30 @@ # Revision history for `lsm-tree` +## 1.1.1.0 -- 2026-07-21++### Breaking changes++None++### New features++None++### Minor changes++* Support `data-elevator-0.3`. See [issue+ #856](https://github.com/IntersectMBO/lsm-tree/issues/856) and [PR+ #857](https://github.com/IntersectMBO/lsm-tree/pull/857).+* Support `ghc-9.14`. See [issue+ #813](https://github.com/IntersectMBO/lsm-tree/issues/813) and [PR+ #859](https://github.com/IntersectMBO/lsm-tree/pull/859).+* Drop support for `random < 1.2`. See [PR+ #865](https://github.com/IntersectMBO/lsm-tree/pull/865).++### Bug fixes++None+ ## 1.1.0.0 -- 2026-05-13 ### Breaking changes
bench-unions/Bench/Unions.hs view
@@ -159,13 +159,13 @@ case P.runPrimArray $ do v <- P.newPrimArray 5 let g0 = Random.mkStdGen (fromIntegral seed)- let (!w0, !g1) = Random.uniform g0+ let (!w0, !g1) = Random.uniform_compat g0 P.writePrimArray v 0 w0- let (!w1, !g2) = Random.uniform g1+ let (!w1, !g2) = Random.uniform_compat g1 P.writePrimArray v 1 w1- let (!w2, !g3) = Random.uniform g2+ let (!w2, !g3) = Random.uniform_compat g2 P.writePrimArray v 2 w2- let (!w3, _g4) = Random.uniform g3+ let (!w3, _g4) = Random.uniform_compat g3 P.writePrimArray v 3 w3 P.writePrimArray v 4 0x3d3d3d3d3d3d3d3d -- ======== case v of@@ -461,7 +461,7 @@ deriveSetupRNGs gOpts amount = let -- g1 is reserved for the run command (_g1, !g2) = deriveInitialForkedRNGs gOpts- in NE.fromList $ take amount $ List.unfoldr (Just . Random.splitGen) g2+ in NE.fromList $ take amount $ List.unfoldr (Just . Random.splitGen_compat) g2 deriveRunRNG :: GlobalOpts -> Random.StdGen deriveRunRNG gOpts =@@ -470,7 +470,7 @@ in g1 deriveInitialForkedRNGs :: GlobalOpts -> (Random.StdGen, Random.StdGen)-deriveInitialForkedRNGs = Random.splitGen . Random.mkStdGen . seed+deriveInitialForkedRNGs = Random.splitGen_compat . Random.mkStdGen . seed ------------------------------------------------------------------------------- -- Batch generation
bench/macro/lsm-tree-bench-bloomfilter.hs view
@@ -24,6 +24,8 @@ import Text.Printf (printf) import Database.LSMTree.Extras.Orphans ()+import Database.LSMTree.Extras.Random (splitGen_compat,+ uniform_compat) import Database.LSMTree.Internal.Assertions (fromIntegralChecked) import qualified Database.LSMTree.Internal.BloomFilter as Bloom import Database.LSMTree.Internal.Serialise (SerialisedKey,@@ -236,7 +238,7 @@ when (i .&. 0xFFFF == 0) (unsafeIOToST $ putStr ".") -- insert n elements into filter b let k :: Word256- (!k, !rng') = uniform rng+ (!k, !rng') = uniform_compat rng Bloom.insert mb (serialiseKey k) pure rng' )@@ -257,9 +259,9 @@ go !rng !n | n <= 0 = () | otherwise =- let (!rng'', !rng') = splitGen rng+ let (!rng'', !rng') = splitGen_compat rng ks :: VP.Vector Word256- !ks = VP.unfoldrExactN b uniform rng'+ !ks = VP.unfoldrExactN b uniform_compat rng' ks' :: V.Vector SerialisedKey !ks' = V.map serialiseKey (V.convert ks) in action ks' `seq` go rng'' (n-b)
bench/macro/lsm-tree-bench-lookups.hs view
@@ -20,6 +20,7 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Unboxed.Mutable as VUM import Database.LSMTree.Extras.Orphans ()+import Database.LSMTree.Extras.Random (uniform_compat) import Database.LSMTree.Extras.UTxO import Database.LSMTree.Internal.Arena (ArenaManager, newArenaManager, withArena)@@ -384,9 +385,9 @@ -- return runs runs <- V.fromList <$> mapM (Run.fromBuilder refCtx) rbs- let blooms = V.map (\(DeRef r) -> Run.runFilter r) runs- indexes = V.map (\(DeRef r) -> Run.runIndex r) runs- handles = V.map (\(DeRef r) -> Run.runKOpsFile r) runs+ let blooms = V.map (\(DeRef r) -> r.bloomFilter) runs+ indexes = V.map (\(DeRef r) -> r.index ) runs+ handles = V.map (\(DeRef r) -> r.kOpsFile ) runs pure $!! (runs, blooms, indexes, handles) genLookupBatch :: StdGen -> Int -> (V.Vector SerialisedKey, StdGen)@@ -404,7 +405,7 @@ !res <- V.unsafeFreeze mres pure (res, rng) | otherwise = do- let (!k, !rng') = uniform @UTxOKey @StdGen rng+ let (!k, !rng') = uniform_compat @UTxOKey @StdGen rng !sk = serialiseKey k VM.write mres i $! sk go rng' (i+1) mres@@ -548,7 +549,7 @@ | i == n-1 = pure g | otherwise = do when (i .&. 0xFFFF == 0) (unsafeIOToPrim $ putStr ".")- let (!x, !g') = uniform g+ let (!x, !g') = uniform_compat g VGM.unsafeWrite vec i x loop (i+1) g'
bench/macro/utxo-bench.hs view
@@ -79,6 +79,7 @@ -- We should be able to write this benchmark -- using only use public lsm-tree interface import qualified Database.LSMTree as LSM+import qualified Database.LSMTree.Extras.Random as Random ------------------------------------------------------------------------------- -- Table configuration@@ -114,13 +115,13 @@ case P.runPrimArray $ do v <- P.newPrimArray 5 let g0 = Random.mkStdGen (fromIntegral seed)- let (!w0, !g1) = Random.uniform g0+ let (!w0, !g1) = Random.uniform_compat g0 P.writePrimArray v 0 w0- let (!w1, !g2) = Random.uniform g1+ let (!w1, !g2) = Random.uniform_compat g1 P.writePrimArray v 1 w1- let (!w2, !g3) = Random.uniform g2+ let (!w2, !g3) = Random.uniform_compat g2 P.writePrimArray v 2 w2- let (!w3, _g4) = Random.uniform g3+ let (!w3, _g4) = Random.uniform_compat g3 P.writePrimArray v 3 w3 P.writePrimArray v 4 0x3d3d3d3d3d3d3d3d -- ======== case v of
bench/micro/Bench/Database/LSMTree.hs view
@@ -17,6 +17,7 @@ import Database.LSMTree hiding (withTable) import Database.LSMTree.Extras import Database.LSMTree.Extras.Orphans ()+import Database.LSMTree.Extras.Random (uniform_compat) import Database.LSMTree.Internal.Assertions (fromIntegralChecked) import qualified Database.LSMTree.Internal.RawBytes as RB import GHC.Generics (Generic)@@ -116,7 +117,7 @@ customRandomEntries :: Int -> V.Vector (K, Word64, ShortByteString) customRandomEntries n = V.unfoldrExactN n f (mkStdGen 17)- where f !g = let (!k, !g') = uniform g+ where f !g = let (!k, !g') = uniform_compat g in ((k, v, b), g') -- The exact value does not matter much, so we pick an arbitrary -- hardcoded one.@@ -207,7 +208,7 @@ customRandomEntries :: Int -> V.Vector (K, V2, Maybe B2) customRandomEntries n = V.unfoldrExactN n f (mkStdGen 17)- where f !g = let (!k, !g') = uniform g+ where f !g = let (!k, !g') = uniform_compat g in ((k, v, Nothing), g') -- The exact value does not matter much, so we pick an arbitrary -- hardcoded one.@@ -257,7 +258,7 @@ randomInserts :: Int -> V.Vector (K, V2, Maybe Void) randomInserts n = V.unfoldrExactN n f (mkStdGen 17)- where f !g = let (!k, !g') = uniform g+ where f !g = let (!k, !g') = uniform_compat g in ((k, v, Nothing), g') -- The exact value does not matter much, so we pick an arbitrary -- hardcoded one.@@ -414,7 +415,7 @@ -- | Random keys, default values @1@ randomEntries :: Int -> V.Vector (K, V3) randomEntries n = V.unfoldrExactN n f (mkStdGen 17)- where f !g = let (!k, !g') = uniform g+ where f !g = let (!k, !g') = uniform_compat g in ((k, 1), g') -- | Like 'randomEntries', but also returns groups of size 'm'
bench/micro/Bench/Database/LSMTree/Internal/BloomFilter.hs view
@@ -57,8 +57,8 @@ -> IO (Bloom SerialisedKey, [SerialisedKey]) elemEnv fpr nbloom nelemsPositive nelemsNegative = do let g = mkStdGen 100- (g1, g') = R.splitGen g- (g2, g3) = R.splitGen g'+ (g1, g') = splitGen_compat g+ (g2, g3) = splitGen_compat g' let (xs, ys1) = splitAt nbloom $ uniformWithoutReplacement @UTxOKey g1 (nbloom + nelemsNegative)
bench/micro/Bench/Database/LSMTree/Internal/Lookup.hs view
@@ -16,8 +16,8 @@ import qualified Data.Vector as V import Database.LSMTree.Extras.Orphans () import Database.LSMTree.Extras.Random (frequency, randomByteStringR,- sampleUniformWithReplacement, shuffle,- uniformWithoutReplacement)+ sampleUniformWithReplacement, shuffle, splitGen_compat,+ uniformWithoutReplacement, uniform_compat) import Database.LSMTree.Extras.UTxO import Database.LSMTree.Internal.Arena (ArenaManager, closeArena, newArena, newArenaManager, withArena)@@ -91,9 +91,9 @@ benchLookups :: Config -> Benchmark benchLookups conf@Config{name} = withEnv $ \ ~(_dir, arenaManager, _hasFS, hasBlockIO, _refCtx, wbblobs, rs, ks) ->- env ( pure ( V.map (\(DeRef r) -> Run.runFilter r) rs- , V.map (\(DeRef r) -> Run.runIndex r) rs- , V.map (\(DeRef r) -> Run.runKOpsFile r) rs+ env ( pure ( V.map (\(DeRef r) -> r.bloomFilter) rs+ , V.map (\(DeRef r) -> r.index ) rs+ , V.map (\(DeRef r) -> r.kOpsFile ) rs ) ) $ \ ~(blooms, indexes, kopsFiles) -> bgroup name [@@ -248,9 +248,9 @@ , V.Vector SerialisedKey ) lookupsEnv g nentries npos nneg = do- let (g1, g') = R.splitGen g- (g2, g'') = R.splitGen g'- (g3, g4) = R.splitGen g''+ let (g1, g') = splitGen_compat g+ (g2, g'') = splitGen_compat g'+ (g3, g4) = splitGen_compat g'' let (keys, negLookups) = splitAt nentries $ uniformWithoutReplacement @UTxOKey g1 (nentries + nneg) posLookups = sampleUniformWithReplacement g2 npos keys@@ -267,14 +267,14 @@ randomEntry :: StdGen -> (Entry UTxOValue ByteString, StdGen) randomEntry g = frequency [- (20, \g' -> let (!v, !g'') = uniform g' in (Insert v, g''))- , (1, \g' -> let (!v, !g'') = uniform g'+ (20, \g' -> let (!v, !g'') = uniform_compat g' in (Insert v, g''))+ , (1, \g' -> let (!v, !g'') = uniform_compat g' -- The size of the blobs doesn't matter for the benchmark, -- as it only deals with the blob references. So we make -- them tiny to not slow down the setup. (!b, !g''') = randomByteStringR (0, 100) g'' in (InsertWithBlob v b, g'''))- , (2, \g' -> let (!v, !g'') = uniform g' in (Upsert v, g''))+ , (2, \g' -> let (!v, !g'') = uniform_compat g' in (Upsert v, g'')) , (2, \g' -> (Delete, g')) ] g
bench/micro/Bench/Database/LSMTree/Internal/Merge.hs view
@@ -36,8 +36,7 @@ import qualified System.FS.BlockIO.IO as FS import qualified System.FS.IO as FS import System.IO.Temp-import qualified System.Random as R-import System.Random (StdGen, mkStdGen, uniform, uniformR)+import System.Random (StdGen, mkStdGen, uniformR) benchmarks :: Benchmark benchmarks = bgroup "Bench.Database.LSMTree.Internal.Merge" [@@ -345,22 +344,22 @@ configWord64 :: Config configWord64 = defaultConfig {- randomKey = first serialiseKey . uniform @Word64 @_- , randomValue = first serialiseValue . uniform @Word64 @_+ randomKey = first serialiseKey . R.uniform_compat @Word64 @_+ , randomValue = first serialiseValue . R.uniform_compat @Word64 @_ , randomBlob = first serialiseBlob . R.randomByteStringR (0, 0x2000) -- up to 8 kB } configUTxO :: Config configUTxO = defaultConfig {- randomKey = first serialiseKey . uniform @UTxOKey @_- , randomValue = first serialiseValue . uniform @UTxOValue @_+ randomKey = first serialiseKey . R.uniform_compat @UTxOKey @_+ , randomValue = first serialiseValue . R.uniform_compat @UTxOValue @_ } configUTxOStaking :: Config configUTxOStaking = defaultConfig { fmupserts = 1- , randomKey = first serialiseKey . uniform @UTxOKey @_- , randomValue = first serialiseValue . uniform @Word64 @_+ , randomKey = first serialiseKey . R.uniform_compat @UTxOKey @_+ , randomValue = first serialiseValue . R.uniform_compat @Word64 @_ , mergeResolve = Just (onDeserialisedValues ((+) @Word64)) } @@ -410,7 +409,7 @@ zipWith (randomRunData config) nentries- (List.unfoldr (Just . R.splitGen) rng0)+ (List.unfoldr (Just . R.splitGen_compat) rng0) -- | Generate keys and entries to insert into the write buffer. -- They are already serialised to exclude the cost from the benchmark.@@ -425,7 +424,7 @@ (R.withoutReplacement g1 runentries randomKey) (R.withReplacement g2 runentries randomEntry) where- (g1, g2) = R.splitGen g0+ (g1, g2) = R.splitGen_compat g0 randomEntry :: Rnd (Entry SerialisedValue SerialisedBlob) randomEntry = R.frequency
bench/micro/Bench/Database/LSMTree/Internal/Serialise.hs view
@@ -3,13 +3,14 @@ ) where import Criterion.Main+import Database.LSMTree.Extras.Random (uniform_compat) import Database.LSMTree.Extras.UTxO import Database.LSMTree.Internal.Serialise.Class import System.Random benchmarks :: Benchmark benchmarks = bgroup "Bench.Database.LSMTree.Internal.Serialise" [- env (pure $ fst $ uniform (mkStdGen 12)) $ \(k :: UTxOKey) ->+ env (pure $ fst $ uniform_compat (mkStdGen 12)) $ \(k :: UTxOKey) -> bgroup "UTxOKey" [ bench "serialiseKey" $ whnf serialiseKey k , bench "serialiseKeyRoundtrip" $ whnf serialiseKeyRoundtrip k
bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs view
@@ -10,14 +10,15 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Word (Word64) import Database.LSMTree.Extras.Orphans ()-import Database.LSMTree.Extras.Random (frequency, randomByteStringR)+import Database.LSMTree.Extras.Random (frequency, randomByteStringR,+ uniform_compat) import Database.LSMTree.Extras.UTxO import Database.LSMTree.Internal.BlobRef (BlobSpan (..)) import Database.LSMTree.Internal.Entry import Database.LSMTree.Internal.Serialise import Database.LSMTree.Internal.WriteBuffer (WriteBuffer) import qualified Database.LSMTree.Internal.WriteBuffer as WB-import System.Random (StdGen, mkStdGen, uniform)+import System.Random (StdGen, mkStdGen) benchmarks :: Benchmark benchmarks = bgroup "Bench.Database.LSMTree.Internal.WriteBuffer" [@@ -168,14 +169,14 @@ configWord64 :: Config configWord64 = defaultConfig {- randomKey = first serialiseKey . uniform @Word64 @_- , randomValue = first serialiseValue . uniform @Word64 @_+ randomKey = first serialiseKey . uniform_compat @Word64 @_+ , randomValue = first serialiseValue . uniform_compat @Word64 @_ } configUTxO :: Config configUTxO = defaultConfig {- randomKey = first serialiseKey . uniform @UTxOKey @_- , randomValue = first serialiseValue . uniform @UTxOValue @_+ randomKey = first serialiseKey . uniform_compat @UTxOKey @_+ , randomValue = first serialiseValue . uniform_compat @UTxOValue @_ } envInputKOps :: Config -> InputKOps@@ -219,6 +220,6 @@ randomBlobSpan :: Rnd BlobSpan randomBlobSpan !g =- let (off, !g') = uniform g- (len, !g'') = uniform g'+ let (off, !g') = uniform_compat g+ (len, !g'') = uniform_compat g' in (BlobSpan off len, g'')
lsm-tree.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: lsm-tree-version: 1.1.0.0+version: 1.1.1.0 synopsis: Log-structured merge-trees description: This package contains an efficient implementation of on-disk key–value storage, implemented as a log-structured merge-tree, LSM-tree or LSMT.@@ -502,7 +502,7 @@ type: git location: https://github.com/IntersectMBO/lsm-tree subdir: lsm-tree- tag: lsm-tree-1.1.0.0+ tag: lsm-tree-1.1.1.0 common warnings ghc-options:@@ -513,6 +513,10 @@ ghc-options: -Werror=missing-deriving-strategies + -- In ghc-9.14 the `pattern` namespace specifier is deprecated.+ if impl(ghc >=9.14)+ ghc-options: -Wno-pattern-namespace-specifier+ common wno-x-partial if impl(ghc >=9.8) -- No errors for x-partial functions. We might remove this in the future if@@ -551,7 +555,7 @@ , lsm-tree:control , lsm-tree:core , primitive ^>=0.9- , random ^>=1.0 || ^>=1.1 || ^>=1.2 || ^>=1.3+ , random ^>=1.2 || ^>=1.3 , text ^>=2.1.1 , vector ^>=0.13 @@ -644,7 +648,7 @@ if impl(ghc >=9.4) other-modules: Database.LSMTree.Internal.StrictArray- build-depends: data-elevator ^>=0.1.0.2 || ^>=0.2+ build-depends: data-elevator ^>=0.1.0.2 || ^>=0.2 || ^>=0.3 cpp-options: -DHAVE_STRICT_ARRAY library extras@@ -755,6 +759,7 @@ Test.Util.Orphans Test.Util.PrettyProxy Test.Util.QC+ Test.Util.QC.Compat Test.Util.QLS Test.Util.RawPage Test.Util.TypeFamilyWrappers
src-core/Database/LSMTree/Internal/Arena.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoFieldSelectors #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_HADDOCK not-home #-} module Database.LSMTree.Internal.Arena ( ArenaManager,
src-core/Database/LSMTree/Internal/MergeSchedule.hs view
@@ -220,9 +220,9 @@ lvls pure $! LevelsCache_ { cachedRuns = rs- , cachedFilters = mapStrict (\(DeRef r) -> Run.runFilter r) rs- , cachedIndexes = mapStrict (\(DeRef r) -> Run.runIndex r) rs- , cachedKOpsFiles = mapStrict (\(DeRef r) -> Run.runKOpsFile r) rs+ , cachedFilters = mapStrict (\(DeRef r) -> r.bloomFilter) rs+ , cachedIndexes = mapStrict (\(DeRef r) -> r.index ) rs+ , cachedKOpsFiles = mapStrict (\(DeRef r) -> r.kOpsFile ) rs } where dupRun r = withRollback reg (dupRef r) releaseRef
src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs view
@@ -109,15 +109,17 @@ -- dropped before we duplicated the reference. withMVar (MT.mergeState mt) $ \case MT.CompletedTreeMerge r ->- LookupBatch . V.singleton <$!> dupRun r+ LookupBatch <$!> (dupRun r >>= V.singletonMStrict) MT.OngoingTreeMerge mr -> do !rs <- withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef) ty <- MR.mergeType mr- pure $ case ty of- Nothing -> LookupBatch rs -- just one run- Just MR.MergeLevel -> LookupBatch rs -- combine runs- Just MR.MergeUnion -> mkLookupNode MR.MergeUnion -- separate- (LookupBatch . V.singleton <$!> rs)+ case ty of+ Nothing -> pure $ LookupBatch rs -- just one run+ Just MR.MergeLevel -> pure $ LookupBatch rs -- combine runs+ Just MR.MergeUnion -> do+ !rs' <- mapM V.singletonMStrict rs+ pure $ mkLookupNode MR.MergeUnion -- separate+ (LookupBatch <$!> rs') MT.PendingTreeMerge (MT.PendingLevelMerge prs Nothing) -> do LookupBatch . V.concatMap id <$!> -- combine runs V.mapMStrict duplicatePreExistingRun prs@@ -136,6 +138,6 @@ dupRun r = withRollback reg (dupRef r) releaseRef duplicatePreExistingRun (MT.PreExistingRun r) =- V.singleton <$!> dupRun r+ dupRun r >>= V.singletonMStrict duplicatePreExistingRun (MT.PreExistingMergingRun mr) = withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
src-core/Database/LSMTree/Internal/Run.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+ {-# OPTIONS_HADDOCK not-home #-} -- | Runs of sorted key\/value data. module Database.LSMTree.Internal.Run ( -- * Run- Run (Run, runIndex, runHasFS, runHasBlockIO, runRunDataCaching,- runBlobFile, runFilter, runKOpsFile)+ Run (Run, index, hasFS, hasBlockIO, dataCaching,+ blobFile, bloomFilter, kOpsFile) , RunFsPaths , size , sizeInPages@@ -68,75 +70,74 @@ -- | The in-memory representation of a completed LSM run. -- data Run m h = Run {- runNumEntries :: !NumEntries+ numEntries :: !NumEntries -- | The reference count for the LSM run. This counts the -- number of references from LSM handles to this run. When -- this drops to zero the open files will be closed.- , runRefCounter :: !(RefCounter m)+ , refCounter :: !(RefCounter m) -- | The file system paths for all the files used by the run.- , runRunFsPaths :: !RunFsPaths+ , fsPaths :: !RunFsPaths -- | The bloom filter for the set of keys in this run.- , runFilter :: !(Bloom SerialisedKey)+ , bloomFilter :: !(Bloom SerialisedKey) -- | The in-memory index mapping keys to page numbers in the -- Key\/Ops file. In future we may support alternative index -- representations.- , runIndex :: !Index+ , index :: !Index -- | The file handle for the Key\/Ops file. This file is opened -- read-only and is accessed in a page-oriented way, i.e. only -- reading whole pages, at page offsets. It will be opened with -- 'O_DIRECT' on supported platforms.- , runKOpsFile :: !(FS.Handle h)+ , kOpsFile :: !(FS.Handle h) -- | The file handle for the BLOBs file. This file is opened -- read-only and is accessed in a normal style using buffered -- I\/O, reading arbitrary file offset and length spans.- , runBlobFile :: !(Ref (BlobFile m h))- , runRunDataCaching :: !RunDataCaching- , runHasFS :: !(HasFS m h)- , runHasBlockIO :: !(HasBlockIO m h)+ , blobFile :: !(Ref (BlobFile m h))+ , dataCaching :: !RunDataCaching+ , hasFS :: !(HasFS m h)+ , hasBlockIO :: !(HasBlockIO m h) } -- | Shows only the 'runRunFsPaths' field. instance Show (Run m h) where- showsPrec _ run = showString "Run { runRunFsPaths = " . showsPrec 0 (runRunFsPaths run) . showString " }"+ showsPrec _ run = showString "Run { fsPaths = " . showsPrec 0 run.fsPaths . showString " }" instance NFData h => NFData (Run m h) where- rnf (Run a b c d e f g h i j) =- rnf a `seq` rwhnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq`- rnf f `seq` rnf g `seq` rnf h `seq` rwhnf i `seq` rwhnf j+ rnf (Run numEntries refCounter fsPaths bloomFilter index kOpsFile blobFile dataCaching hasFS hasBlockIO) =+ rnf numEntries `seq` rwhnf refCounter `seq` rnf fsPaths `seq`+ rnf bloomFilter `seq` rnf index `seq` rnf kOpsFile `seq`+ rnf blobFile `seq` rnf dataCaching `seq` rwhnf hasFS `seq` rwhnf hasBlockIO instance RefCounted m (Run m h) where- getRefCounter = runRefCounter+ getRefCounter r = r.refCounter size :: Ref (Run m h) -> NumEntries-size (DeRef run) = runNumEntries run+size (DeRef run) = run.numEntries sizeInPages :: Ref (Run m h) -> NumPages-sizeInPages (DeRef run) = Index.sizeInPages (runIndex run)+sizeInPages (DeRef run) = Index.sizeInPages run.index runFsPaths :: Ref (Run m h) -> RunFsPaths-runFsPaths (DeRef r) = runRunFsPaths r+runFsPaths (DeRef r) = r.fsPaths runFsPathsNumber :: Ref (Run m h) -> RunNumber runFsPathsNumber = Paths.runNumber . runFsPaths -- | See 'openFromDisk' runIndexType :: Ref (Run m h) -> IndexType-runIndexType (DeRef r) = Index.indexToIndexType (runIndex r)+runIndexType (DeRef r) = Index.indexToIndexType r.index -- | See 'openFromDisk' runDataCaching :: Ref (Run m h) -> RunDataCaching-runDataCaching (DeRef r) = runRunDataCaching r+runDataCaching (DeRef r) = r.dataCaching -- | Helper function to make a 'WeakBlobRef' that points into a 'Run'. mkRawBlobRef :: Run m h -> BlobSpan -> RawBlobRef m h-mkRawBlobRef Run{runBlobFile} blobspan =- BlobRef.mkRawBlobRef runBlobFile blobspan+mkRawBlobRef run = BlobRef.mkRawBlobRef run.blobFile -- | Helper function to make a 'WeakBlobRef' that points into a 'Run'. mkWeakBlobRef :: Ref (Run m h) -> BlobSpan -> WeakBlobRef m h-mkWeakBlobRef (DeRef Run{runBlobFile}) blobspan =- BlobRef.mkWeakBlobRef runBlobFile blobspan+mkWeakBlobRef (DeRef run) blobspan = BlobRef.mkWeakBlobRef run.blobFile blobspan {-# SPECIALISE finaliser :: HasFS IO h@@ -227,7 +228,18 @@ setRunDataCaching runHasBlockIO runKOpsFile runRunDataCaching newRef refCtx (finaliser runHasFS runKOpsFile runBlobFile runRunFsPaths)- (\runRefCounter -> Run { .. })+ (\refCounter -> Run {+ numEntries = runNumEntries+ , refCounter = refCounter+ , fsPaths = runRunFsPaths+ , bloomFilter = runFilter+ , index = runIndex+ , kOpsFile = runKOpsFile+ , blobFile = runBlobFile+ , dataCaching = runRunDataCaching+ , hasFS = runHasFS+ , hasBlockIO = runHasBlockIO+ }) {-# SPECIALISE fromWriteBuffer :: HasFS IO h@@ -336,10 +348,17 @@ setRunDataCaching hbio runKOpsFile runRunDataCaching newRef refCtx (finaliser fs runKOpsFile runBlobFile runRunFsPaths) $ \runRefCounter -> Run {- runHasFS = fs- , runHasBlockIO = hbio- , ..- }+ numEntries = runNumEntries+ , refCounter = runRefCounter+ , fsPaths = runRunFsPaths+ , bloomFilter = runFilter+ , index = runIndex+ , kOpsFile = runKOpsFile+ , blobFile = runBlobFile+ , dataCaching = runRunDataCaching+ , hasFS = fs+ , hasBlockIO = hbio+ } where -- Note: all file data for this path is evicted from the page cache /if/ the -- caching argument is 'NoCacheRunData'.
src-core/Database/LSMTree/Internal/RunReader.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+ {-# OPTIONS_HADDOCK not-home #-} -- | A run that is being read incrementally.@@ -74,19 +77,19 @@ data RunReader m h = RunReader { -- | The disk page currently being read. If it is 'Nothing', the reader -- is considered closed.- readerCurrentPage :: !(MutVar (PrimState m) (Maybe RawPage))+ currentPage :: !(MutVar (PrimState m) (Maybe RawPage)) -- | The index of the entry to be returned by the next call to 'next'.- , readerCurrentEntryNo :: !(PrimVar (PrimState m) Word16)+ , currentEntryNo :: !(PrimVar (PrimState m) Word16) -- | Read mode file handle into the run's k\/ops file. We rely on it to -- track the position of the next disk page to read, instead of keeping -- a counter ourselves. Also, the run's handle is supposed to be opened -- with @O_DIRECT@, which is counterproductive here.- , readerKOpsHandle :: !(FS.Handle h)+ , kOpsHandle :: !(FS.Handle h) -- | The blob file from the run this reader is reading from.- , readerBlobFile :: !(Ref (BlobFile m h))- , readerRunDataCaching :: !Run.RunDataCaching- , readerHasFS :: !(HasFS m h)- , readerHasBlockIO :: !(HasBlockIO m h)+ , blobFile :: !(Ref (BlobFile m h))+ , dataCaching :: !Run.RunDataCaching+ , hasFS :: !(HasFS m h)+ , hasBlockIO :: !(HasBlockIO m h) } data OffsetKey = NoOffsetKey | OffsetKey !SerialisedKey@@ -101,30 +104,31 @@ => OffsetKey -> Ref (Run.Run m h) -> m (RunReader m h)-new !offsetKey- readerRun@(DeRef Run.Run {- runBlobFile,- runRunDataCaching = readerRunDataCaching,- runHasFS = readerHasFS,- runHasBlockIO = readerHasBlockIO,- runIndex = index- }) = do- (readerKOpsHandle :: FS.Handle h) <-- FS.hOpen readerHasFS (runKOpsPath (Run.runFsPaths readerRun)) FS.ReadMode >>= \h -> do- fileSize <- FS.hGetSize readerHasFS h+new !offsetKey readerRun@(DeRef run) = do+ (kOpsHandle :: FS.Handle h) <-+ FS.hOpen run.hasFS (runKOpsPath (Run.runFsPaths readerRun)) FS.ReadMode >>= \h -> do+ fileSize <- FS.hGetSize run.hasFS h let fileSizeInPages = fileSize `div` toEnum pageSize let indexedPages = getNumPages $ Run.sizeInPages readerRun assert (indexedPages == fileSizeInPages) $ pure h -- Advise the OS that this file is being read sequentially, which will -- double the readahead window in response (only for this file descriptor)- FS.hAdviseAll readerHasBlockIO readerKOpsHandle FS.AdviceSequential+ FS.hAdviseAll run.hasBlockIO kOpsHandle FS.AdviceSequential - (page, entryNo) <- seekFirstEntry readerKOpsHandle+ (page, entryNo) <- seekFirstEntry kOpsHandle - readerBlobFile <- dupRef runBlobFile- readerCurrentEntryNo <- newPrimVar entryNo- readerCurrentPage <- newMutVar page- let reader = RunReader {..}+ blobFile <- dupRef run.blobFile+ currentEntryNo <- newPrimVar entryNo+ currentPage <- newMutVar page+ let reader = RunReader {+ currentPage = currentPage+ , currentEntryNo = currentEntryNo+ , kOpsHandle = kOpsHandle+ , blobFile = blobFile+ , dataCaching = run.dataCaching+ , hasFS = run.hasFS+ , hasBlockIO = run.hasBlockIO+ } when (isNothing page) $ close reader@@ -134,13 +138,13 @@ case offsetKey of NoOffsetKey -> do -- Load first page from disk, if it exists.- firstPage <- readDiskPage readerHasFS readerKOpsHandle+ firstPage <- readDiskPage run.hasFS readerKOpsHandle pure (firstPage, 0) OffsetKey offset -> do -- Use the index to find the page number for the key (if it exists).- let PageSpan pageNo pageEnd = Index.search offset index- seekToDiskPage readerHasFS pageNo readerKOpsHandle- readDiskPage readerHasFS readerKOpsHandle >>= \case+ let PageSpan pageNo pageEnd = Index.search offset run.index+ seekToDiskPage run.hasFS pageNo readerKOpsHandle+ readDiskPage run.hasFS readerKOpsHandle >>= \case Nothing -> pure (Nothing, 0) Just foundPage -> do@@ -159,8 +163,8 @@ -- page and the first key in the next page. -- Thus the reader should be initialised to return keys -- starting from the next (non-overflow) page.- seekToDiskPage readerHasFS (nextPageNo pageEnd) readerKOpsHandle- nextPage <- readDiskPage readerHasFS readerKOpsHandle+ seekToDiskPage run.hasFS (nextPageNo pageEnd) readerKOpsHandle+ nextPage <- readDiskPage run.hasFS readerKOpsHandle pure (nextPage, 0) {-# SPECIALISE close ::@@ -173,12 +177,12 @@ (MonadSTM m, MonadMask m, PrimMonad m) => RunReader m h -> m ()-close RunReader{..} = do- when (readerRunDataCaching == Run.NoCacheRunData) $+close r = do+ when (r.dataCaching == Run.NoCacheRunData) $ -- drop the file from the OS page cache- FS.hDropCacheAll readerHasBlockIO readerKOpsHandle- FS.hClose readerHasFS readerKOpsHandle- releaseRef readerBlobFile+ FS.hDropCacheAll r.hasBlockIO r.kOpsHandle+ FS.hClose r.hasFS r.kOpsHandle+ releaseRef r.blobFile --TODO: arguably we should have distinct finish and close and require that -- readers are _always_ closed, even after they have been drained. -- This would allow BlobRefs to remain valid until the reader is closed.@@ -247,12 +251,12 @@ (MonadMask m, MonadSTM m, MonadST m) => RunReader m h -> m (Result m h)-next reader@RunReader {..} = do- readMutVar readerCurrentPage >>= \case+next reader = do+ readMutVar reader.currentPage >>= \case Nothing -> pure Empty Just page -> do- entryNo <- readPrimVar readerCurrentEntryNo+ entryNo <- readPrimVar reader.currentEntryNo go entryNo page where go :: Word16 -> RawPage -> m (Result m h)@@ -261,26 +265,26 @@ case rawPageIndex page entryNo of IndexNotPresent -> do -- if it is past the last one, load a new page from disk, try again- newPage <- readDiskPage readerHasFS readerKOpsHandle- stToIO $ writeMutVar readerCurrentPage newPage+ newPage <- readDiskPage reader.hasFS reader.kOpsHandle+ stToIO $ writeMutVar reader.currentPage newPage case newPage of Nothing -> do close reader pure Empty Just p -> do- writePrimVar readerCurrentEntryNo 0+ writePrimVar reader.currentEntryNo 0 go 0 p -- try again on the new page IndexEntry key entry -> do- modifyPrimVar readerCurrentEntryNo (+1)- let entry' = fmap (BlobRef.mkRawBlobRef readerBlobFile) entry+ modifyPrimVar reader.currentEntryNo (+1)+ let entry' = fmap (BlobRef.mkRawBlobRef reader.blobFile) entry let rawEntry = Entry entry' pure (ReadEntry key rawEntry) IndexEntryOverflow key entry lenSuffix -> do -- TODO: we know that we need the next page, could already load?- modifyPrimVar readerCurrentEntryNo (+1)+ modifyPrimVar reader.currentEntryNo (+1) let entry' :: E.Entry SerialisedValue (RawBlobRef m h)- entry' = fmap (BlobRef.mkRawBlobRef readerBlobFile) entry- overflowPages <- readOverflowPages readerHasFS readerKOpsHandle lenSuffix+ entry' = fmap (BlobRef.mkRawBlobRef reader.blobFile) entry+ overflowPages <- readOverflowPages reader.hasFS reader.kOpsHandle lenSuffix let rawEntry = mkEntryOverflow entry' page lenSuffix overflowPages pure (ReadEntry key rawEntry)
src-core/Database/LSMTree/Internal/Unsafe.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+ {-# OPTIONS_HADDOCK not-home #-} -- | This module brings together the internal parts to provide an API in terms@@ -1235,9 +1235,9 @@ resolve (tableSessionSalt tEnv) runs- (V.mapStrict (\(DeRef r) -> Run.runFilter r) runs)- (V.mapStrict (\(DeRef r) -> Run.runIndex r) runs)- (V.mapStrict (\(DeRef r) -> Run.runKOpsFile r) runs)+ (V.mapStrict (\(DeRef r) -> r.bloomFilter) runs)+ (V.mapStrict (\(DeRef r) -> r.index ) runs)+ (V.mapStrict (\(DeRef r) -> r.kOpsFile ) runs) ks {-# SPECIALISE rangeLookup ::
src-core/Database/LSMTree/Internal/Vector.hs view
@@ -16,6 +16,7 @@ binarySearchL, unsafeInsertWithMStrict, unfoldrNM',+ singletonMStrict, ) where import Control.Monad@@ -136,3 +137,10 @@ (Just !a, !b') -> do VM.unsafeWrite vec n a go vec (n+1) b'++{-# INLINE singletonMStrict #-}+singletonMStrict :: PrimMonad m => a -> m (V.Vector a)+singletonMStrict !x = do+ mv <- VM.unsafeNew 1+ VM.unsafeWrite mv 0 $! x+ V.unsafeFreeze mv
src-extras/Database/LSMTree/Extras/Random.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Database.LSMTree.Extras.Random ( -- * Sampling from uniform distributions@@ -14,6 +15,9 @@ , shuffle -- * Generators for specific data types , randomByteStringR+ -- * Compatibility+ , splitGen_compat+ , uniform_compat ) where import qualified Data.ByteString as BS@@ -21,7 +25,7 @@ import Data.Ord (comparing) import qualified Data.Set as Set import qualified System.Random as R-import System.Random (StdGen, Uniform, uniform, uniformR)+import System.Random (StdGen, Uniform, uniformR) import Text.Printf (printf) {-------------------------------------------------------------------------------@@ -29,17 +33,16 @@ -------------------------------------------------------------------------------} uniformWithoutReplacement :: (Ord a, Uniform a) => StdGen -> Int -> [a]-uniformWithoutReplacement rng n = withoutReplacement rng n uniform+uniformWithoutReplacement rng n = withoutReplacement rng n uniform_compat uniformWithReplacement :: Uniform a => StdGen -> Int -> [a]-uniformWithReplacement rng n = withReplacement rng n uniform+uniformWithReplacement rng n = withReplacement rng n uniform_compat sampleUniformWithoutReplacement :: Ord a => StdGen -> Int -> [a] -> [a] sampleUniformWithoutReplacement rng0 n (Set.fromList -> xs0) | n > Set.size xs0 = error $- printf "sampleUniformWithoutReplacement: n > length xs0 for n=%d, \- \ length xs0=%d"+ printf "sampleUniformWithoutReplacement: n > length xs0 for n=%d, length xs0=%d" n (Set.size xs0) | otherwise =@@ -115,6 +118,39 @@ -- | Generates a random bytestring. Its length is uniformly distributed within -- the provided range. randomByteStringR :: (Int, Int) -> StdGen -> (BS.ByteString, StdGen)+#if MIN_VERSION_random(1,3,0) randomByteStringR range g = let (!l, !g') = uniformR range g in R.uniformByteString l g'+#else+-- MIN_VERSION_random(1,2,0)+randomByteStringR range g =+ let (!l, !g') = uniformR range g+ in R.genByteString l g'+#endif++{-------------------------------------------------------------------------------+ Compatibility+-------------------------------------------------------------------------------}++-- | Alternative to @splitGen@ that is also compatible with versions of+-- random<1.3+--+-- Uses @split@ on @random<1.3@, and @splitGen@ on @random>=1.3@. The former+-- function is deprecated on @random>=1.3@.+splitGen_compat :: StdGen -> (StdGen, StdGen)+#if MIN_VERSION_random(1,3,0)+splitGen_compat = R.splitGen+#else+splitGen_compat = R.split+#endif++-- | Alternative to @uniform@ that is also compatible with versions of+-- random<1.3+--+-- The order of type variables is different on random<1.3 and random>=1.3. This+-- is inconvenient for type application, so we use this compatibility function+-- to ensure that the type variables always have the same ordering.+uniform_compat :: (Uniform a, R.RandomGen g) => g -> (a, g)+uniform_compat = R.uniform+
test/Database/LSMTree/Model/Session.hs view
@@ -496,7 +496,7 @@ , innerBlob :: !(Model.BlobRef b) } -deriving stock instance Show b => Show (BlobRef b)+deriving stock instance Show (BlobRef b) retrieveBlobs :: forall m b. ( MonadState Model m
test/Test/Database/LSMTree/Internal.hs view
@@ -22,11 +22,12 @@ import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.FS+import Test.Util.QC.Compat (withNumTests_compat) tests :: TestTree tests = testGroup "Test.Database.LSMTree.Internal" [ testGroup "Cursor" [- testProperty "prop_roundtripCursor" $ withMaxSuccess 500 $+ testProperty "prop_roundtripCursor" $ withNumTests_compat 500 $ prop_roundtripCursor ] ]
test/Test/Database/LSMTree/Internal/BloomFilter.hs view
@@ -30,6 +30,7 @@ FileFormat (..)) import Database.LSMTree.Internal.Serialise (SerialisedKey, serialiseKey)+import Test.Util.QC.Compat (withNumTests_compat) --TODO: add a golden test for the BloomFilter format vs the 'formatVersion' -- to ensure we don't change the format without conciously bumping the version.@@ -38,9 +39,9 @@ [ testProperty "roundtrip" roundtrip_prop -- a specific case: 300 bits is just under 5x 64 bit words , testProperty "roundtrip-3-300" $ roundtrip_prop (Positive (Small 3)) (Positive 300)- , testProperty "total-deserialisation" $ withMaxSuccess 10000 $+ , testProperty "total-deserialisation" $ withNumTests_compat 10000 $ prop_total_deserialisation- , testProperty "total-deserialisation-whitebox" $ withMaxSuccess 10000 $+ , testProperty "total-deserialisation-whitebox" $ withNumTests_compat 10000 $ prop_total_deserialisation_whitebox , testProperty "bloomQueries (bulk)" $ prop_bloomQueries
test/Test/Database/LSMTree/Internal/Index/Compact.hs view
@@ -50,6 +50,7 @@ import Test.Util.Arbitrary (noTags, prop_arbitraryAndShrinkPreserveInvariant) import Test.Util.Orphans ()+import Test.Util.QC.Compat (withNumTests_compat) import Text.Printf (printf) tests :: TestTree@@ -123,9 +124,9 @@ prop_roundtrip_chunks , testProperty "prop_roundtrip" $ prop_roundtrip @TestKey- , testProperty "prop_total_deserialisation" $ withMaxSuccess 10000+ , testProperty "prop_total_deserialisation" $ withNumTests_compat 10000 prop_total_deserialisation- , testProperty "prop_total_deserialisation_whitebox" $ withMaxSuccess 10000+ , testProperty "prop_total_deserialisation_whitebox" $ withNumTests_compat 10000 prop_total_deserialisation_whitebox ] ]
test/Test/Database/LSMTree/Internal/Lookup.hs view
@@ -341,9 +341,9 @@ testSalt wb wbblobs runs- (V.map (\(DeRef r) -> Run.runFilter r) runs)- (V.map (\(DeRef r) -> Run.runIndex r) runs)- (V.map (\(DeRef r) -> Run.runKOpsFile r) runs)+ (V.map (\(DeRef r) -> r.bloomFilter) runs)+ (V.map (\(DeRef r) -> r.index) runs)+ (V.map (\(DeRef r) -> r.kOpsFile) runs) keys pure $ modelres === realres where
test/Test/Database/LSMTree/Internal/Merge.hs view
@@ -127,20 +127,15 @@ vals = concatMap (bifoldMap pure mempty . snd) kops isLarge = not . uncurry entryWouldFitInPage - getRunContent run@(DeRef Run.Run {- Run.runFilter,- Run.runIndex,- Run.runKOpsFile,- Run.runBlobFile- }) = do+ getRunContent run@(DeRef r) = do runSize <- evaluate (Run.size run) runKOps <- readKOps Nothing run- kopsFileContent <- FS.hGetAll fs runKOpsFile- blobFileContent <- withRef runBlobFile $+ kopsFileContent <- FS.hGetAll fs r.kOpsFile+ blobFileContent <- withRef r.blobFile $ FS.hGetAll fs . BlobFile.blobFileHandle pure ( runSize- , runFilter- , runIndex+ , r.bloomFilter+ , r.index , runKOps , kopsFileContent , blobFileContent
test/Test/Database/LSMTree/Internal/MergingTree.hs view
@@ -176,9 +176,9 @@ resolveVal testSalt runs- (fmap (\(DeRef r) -> Run.runFilter r) runs)- (fmap (\(DeRef r) -> Run.runIndex r) runs)- (fmap (\(DeRef r) -> Run.runKOpsFile r) runs)+ (fmap (\(DeRef r) -> r.bloomFilter) runs)+ (fmap (\(DeRef r) -> r.index ) runs)+ (fmap (\(DeRef r) -> r.kOpsFile ) runs) keys type SerialisedEntry = Entry SerialisedValue SerialisedBlob
test/Test/Database/LSMTree/Internal/RawBytes.hs view
@@ -9,9 +9,10 @@ import Database.LSMTree.Internal.RawBytes (RawBytes (RawBytes)) import qualified Database.LSMTree.Internal.RawBytes as RB import Test.QuickCheck (Property, classify, collect, mapSize,- withDiscardRatio, withMaxSuccess, (.||.), (===), (==>))+ withDiscardRatio, (.||.), (===), (==>)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)+import Test.Util.QC.Compat (withNumTests_compat) -- * Tests @@ -40,7 +41,7 @@ twoBlocksProp :: String -> RawBytes -> RawBytes -> Property -> Property twoBlocksProp msgAddition block1 block2- = withMaxSuccess 10000 .+ = withNumTests_compat 10000 . classify (block1 == block2) ("equal blocks" ++ msgAddition) withFirstBlockSizeInfo :: RawBytes -> Property -> Property
test/Test/Database/LSMTree/Internal/Run.hs view
@@ -223,8 +223,8 @@ Run.size written @=? Run.size loaded withRef written $ \written' -> withRef loaded $ \loaded' -> do- runFilter written' @=? runFilter loaded'- runIndex written' @=? runIndex loaded'+ written'.bloomFilter @=? loaded'.bloomFilter+ written'.index @=? loaded'.index writtenKOps <- readKOps Nothing written loadedKOps <- readKOps Nothing loaded
test/Test/Database/LSMTree/Internal/RunBloomFilterAlloc.hs view
@@ -36,7 +36,7 @@ import qualified Database.LSMTree.Internal.Entry as LSMT import Database.LSMTree.Internal.RunAcc (RunBloomFilterAlloc (..), newMBloom)-import System.Random hiding (Seed)+import System.Random (StdGen, Uniform, mkStdGen) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck
test/Test/Database/LSMTree/Internal/RunReader.hs view
@@ -198,7 +198,7 @@ Reader.next reader >>= \case Reader.Empty -> pure [] Reader.ReadEntry key e -> do- let fs = Reader.readerHasFS reader+ let fs = reader.hasFS e' <- traverse (readRawBlobRef fs) $ Reader.toFullEntry e ((key, e') :) <$> go reader
test/Test/Database/LSMTree/Resolve.hs view
@@ -9,6 +9,7 @@ import Database.LSMTree.Extras.Generators () import Test.Tasty import Test.Tasty.QuickCheck+import Test.Util.QC.Compat (withNumTests_compat) tests :: TestTree tests = testGroup "Test.Database.LSMTree.Resolve"@@ -19,9 +20,9 @@ forall v. (Show v, Arbitrary v, NFData v, SerialiseValue v, ResolveValue v) => [TestTree] allProperties =- [ testProperty "prop_resolveValidOutput" $ withMaxSuccess 1000 $+ [ testProperty "prop_resolveValidOutput" $ withNumTests_compat 1000 $ prop_resolveValidOutput @v- , testProperty "prop_resolveAssociativity" $ withMaxSuccess 1000 $+ , testProperty "prop_resolveAssociativity" $ withNumTests_compat 1000 $ prop_resolveAssociativity @v ]
+ test/Test/Util/QC/Compat.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++-- disabled because imports depend on CPP+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Test.Util.QC.Compat (+ withNumTests_compat+ ) where++import GHC.TypeLits+import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, Testable)++-- | Alternative to @withNumTests@ that is also compatible with versions of+-- QuickCheck<2.18+--+-- Uses @withMaxSuccess@ on @QuickCheck<2.18@, and @withNumTests@ on+-- @QuickCheck>=2.18@. The former function is deprecated on @QuickCheck>=2.18@.+withNumTests_compat :: Testable prop => Int -> prop -> Property+#if defined(MIN_VERSION_QuickCheck)+-- version macros are available and can be used as usual+# if MIN_VERSION_QuickCheck(2,18,0)+withNumTests_compat = QC.withNumTests+# else+withNumTests_compat = QC.withMaxSuccess+# endif+#else+-- MIN_VERSION_QuickCheck should always be defined as long as we are using Cabal+-- as our build system+withNumTests_compat = (undefined :: TypeError (Text "withNumTests_compat: MIN_VERSION_QuickCheck is unexpectedly undefined"))+#endif