diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,30 @@ # Revision history for `lsm-tree` +## 1.0.0.2 -- 2026-04-24 + +### Breaking changes + +None + +### New features + +None + +### Minor changes + +* Support `io-classes ^>=1.9` and `^>=1.10`. See [PR + #819](https://github.com/IntersectMBO/lsm-tree/pull/819). +* Support `ghc-9.14`. See [PR + #836](https://github.com/IntersectMBO/lsm-tree/pull/836). +* Support `containers-0.8`. See [PR + #836](https://github.com/IntersectMBO/lsm-tree/pull/836). + +### Bug fixes + +* Fix a bug where `lookups` with a large number of input keys would sometimes + return incorrect lookup results. See [PR + #841](https://github.com/IntersectMBO/lsm-tree/pull/841). + ## 1.0.0.1 -- 2025-12-03 * PATCH: support `filepath-1.4`. See PR diff --git a/bench/macro/utxo-bench.hs b/bench/macro/utxo-bench.hs --- a/bench/macro/utxo-bench.hs +++ b/bench/macro/utxo-bench.hs @@ -38,21 +38,23 @@ import Control.Applicative ((<**>)) import Control.Concurrent (getNumCapabilities) -import Control.Concurrent.Async -import Control.Concurrent.MVar +import Control.Concurrent.Async (waitBoth, withAsyncOn) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Control.DeepSeq (force) -import Control.Exception +import Control.Exception (evaluate) import Control.Monad (forM_, unless, void, when) import Control.Monad.Trans.State.Strict (runState, state) -import Control.Tracer +import Control.Tracer (Contravariant (contramap), Tracer, nullTracer, + squelchUnless, stdoutTracer) import qualified Data.ByteString.Short as BS import qualified Data.Foldable as Fold import qualified Data.IntSet as IS -import Data.IORef +import Data.IORef (IORef, modifyIORef, modifyIORef', newIORef, + readIORef, writeIORef) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Monoid +import Data.Monoid (Dual (Dual, getDual)) import qualified Data.Primitive as P import qualified Data.Vector as V import Data.Void (Void) @@ -64,11 +66,13 @@ import qualified System.Clock as Clock import qualified System.FS.API as FS import qualified System.FS.BlockIO.IO as FsIO -import System.IO +import System.IO (BufferMode (NoBuffering), Handle, + IOMode (WriteMode), hPutStr, hPutStrLn, hSetBuffering, + stdout, withFile) import System.Mem (performMajorGC) import qualified System.Random as Random import Text.Printf (printf) -import Text.Show.Pretty +import Text.Show.Pretty (ppShow) import Database.LSMTree.Extras (groupsOfN) diff --git a/lsm-tree.cabal b/lsm-tree.cabal --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: lsm-tree -version: 1.0.0.1 +version: 1.0.0.2 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.0.0.1 + tag: lsm-tree-1.0.0.2 common warnings ghc-options: @@ -528,6 +528,7 @@ ExplicitNamespaces GADTs LambdaCase + OverloadedRecordDot RecordWildCards RoleAnnotations ViewPatterns @@ -540,12 +541,12 @@ Database.LSMTree.Simple build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , blockio ^>=0.1 , contra-tracer ^>=0.1 || ^>=0.2 , deepseq ^>=1.4 || ^>=1.5 , fs-api ^>=0.4 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , io-classes:strict-mvar , lsm-tree:control , lsm-tree:core @@ -617,19 +618,19 @@ Database.LSMTree.Internal.WriteBufferWriter build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , bitvec ^>=1.1 , blockio ^>=0.1 , bloomfilter-blocked ^>=0.1 , bytestring ^>=0.11.4.0 || ^>=0.12.1.0 , cborg ^>=0.2.10.0 - , containers ^>=0.6 || ^>=0.7 + , containers ^>=0.6 || ^>=0.7 || ^>=0.8 , contra-tracer ^>=0.1 || ^>=0.2 , crc32c ^>=0.2.1 , deepseq ^>=1.4 || ^>=1.5 , filepath ^>=1.4 || ^>=1.5 , fs-api ^>=0.4 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , io-classes:strict-mvar , lsm-tree:control , lsm-tree:kmerge @@ -663,7 +664,7 @@ Database.LSMTree.Extras.UTxO build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , bitvec , blockio , bytestring @@ -780,7 +781,7 @@ , io-classes , io-classes:strict-mvar , io-classes:strict-stm - , io-sim + , io-sim <1.10 , lsm-tree , lsm-tree:control , lsm-tree:core @@ -798,7 +799,7 @@ , safe-wild-cards , semialign , split - , tasty + , tasty <1.5.3.0 , tasty-golden , tasty-hunit , tasty-quickcheck @@ -1026,7 +1027,7 @@ hs-source-dirs: test main-is: kmerge-test.hs build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , deepseq , heaps , lsm-tree:kmerge @@ -1045,7 +1046,7 @@ main-is: kmerge-test.hs cpp-options: -DKMERGE_BENCHMARKS build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , deepseq , heaps , lsm-tree:kmerge @@ -1063,7 +1064,7 @@ hs-source-dirs: test main-is: map-range-test.hs build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , bytestring , containers , lsm-tree:core @@ -1099,6 +1100,7 @@ Test.FormatPage Test.ScheduledMerges Test.ScheduledMerges.RunSizes + Test.ScheduledMergesDL Test.ScheduledMergesQLS build-depends: @@ -1127,9 +1129,9 @@ Control.RefCount build-depends: - , base >=4.16 && <4.22 + , base >=4.16 && <4.23 , deepseq ^>=1.4 || ^>=1.5 - , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 || ^>=1.9 || ^>=1.10 , io-classes:strict-stm , primitive ^>=0.9 diff --git a/src-core/Database/LSMTree/Internal/Arena.hs b/src-core/Database/LSMTree/Internal/Arena.hs --- a/src-core/Database/LSMTree/Internal/Arena.hs +++ b/src-core/Database/LSMTree/Internal/Arena.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_HADDOCK not-home #-} module Database.LSMTree.Internal.Arena ( ArenaManager, @@ -105,7 +107,7 @@ curr <- newBlock >>= newMVar free <- newMutVar [] full <- newMutVar [] - pure Arena {..} + pure Arena { curr = curr, free = free, full = full} {-# SPECIALISE closeArena :: ArenaManager s -> Arena s -> ST s () @@ -132,10 +134,10 @@ #ifndef NO_IGNORE_ASSERTS scrambleArena _ = pure () #else -scrambleArena Arena {..} = do - readMVar curr >>= scrambleBlock - readMutVar full >>= mapM_ scrambleBlock - readMutVar free >>= mapM_ scrambleBlock +scrambleArena arena = do + readMVar arena.curr >>= scrambleBlock + readMutVar arena.full >>= mapM_ scrambleBlock + readMutVar arena.free >>= mapM_ scrambleBlock {-# SPECIALISE scrambleBlock :: Block s -> ST s () @@ -157,18 +159,18 @@ #-} -- | Reset arena, i.e. return used blocks to free list. resetArena :: PrimMonad m => Arena (PrimState m) -> m () -resetArena Arena {..} = do - Block off mba <- takeMVar curr +resetArena arena = do + Block off mba <- takeMVar arena.curr -- reset current block writePrimVar off 0 -- move full block to free blocks. -- block's offset will be reset in 'newBlockWithFree' - full' <- atomicModifyMutVar' full $ \xs -> ([], xs) - atomicModifyMutVar' free $ \xs -> (full' <> xs, ()) + full' <- atomicModifyMutVar' arena.full $ \xs -> ([], xs) + atomicModifyMutVar' arena.free $ \xs -> (full' <> xs, ()) - putMVar curr $! Block off mba + putMVar arena.curr $! Block off mba -- | Create unmanaged arena. -- @@ -205,9 +207,9 @@ #-} -- TODO!? this is not async exception safe allocateFromArena' :: PrimMonad m => Arena (PrimState m)-> Size -> Alignment -> m (Offset, MutableByteArray (PrimState m)) -allocateFromArena' arena@Arena { .. } !size !alignment = do +allocateFromArena' arena !size !alignment = do -- take current block, lock the arena - curr'@(Block off mba) <- takeMVar curr + curr'@(Block off mba) <- takeMVar arena.curr off' <- readPrimVar off let !ali = alignment - 1 @@ -219,18 +221,18 @@ -- * update offset writePrimVar off end -- * release lock - putMVar curr curr' + putMVar arena.curr curr' -- * return data pure (off'', mba) else do -- doesn't fit into current block: -- * move current block into full - atomicModifyMutVar' full (\xs -> (curr' : xs, ())) + atomicModifyMutVar' arena.full (\xs -> (curr' : xs, ())) -- * allocate new block - new <- newBlockWithFree free + new <- newBlockWithFree arena.free -- * set new block as current, release the lock - putMVar curr new + putMVar arena.curr new -- * go again allocateFromArena' arena size alignment diff --git a/src-core/Database/LSMTree/Internal/BloomFilter.hs b/src-core/Database/LSMTree/Internal/BloomFilter.hs --- a/src-core/Database/LSMTree/Internal/BloomFilter.hs +++ b/src-core/Database/LSMTree/Internal/BloomFilter.hs @@ -89,7 +89,7 @@ unpackRunIxKeyIx :: RunIxKeyIx -> (Int, Int) unpackRunIxKeyIx (MkRunIxKeyIx c) = ( fromIntegral (c `unsafeShiftR` 16) - , fromIntegral (c .&. 0xfff) + , fromIntegral (c .&. 0xffff) ) {-# INLINE unpackRunIxKeyIx #-} diff --git a/src-core/Database/LSMTree/Internal/Index/Compact.hs b/src-core/Database/LSMTree/Internal/Index/Compact.hs --- a/src-core/Database/LSMTree/Internal/Index/Compact.hs +++ b/src-core/Database/LSMTree/Internal/Index/Compact.hs @@ -233,15 +233,15 @@ entries both for the first and subsequent pages of a larger-than-page entry. The natural thing to do is have each of these subsequent primary index entries contain the same key prefix value. This means a binary search will - find the /last/ entry in a run of equal prefix values. + find the /last/ entry in a sequence of equal prefix values. - What leads to complexity is that we will /also/ get runs of equal values if + What leads to complexity is that we will /also/ get sequences of equal values if we have clashes between pages (as discussed above). So in the general case - we may have a run of equal values made up of a mixture of clashes and + we may have a sequence of equal values made up of a mixture of clashes and larger-than-page entries. So the general situation is that after a binary search we have found the - end of what may turn out to be a run of clashes and larger-than-page values + end of what may turn out to be a sequence of clashes and larger-than-page values and we must disambigutate and return the appropriate single page (for the ordinary case) or an interval of pages (for the LTP case). @@ -251,13 +251,13 @@ counter-intuitive but it leads to a simpler mathematical definition (below). The search algorithm involves searching backwards in the clash bits to find - the beginning of the run of entries that are involved. To establish which - entry within the run is the right one to return, we can consult the tie + the beginning of the sequence of entries that are involved. To establish which + entry within the sequence is the right one to return, we can consult the tie breaker map by looking for the biggest entry that is less than or equal to - the full search key. This may then point to an index within the run of + the full search key. This may then point to an index within the sequence of clashing entries, in which case this is the right entry, but it may also point to an earlier and thus irrelevant entry, in which case the first entry - in the run is the right one. + in the sequence is the right one. Note that this second case also covers the case of a single non-clashing LTP. diff --git a/src-prototypes/ScheduledMerges.hs b/src-prototypes/ScheduledMerges.hs --- a/src-prototypes/ScheduledMerges.hs +++ b/src-prototypes/ScheduledMerges.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-partial-fields #-} -- | A prototype of an LSM with explicitly scheduled incremental merges. @@ -106,7 +104,7 @@ import Data.Functor.Contravariant import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, maybeToList) import Data.Primitive.Types import Data.STRef @@ -150,7 +148,7 @@ -- | The levels of the table, from most to least recently inserted. data LSMContent s = LSMContent - Buffer -- ^ write buffer is level 0 of the table, in-memory + WriteBuffer -- ^ write buffer is level 0 of the table, in-memory (Levels s) -- ^ \"regular\" levels 1+, on disk in real implementation (UnionLevel s) -- ^ a potential last level @@ -163,7 +161,11 @@ -- | A level is a sequence of resident runs at this level, prefixed by an -- incoming run, which is usually multiple runs that are being merged. Once -- completed, the resulting run will become a resident run at this level. +-- +-- Levels can also be empty, although we currently never create empty levels. +-- We plan to make use of them when migrating a completed union level. data Level s = Level !(IncomingRun s) ![Run] + | EmptyLevel -- | We represent single runs specially, rather than putting them in as a -- 'CompletedMerge'. This is for two reasons: to see statically that it's a @@ -173,8 +175,17 @@ data IncomingRun s = Merging !MergePolicyForLevel !NominalDebt !(STRef s NominalCredit) !(MergingRun LevelMergeType s) - | Single !Run + | Single !SingleRunOrigin !Run +-- | Additional information about the origin of a 'Single' run. This allows us +-- to have stronger invariants. +data SingleRunOrigin = FromWriteBuffer + | FromLevellingLevel + -- | A former union level that was completed (merged down + -- to a single run) and became the last regular level. + | FromMigratedUnion + deriving stock (Eq, Show) + -- | The merge policy for a LSM level can be either tiering or levelling. -- In this design we use levelling for the last level, and tiering for -- all other levels. The first level always uses tiering however, even if @@ -288,18 +299,34 @@ -> PendingMerge s pattern PendingMerge mt prs ts <- (pendingContent -> (mt, prs, ts)) -type Run = Map Key Entry -type Buffer = Map Key Entry - -bufferToRun :: Buffer -> Run -bufferToRun = id +newtype Run = Run { runEntries :: Map Key Entry } + deriving newtype Show runSize :: Run -> Int -runSize = Map.size +runSize = Map.size . runEntries -bufferSize :: Buffer -> Int -bufferSize = Map.size +lookupRun :: Key -> Run -> Maybe Entry +lookupRun k = Map.lookup k . runEntries +newtype WriteBuffer = WriteBuffer { bufferEntries :: Map Key Entry } + +emptyWriteBuffer :: WriteBuffer +emptyWriteBuffer = WriteBuffer Map.empty + +writeBufferSize :: WriteBuffer -> Int +writeBufferSize = Map.size . bufferEntries + +insertWriteBuffer :: Key -> Entry -> WriteBuffer -> WriteBuffer +insertWriteBuffer k e = WriteBuffer . Map.insertWith combine k e . bufferEntries + +lookupWriteBuffer :: Key -> WriteBuffer -> Maybe Entry +lookupWriteBuffer k = Map.lookup k . bufferEntries + +-- | Flush a write buffer. In the real implementation, this involves IO. +-- Note that we should never flush an empty write buffer. +flushWriteBuffer :: WriteBuffer -> Run +flushWriteBuffer (WriteBuffer m) = assert (not (null m)) (Run m) + type Entry = Update Value Blob newtype Key = K Int @@ -340,9 +367,12 @@ levelsInvariant :: Int -> Levels s -> ST s () levelsInvariant !_ [] = pure () + levelsInvariant !_ (EmptyLevel : ls) = do + assertST $ not (null ls) -- last level shouldn't be empty + levelsInvariant !ln (Level ir rs : ls) = do mrs <- case ir of - Single r -> + Single _ r -> pure (CompletedMerge r) Merging mp _ _ (MergingRun mt _ ref) -> do assertST $ ln > 1 -- no merges on level 1 @@ -356,24 +386,35 @@ levelsInvariant (ln+1) ls - -- All runs within a level "proper" (as opposed to the incoming runs + -- All regular runs within a level "proper" (as opposed to the incoming runs -- being merged) should be of the correct size for the level. expectedRunLengths :: Int -> [Run] -> [Level s] -> ST s () expectedRunLengths ln rs ls = case mergePolicyForLevel ln ls ul of - -- Levels using levelling have only one (incoming) run, which almost - -- always consists of an ongoing merge. The exception is when a - -- levelling run becomes too large and is promoted, in that case - -- initially there's no merge, but it is still represented as an - -- 'IncomingRun', using 'Single'. Thus there are no other resident runs. - LevelLevelling -> assertST $ null rs && null ls - -- Runs in tiering levels usually fit that size, but they can be one - -- larger, if a run has been held back (creating a (T+1)-way merge). - LevelTiering -> assertST $ all (\r -> runToLevelNumber LevelTiering conf r `elem` [ln, ln+1]) rs - -- (This is actually still not really true, but will hold in practice. - -- In the pathological case, all runs passed to the next level can be - -- factor ((T+1)/T) too large, and there the same holding back can lead to - -- factor ((T+2)/T) etc., until at level 12 a run is two levels too large. + LevelLevelling -> do + -- Levelling can only occur on the last level. + assertST $ null ls + -- Levels using levelling have only one (incoming) run, which almost + -- always consists of an ongoing merge. The exception is when a + -- levelling run becomes too large and is promoted, in that case + -- initially there's no merge, but it is still represented as an + -- 'IncomingRun', using 'Single'. Thus there are no other resident + -- runs. + assertST $ null rs + LevelTiering -> do + -- There are no empty runs in tiering levels, as they are either: + -- 1. a mid-level, so deletes can't be dropped and merges can't result + -- in empty runs + -- 2. the first level, so their runs come directly from flushing the + -- write buffer. + assertST $ all (\r -> runSize r > 0) rs + -- Runs in tiering levels usually fit that level's size, but they can + -- be slightly larger if a run has been held back (creating a + -- (T+1)-way merge). + -- + -- TODO: Holding back runs can theoretically result in runs that are + -- more than one size too large. See issue #829. + assertST $ all (\r -> runToLevelNumber LevelTiering conf r `elem` [ln, ln+1]) rs -- Incoming runs being merged also need to be of the right size, but the -- conditions are more complicated. @@ -383,12 +424,23 @@ case mergePolicyForLevel ln ls ul of LevelLevelling -> do case (ir, mrs) of - -- A single incoming run (which thus didn't need merging) must be - -- of the expected size range already - (Single r, m) -> do + -- A single incoming run (which didn't need merging) in a levelling + -- level can be created one of two ways: + -- 1. when a levelling level is full, so the run gets promoted to + -- the new last level + -- 2. when the union level gets migrated. + -- + -- In the latter case, it can be arbitrarily small. + (Single origin r, m) -> do assertST $ case m of CompletedMerge{} -> True OngoingMerge{} -> False - assertST $ runToLevelNumber LevelLevelling conf r == ln + case origin of + FromWriteBuffer -> + assertST False -- we don't flush to levelling levels + FromLevellingLevel -> + assertST $ runToLevelNumber LevelLevelling conf r == ln + FromMigratedUnion -> + assertST $ runToLevelNumber LevelLevelling conf r <= ln -- A completed merge for levelling can be of almost any size at all! -- It can be smaller, due to deletions in the last level. But it @@ -415,9 +467,10 @@ case (ir, mrs, mergeTypeForLevel ls ul) of -- A single incoming run (which thus didn't need merging) must be -- of the expected size already - (Single r, m, _) -> do + (Single origin r, m, _) -> do assertST $ case m of CompletedMerge{} -> True OngoingMerge{} -> False + assertST $ origin == FromWriteBuffer assertST $ runToLevelNumber LevelTiering conf r == ln -- A completed last level run can be of almost any smaller size due @@ -891,7 +944,7 @@ assertST $ length runs > 1 -- in some cases, no merging is required at all (debt, state) <- case filter (\r -> runSize r > 0) runs of - [] -> let (r:_) = runs -- just reuse the empty input + [] -> let r = head runs -- just reuse the empty input in pure (runSize r, CompletedMerge r) [r] -> pure (runSize r, CompletedMerge r) rs -> do @@ -904,8 +957,10 @@ mergek :: IsMergeType t => t -> [Run] -> Run mergek t = - (if isLastLevel t then Map.filter (/= Delete) else id) + Run + . (if isLastLevel t then Map.filter (/= Delete) else id) . Map.unionsWith (if isUnion t then combineUnion else combine) + . map runEntries -- | Combines two entries that have been performed after another. Therefore, the -- newer one overwrites the old one (or modifies it for 'Mupsert'). Only take a @@ -992,7 +1047,7 @@ | otherwise = do traceWith tr $ NewTableEvent tid conf c <- newSTRef 0 - lsm <- newSTRef (LSMContent Map.empty [] NoUnion) + lsm <- newSTRef (LSMContent emptyWriteBuffer [] NoUnion) pure (LSMHandle tid c conf lsm) inserts :: Tracer (ST s) Event -> LSM s -> [(Key, Value, Maybe Blob)] -> ST s () @@ -1026,19 +1081,23 @@ update tr (LSMHandle tid scr conf lsmr) k entry = do traceWith tr $ UpdateEvent tid k entry sc <- readSTRef scr - content@(LSMContent wb ls unionLevel) <- readSTRef lsmr + content@(LSMContent wb ls ul) <- readSTRef lsmr modifySTRef' scr (+1) supplyCreditsLevels (NominalCredit 1) ls invariant conf content - let wb' = Map.insertWith combine k entry wb - if bufferSize wb' >= maxWriteBufferSize conf + let wb' = insertWriteBuffer k entry wb + if writeBufferSize wb' >= maxWriteBufferSize conf then do - ls' <- increment (LevelEvent tid >$< tr) sc conf (bufferToRun wb') ls unionLevel - let content' = LSMContent Map.empty ls' unionLevel + -- The merging tree might have become completed. If so, we want to + -- migrate it now, so it can become part of new merges. + (ls', ul') <- migrateUnionLevel (LevelEvent tid >$< tr) sc conf ls ul + let r = flushWriteBuffer wb' + ls'' <- increment (LevelEvent tid >$< tr) sc conf r ls' ul' + let content' = LSMContent emptyWriteBuffer ls'' ul' invariant conf content' writeSTRef lsmr content' else - writeSTRef lsmr (LSMContent wb' ls unionLevel) + writeSTRef lsmr (LSMContent wb' ls ul) supplyMergeCredits :: LSM s -> NominalCredit -> ST s () supplyMergeCredits (LSMHandle _ scr conf lsmr) credits = do @@ -1099,7 +1158,7 @@ Just tree -> do debt <- fst <$> remainingDebtMergingTree tree Union tree <$> newSTRef debt - lsmr <- newSTRef (LSMContent Map.empty [] unionLevel) + lsmr <- newSTRef (LSMContent emptyWriteBuffer [] unionLevel) c <- newSTRef 0 pure (LSMHandle childTid c conf lsmr) @@ -1116,12 +1175,17 @@ -- | Return the current union debt. This debt can be reduced until it is paid -- off using 'supplyUnionCredits'. +-- +-- As long as there is a union level, there is a non-zero debt. This makes it +-- clear that 'supplyUnionCredits' should still be called to trigger migration, +-- even if the merging tree itself has been completed. This becomes necessary +-- when the tree has been completed by operations on another table via sharing. remainingUnionDebt :: LSM s -> ST s UnionDebt remainingUnionDebt (LSMHandle _ _ _conf lsmr) = do LSMContent _ _ ul <- readSTRef lsmr UnionDebt <$> case ul of NoUnion -> pure 0 - Union tree d -> checkedUnionDebt tree d + Union tree d -> (+1) <$> checkedUnionDebt tree d -- | Credits are used to pay off 'UnionDebt', completing a 'union' in the -- process. @@ -1142,43 +1206,31 @@ -- This function returns any surplus of union credits as /leftover/ credits when -- a union has finished. In particular, if the returned number of credits is -- non-negative, then the union is finished. -supplyUnionCredits :: LSM s -> UnionCredits -> ST s UnionCredits -supplyUnionCredits (LSMHandle _ scr conf lsmr) (UnionCredits credits) - | credits <= 0 = pure (UnionCredits 0) - | otherwise = do - content@(LSMContent _ _ ul) <- readSTRef lsmr - UnionCredits <$> case ul of - NoUnion -> - pure credits - Union tree debtRef -> do - modifySTRef' scr (+1) - _debt <- checkedUnionDebt tree debtRef -- just to make sure it's checked - c' <- supplyCreditsMergingTree credits tree - debt' <- checkedUnionDebt tree debtRef - when (debt' > 0) $ - assertST $ c' == 0 -- should have spent these credits - invariant conf content - pure c' - --- TODO: At some point the completed merging tree should to moved into the --- regular levels, so it can be merged with other runs and last level merges can --- happen again to drop deletes. Also, lookups then don't need to handle the --- merging tree any more. There are two possible strategies: --- --- 1. As soon as the merging tree completes, move the resulting run to the --- regular levels. However, its size does generally not fit the last level, --- which requires relaxing 'invariant' and adjusting 'increment'. --- --- If the run is much larger than the resident and incoming runs of the last --- level, it should also not be included into a merge yet, as that merge --- would be expensive, but offer very little potential for compaction (the --- run from the merging tree is already compacted after all). So it needs to --- be bumped to the next level instead. --- --- 2. Initially leave the completed run in the union level. Then every time a --- new last level merge is created in 'increment', check if there is a --- completed run in the union level with a size that fits the new merge. If --- yes, move it over. +supplyUnionCredits :: Tracer (ST s) Event -> LSM s -> UnionCredits -> ST s UnionCredits +supplyUnionCredits tr (LSMHandle tid scr conf lsmr) (UnionCredits credits) = do + traceWith tr $ SupplyUnionCreditsEvent tid credits + if credits <= 0 + then + pure (UnionCredits 0) + else do + content@(LSMContent wb ls ul) <- readSTRef lsmr + UnionCredits <$> case ul of + NoUnion -> + pure credits + Union tree debtRef -> do + invariant conf content + sc <- readSTRef scr + modifySTRef' scr (+1) + _debt <- checkedUnionDebt tree debtRef -- make sure it's checked + c' <- supplyCreditsMergingTree credits tree + debt' <- checkedUnionDebt tree debtRef + when (debt' > 0) $ + assertST $ c' == 0 -- we should have spent these credits + (ls', ul') <- migrateUnionLevel (LevelEvent tid >$< tr) sc conf ls ul + let content' = LSMContent wb ls' ul' + invariant conf content' + writeSTRef lsmr content' + pure c' -- | Like 'remainingDebtMergingTree', but additionally asserts that the debt -- never increases. @@ -1190,6 +1242,53 @@ writeSTRef debtRef debt pure debt +-- | At some point the completed merging tree should become part of the regular +-- levels, so it can be merged with other runs. Otherwise, we could never +-- perform a last level merge, which is especially important for compaction, as +-- it allows us to drop deletes. Also, lookups then don't need to consider the +-- merging tree any more. +-- +-- We can do this as soon as the tree is completed by appending a new regular +-- level containing only the run that resulted from the tree merge. If the +-- run is too large to fit into the level directly after the existing ones, we +-- first add empty levels. +migrateUnionLevel :: forall s. Tracer (ST s) (EventAt EventDetail) + -> Counter -> LSMConfig -> Levels s -> UnionLevel s + -> ST s (Levels s, UnionLevel s) +migrateUnionLevel _ _ _ ls NoUnion = do + -- nothing to do + pure (ls, NoUnion) +migrateUnionLevel tr sc conf ls ul@(Union t _) = + getCompletedMergingTree t >>= \case + Nothing -> + -- Still in progress, leave it. + pure (ls, ul) + Just r -> do + -- Before migration, there is usually a last regular (i.e. non-union) + -- level, which uses tiering. We could potentially add the completed + -- union (or rather the run it resulted in) directly to the resident + -- tiering runs of that last regular level, but that would clash with + -- some invariants. Instead, we always create a new last level, which + -- only makes a small difference, but keeps the invariants simpler. + -- + -- Also note even empty runs get migrated. This doesn't violate any + -- invariants, as levelling levels can already contain empty runs. + -- Dropping the run would be more complicated since the previous level + -- then suddenly becomes the last one while potentially still containing + -- midlevel merges. + let levelNo = maximum + [ 2 -- First level is tiering, don't migrate there. + , length ls + 1 -- Must come after existing levels. + , runToLevelNumber LevelLevelling conf r + -- Run must not be too large for the level. + ] + let emptyLevels = replicate (levelNo - 1 - length ls) EmptyLevel + let level = Level (Single FromMigratedUnion r) [] + let levels = ls ++ emptyLevels ++ [level] + assertST $ length levels == levelNo + traceWith tr $ EventAt sc levelNo $ UnionLevelMigratedEvent r + pure (levels, NoUnion) + ------------------------------------------------------------------------------- -- Lookups -- @@ -1212,9 +1311,9 @@ -- -- In the real implementation, this is done not on an individual 'LookupAcc', -- but one for each key, i.e. @Vector (Maybe Entry)@. -doLookup :: Buffer -> [Run] -> UnionLevel s -> Key -> ST s (LookupResult Value Blob) +doLookup :: WriteBuffer -> [Run] -> UnionLevel s -> Key -> ST s (LookupResult Value Blob) doLookup wb runs ul k = do - let acc0 = lookupBatch (Map.lookup k wb) k runs + let acc0 = lookupBatch (lookupWriteBuffer k wb) k runs case ul of NoUnion -> pure (convertAcc acc0) @@ -1222,7 +1321,7 @@ treeBatches <- buildLookupTree tree let treeResults = lookupBatch Nothing k <$> treeBatches pure $ convertAcc $ foldLookupTree $ - if null wb && null runs + if writeBufferSize wb == 0 && null runs then treeResults else LookupNode MergeLevel [LookupBatch acc0, treeResults ] where @@ -1239,7 +1338,7 @@ -- In a real implementation, this would take all keys at once and be in IO. lookupBatch :: LookupAcc -> Key -> [Run] -> LookupAcc lookupBatch acc k rs = - let entries = [entry | r <- rs, Just entry <- [Map.lookup k r]] + let entries = [entry | r <- rs, Just entry <- [lookupRun k r]] in foldl (updateAcc combine) acc entries data LookupTree a = LookupBatch a @@ -1333,11 +1432,12 @@ -- inserting without calling 'supplyUnionCredits'. supplyCreditsLevels :: NominalCredit -> Levels s -> ST s () supplyCreditsLevels nominalDeposit = - traverse_ $ \(Level ir _rs) -> do - case ir of - Single{} -> pure () - Merging _mp nominalDebt nominalCreditVar - mr@(MergingRun _ physicalDebt _) -> do + traverse_ $ \lvl -> do + case lvl of + EmptyLevel -> pure () + Level Single{} _ -> pure () + Level (Merging _mp nominalDebt nominalCreditVar + mr@(MergingRun _ physicalDebt _)) _ -> do nominalCredit <- depositNominalCredit nominalDebt nominalCreditVar nominalDeposit @@ -1438,9 +1538,17 @@ where tr' = contramap (EventAt sc ln) tr + go !ln incoming (EmptyLevel : ls) = do + assertST $ mergePolicyForLevel ln ls ul == LevelTiering -- mid level + traceWith tr' LevelWasEmptyEvent + ir <- newLevelMerge tr' conf ln LevelTiering (mergeTypeFor ls) incoming + pure (Level ir [] : ls) + where + tr' = contramap (EventAt sc ln) tr + go !ln incoming (Level ir rs : ls) = do r <- case ir of - Single r -> do + Single _ r -> do traceWith tr' $ SingleRunCompletedEvent r pure r Merging mergePolicy _ _ mr -> do @@ -1511,10 +1619,18 @@ -> LSMConfig -> Int -> MergePolicyForLevel -> LevelMergeType -> [Run] -> ST s (IncomingRun s) -newLevelMerge tr _ _ _ _ [r] = do +newLevelMerge tr _ ln mergePolicy _ [r] = do + origin <- + if ln <= 1 + then do + assertST $ ln == 1 + pure FromWriteBuffer + else do + assertST $ mergePolicy == LevelLevelling + pure FromLevellingLevel traceWith tr $ NewSingleRunEvent r - pure (Single r) -newLevelMerge tr conf@LSMConfig{..} level mergePolicy mergeType rs = do + pure (Single origin r) +newLevelMerge tr conf@LSMConfig{..} ln mergePolicy mergeType rs = do mergingRun@(MergingRun _ physicalDebt _) <- newMergingRun mergeType rs traceWith tr NewLevelMergeEvent { mergePolicy, @@ -1530,7 +1646,7 @@ -- The nominal debt equals the minimum of credits we will supply before we -- expect the merge to complete. This is the same as the number of updates -- in a run that gets moved to this level. - nominalDebt = NominalDebt (levelNumberToMaxRunSize LevelTiering conf level) + nominalDebt = NominalDebt (levelNumberToMaxRunSize LevelTiering conf ln) -- The physical debt is the number of actual merge steps we will need to -- perform before the merge is complete. This is always the sum of the @@ -1548,16 +1664,16 @@ LevelLevelling -> -- Incoming runs, which may be slightly overfull with respect to the -- previous level - configSizeRatio * levelNumberToMaxRunSize LevelTiering conf level + configSizeRatio * levelNumberToMaxRunSize LevelTiering conf ln -- The single run that was already on this level - + levelNumberToMaxRunSize LevelLevelling conf level + + levelNumberToMaxRunSize LevelLevelling conf ln LevelTiering -> -- Incoming runs, which may be slightly overfull with respect to the -- previous level - configSizeRatio * levelNumberToMaxRunSize LevelTiering conf level + configSizeRatio * levelNumberToMaxRunSize LevelTiering conf ln -- Held back run that is underfull with respect to the current -- level - + levelNumberToMaxRunSize LevelTiering conf (level - 1) + + levelNumberToMaxRunSize LevelTiering conf (ln - 1) ------------------------------------------------------------------------------- -- MergingTree abstraction @@ -1600,24 +1716,19 @@ -- | Ensures that the merge contains more than one input, avoiding creating a -- pending merge where possible. -newPendingLevelMerge :: [IncomingRun s] +newPendingLevelMerge :: [PreExistingRun s] -> Maybe (MergingTree s) -> ST s (Maybe (MergingTree s)) newPendingLevelMerge [] t = pure t -newPendingLevelMerge [Single r] Nothing = +newPendingLevelMerge [PreExistingRun r] Nothing = Just . MergingTree <$> newSTRef (CompletedTreeMerge r) -newPendingLevelMerge [Merging{}] Nothing = +newPendingLevelMerge [PreExistingMergingRun{}] Nothing = -- This case should never occur. If there is a single entry in the list, -- there can only be one level in the input table. At level 1 there are no - -- merging runs, so it must be a PreExistingRun. + -- merging runs, it must be a Single run flushed from a write buffer. error "newPendingLevelMerge: singleton Merging run" -newPendingLevelMerge irs tree = do - let prs = map incomingToPreExistingRun irs - st = PendingTreeMerge (PendingLevelMerge prs tree) - Just . MergingTree <$> newSTRef st - where - incomingToPreExistingRun (Single r) = PreExistingRun r - incomingToPreExistingRun (Merging _ _ _ mr) = PreExistingMergingRun mr +newPendingLevelMerge prs t = do + Just . MergingTree <$> newSTRef (PendingTreeMerge (PendingLevelMerge prs t)) -- | Ensures that the merge contains more than one input. newPendingUnionMerge :: [MergingTree s] -> ST s (Maybe (MergingTree s)) @@ -1629,15 +1740,20 @@ contentToMergingTree :: LSMContent s -> ST s (Maybe (MergingTree s)) contentToMergingTree (LSMContent wb ls ul) = - newPendingLevelMerge (buffers ++ levels) trees + newPendingLevelMerge (maybeToList buffer ++ levels) trees where -- flush the write buffer (but this should not modify the content) - buffers - | bufferSize wb == 0 = [] - | otherwise = [Single (bufferToRun wb)] + buffer + | writeBufferSize wb == 0 = Nothing + | otherwise = Just (PreExistingRun (flushWriteBuffer wb)) - levels = flip concatMap ls $ \(Level ir rs) -> ir : map Single rs + levels = flip concatMap ls $ \case + EmptyLevel -> [] + Level ir rs -> toPreExisting ir : map PreExistingRun rs + toPreExisting (Single _ r) = PreExistingRun r + toPreExisting (Merging _ _ _ mr) = PreExistingMergingRun mr + trees = case ul of NoUnion -> Nothing Union t _ -> Just t @@ -1791,6 +1907,12 @@ expectCompletedMergingTree :: HasCallStack => MergingTree s -> ST s Run expectCompletedMergingTree = expectInvariant . isCompletedMergingTree +getCompletedMergingTree :: MergingTree s -> ST s (Maybe Run) +getCompletedMergingTree t = + evalInvariant (isCompletedMergingTree t) >>= \case + Left _ -> pure Nothing + Right r -> pure (Just r) + ------------------------------------------------------------------------------- -- Measurements -- @@ -1799,7 +1921,7 @@ | MNode TreeMergeType [MTree r] deriving stock (Eq, Foldable, Functor, Show) -allLevels :: LSM s -> ST s (Buffer, [[Run]], Maybe (MTree Run)) +allLevels :: LSM s -> ST s (WriteBuffer, [[Run]], Maybe (MTree Run)) allLevels (LSMHandle _ _ _conf lsmr) = do LSMContent wb ls ul <- readSTRef lsmr rs <- flattenLevels ls @@ -1812,11 +1934,12 @@ flattenLevels = mapM flattenLevel flattenLevel :: Level s -> ST s [Run] +flattenLevel EmptyLevel = pure [] flattenLevel (Level ir rs) = (++ rs) <$> flattenIncomingRun ir flattenIncomingRun :: IncomingRun s -> ST s [Run] flattenIncomingRun = \case - Single r -> pure [r] + Single _ r -> pure [r] Merging _ _ _ mr -> flattenMergingRun mr flattenMergingRun :: MergingRun t s -> ST s [Run] @@ -1851,8 +1974,9 @@ (wb, levels, tree) <- allLevels lsm let r = mergek MergeLevel - (wb : concat levels ++ toList (mergeTree <$> tree)) - pure (Map.mapMaybe justInsert r) + (Run (bufferEntries wb) -- we don't flush, but treat wb as a run + : concat levels ++ toList (mergeTree <$> tree)) + pure (Map.mapMaybe justInsert (runEntries r)) where mergeTree :: MTree Run -> Run mergeTree (MLeaf r) = r @@ -1862,7 +1986,7 @@ justInsert Delete = Nothing justInsert (Mupsert v) = Just (v, Nothing) -type Representation = (Run, [LevelRepresentation], Maybe (MTree Run)) +type Representation = (WriteBuffer, [LevelRepresentation], Maybe (MTree Run)) type LevelRepresentation = (Maybe (MergePolicyForLevel, NominalDebt, NominalCredit, @@ -1879,7 +2003,9 @@ pure (wb, levels, tree) dumpLevel :: Level s -> ST s LevelRepresentation -dumpLevel (Level (Single r) rs) = +dumpLevel EmptyLevel = + pure (Nothing, []) +dumpLevel (Level (Single _ r) rs) = pure (Nothing, (r:rs)) dumpLevel (Level (Merging mp nd ncv (MergingRun mt _ ref)) rs) = do mrs <- readSTRef ref @@ -1892,31 +2018,30 @@ representationShape :: Representation -> (Int, [([Int], [Int])], Maybe (MTree Int)) representationShape (wb, levels, tree) = - (summaryRun wb, map summaryLevel levels, fmap (fmap summaryRun) tree) + (writeBufferSize wb, map summaryLevel levels, fmap (fmap runSize) tree) where summaryLevel (mmr, rs) = let (ongoing, complete) = summaryMR mmr - in (ongoing, complete <> map summaryRun rs) - - summaryRun = runSize + in (ongoing, complete <> map runSize rs) summaryMR = \case Nothing -> ([], []) - Just (_, _, _, _, CompletedMerge r) -> ([], [summaryRun r]) - Just (_, _, _, _, OngoingMerge _ rs _) -> (map summaryRun rs, []) + Just (_, _, _, _, CompletedMerge r) -> ([], [runSize r]) + Just (_, _, _, _, OngoingMerge _ rs _) -> (map runSize rs, []) ------------------------------------------------------------------------------- -- Tracing -- -- TODO: these events are incomplete, in particular we should also trace what --- happens in the union level. +-- happens in the union level. Somewhat related: issue #445. data Event = NewTableEvent TableId LSMConfig | UpdateEvent TableId Key Entry | LookupEvent TableId Key | DuplicateEvent TableId TableId | UnionsEvent TableId [TableId] + | SupplyUnionCreditsEvent TableId Credit | LevelEvent TableId (EventAt EventDetail) deriving stock Show @@ -1946,9 +2071,12 @@ } | SingleRunCompletedEvent Run + | UnionLevelMigratedEvent Run + | RunTooSmallForLevelEvent MergePolicyForLevel Run | LevelIsFullEvent MergePolicyForLevel | LevelIsNotFullEvent MergePolicyForLevel + | LevelWasEmptyEvent deriving stock Show ------------------------------------------------------------------------------- @@ -1974,8 +2102,26 @@ , (1, pure Delete) ] +instance QC.Arbitrary Run where + arbitrary = Run <$> QC.arbitrary + shrink = map Run . QC.shrink . runEntries + instance QC.Arbitrary LevelMergeType where arbitrary = QC.elements [MergeMidLevel, MergeLastLevel] instance QC.Arbitrary TreeMergeType where arbitrary = QC.elements [MergeLevel, MergeUnion] + +instance QC.Arbitrary LSMConfig where + arbitrary = do + configMaxWriteBufferSize <- QC.chooseInt (1, 10) + configSizeRatio <- QC.chooseInt (2, 8) + pure LSMConfig {configMaxWriteBufferSize, configSizeRatio} + shrink (LSMConfig size ratio) = + [ LSMConfig size' ratio' + | (size', ratio') <- QC.liftShrink2 QC.shrink shrinkSizeRatio (size, ratio) + , size' >= 1 + ] + where + shrinkSizeRatio 4 = [] + shrinkSizeRatio _ = [4] -- try shrinking to four, the default ratio diff --git a/test-prototypes/Main.hs b/test-prototypes/Main.hs --- a/test-prototypes/Main.hs +++ b/test-prototypes/Main.hs @@ -5,6 +5,7 @@ import qualified Test.FormatPage import qualified Test.ScheduledMerges import qualified Test.ScheduledMerges.RunSizes +import qualified Test.ScheduledMergesDL import qualified Test.ScheduledMergesQLS main :: IO () @@ -13,4 +14,5 @@ , Test.ScheduledMerges.tests , Test.ScheduledMerges.RunSizes.tests , Test.ScheduledMergesQLS.tests + , Test.ScheduledMergesDL.tests ] diff --git a/test-prototypes/Test/ScheduledMerges.hs b/test-prototypes/Test/ScheduledMerges.hs --- a/test-prototypes/Test/ScheduledMerges.hs +++ b/test-prototypes/Test/ScheduledMerges.hs @@ -13,7 +13,8 @@ import ScheduledMerges as LSM import qualified Test.QuickCheck as QC -import Test.QuickCheck (Arbitrary (arbitrary, shrink), Property) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Property, + (.&&.)) import Test.QuickCheck.Exception (isDiscard) import Test.Tasty import Test.Tasty.HUnit (HasCallStack, testCase) @@ -24,7 +25,7 @@ tests = testGroup "Test.ScheduledMerges" [ testCase "test_regression_empty_run" test_regression_empty_run , testCase "test_merge_again_with_incoming" test_merge_again_with_incoming - , testProperty "prop_union" prop_union + , testProperty "prop_union_complete" prop_union_complete , testGroup "T" [ localOption (QuickCheckTests 1000) $ -- super quick, run more testProperty "Arbitrary satisfies invariant" prop_arbitrarySatisfiesInvariant @@ -176,35 +177,114 @@ -- properties -- --- | Supplying enough credits for the remaining debt completes the union merge. -prop_union :: [[(LSM.Key, LSM.Entry)]] -> Property -prop_union kess = length (filter (not . null) kess) > 1 QC.==> +-- | Supplying enough credits for the remaining debt completes the union merge +-- (as externally observable through 'LSM.remainingUnionDebt'). However, a +-- special union level remains. +prop_union_complete :: LSMConfig -> NestedUnionData -> Property +prop_union_complete conf nestedUnionData = QC.ioProperty $ runWithTracer $ \tr -> stToIO $ do - ts <- traverse (uncurry $ mkTable tr) (zip [LSM.TableId 0..] kess) - t <- LSM.unions tr (LSM.TableId (length kess)) ts + tidCounter <- newSTRef (LSM.TableId 0) + t <- mkNestedUnion tr conf tidCounter nestedUnionData + rep <- dumpRepresentation t debt@(UnionDebt x) <- LSM.remainingUnionDebt t - _ <- LSM.supplyUnionCredits t (UnionCredits x) + + leftovers <- LSM.supplyUnionCredits tr t (UnionCredits x) + + rep' <- dumpRepresentation t debt' <- LSM.remainingUnionDebt t - rep <- dumpRepresentation t pure $ QC.counterexample (show (debt, debt')) $ QC.conjoin - [ debt =/= UnionDebt 0 - , debt' === UnionDebt 0 - , hasUnionWith isCompleted rep + [ QC.counterexample "before" $ + -- The input is a non-empty list of structurally non-empty tables + -- (i.e. they have runs or at least a non-empty write buffer). + -- Therefore there must be a merging tree. + debt =/= UnionDebt 0 + .&&. hasUnionLevelWith (not . isCompleted) rep + , QC.counterexample "after" $ + debt' === UnionDebt 0 + .&&. hasNoUnionLevel rep' + , QC.counterexample "leftovers" $ + leftovers >= 0 ] where isCompleted = \case MLeaf{} -> True MNode{} -> False -mkTable :: Tracer (ST s) Event -> LSM.TableId -> [(LSM.Key, LSM.Entry)] -> ST s (LSM s) -mkTable tr tid ks = do - t <- LSM.new tr tid + +-- | For simplicity, this is not a recursive structure. We just nest once, or +-- not at all if there is just a single 'UnionData'. +newtype NestedUnionData = NestedUnionData [UnionData] + deriving stock Show + +instance Arbitrary NestedUnionData where + arbitrary = do + numUnionInputs <- QC.chooseInt (1, 10) + NestedUnionData <$> QC.vectorOf numUnionInputs arbitrary + + shrink (NestedUnionData unionInputs) = + [ NestedUnionData unionInputs' + | unionInputs' <- shrink unionInputs + , not (null unionInputs') + ] + +-- | Inputs to a union, plus some extra updates to perform on the result. +-- Note that we want at least two inputs, so there is some merging required. +data UnionData = UnionData [(LSM.Key, LSM.Entry)] [TableData] + deriving stock Show + +unionDataInvariant :: UnionData -> Bool +unionDataInvariant (UnionData _ tableInputs) = length tableInputs >= 2 + +instance Arbitrary UnionData where + arbitrary = do + numUnionInputs <- QC.oneof [pure 2, QC.chooseInt (3, 6)] + UnionData <$> arbitrary <*> QC.vectorOf numUnionInputs arbitrary + + shrink (UnionData kes tableInputs) = + [ data' + | (kes', tableInputs') <- shrink (kes, tableInputs) + , let data' = UnionData kes' tableInputs' + , unionDataInvariant data' + ] + +newtype TableData = TableData [(LSM.Key, LSM.Entry)] + deriving stock Show + deriving Arbitrary + via QC.NonEmptyList (LSM.Key, LSM.Entry) + +mkNestedUnion :: Tracer (ST s) Event -> LSMConfig -> STRef s LSM.TableId + -> NestedUnionData -> ST s (LSM s) +mkNestedUnion tr conf tidCounter (NestedUnionData unionInputs) = do + tid <- freshTableId tidCounter + ts <- traverse (mkUnion tr conf tidCounter) unionInputs + LSM.unions tr tid ts + +mkUnion :: Tracer (ST s) Event -> LSMConfig -> STRef s LSM.TableId + -> UnionData -> ST s (LSM s) +mkUnion tr conf tidCounter (UnionData kes tableInputs) = do + tid <- freshTableId tidCounter + ts <- traverse (mkTable tr conf tidCounter) tableInputs + table <- LSM.unions tr tid ts + LSM.updates tr table kes + pure table + +mkTable :: Tracer (ST s) Event -> LSMConfig -> STRef s LSM.TableId + -> TableData -> ST s (LSM s) +mkTable tr conf tidCounter (TableData ks) = do + tid <- freshTableId tidCounter + t <- LSM.newWith tr tid conf LSM.updates tr t ks pure t +freshTableId :: STRef s LSM.TableId -> ST s LSM.TableId +freshTableId ref = do + tid <- readSTRef ref + modifySTRef' ref succ + pure tid + ------------------------------------------------------------------------------- -- tests for MergingTree -- @@ -448,7 +528,7 @@ -- genMergeCreditForRuns :: [NonEmptyRun] -> QC.Gen (MergeDebt, MergeCredit) genMergeCreditForRuns rs = do - let totalDebt = sum (map (length . getNonEmptyRun) rs) + let totalDebt = sum (map (runSize . getNonEmptyRun) rs) suppliedCredits <- QC.chooseInt (0, totalDebt-1) unspentCredits <- QC.chooseInt (0, min (mergeBatchSize-1) suppliedCredits) let spentCredits = suppliedCredits - unspentCredits @@ -472,7 +552,7 @@ shrinkMergeCreditForRuns rs' MergeCredit {spentCredits, unspentCredits} = [ assert (mergeDebtInvariant md' mc') (md', mc') - | let totalDebt' = sum (map (length . getNonEmptyRun) rs') + | let totalDebt' = sum (map (runSize . getNonEmptyRun) rs') , suppliedCredits' <- shrink (min (spentCredits+unspentCredits) (totalDebt'-1)) , unspentCredits' <- shrink (min unspentCredits suppliedCredits') @@ -487,8 +567,8 @@ ] instance Arbitrary NonEmptyRun where - arbitrary = NonEmptyRun <$> (arbitrary `QC.suchThat` (not . null)) - shrink (NonEmptyRun r) = [NonEmptyRun r' | r' <- shrink r, not (null r')] + arbitrary = NonEmptyRun <$> (arbitrary `QC.suchThat` (\r -> runSize r > 0)) + shrink (NonEmptyRun r) = [NonEmptyRun r' | r' <- shrink r, runSize r' > 0] prop_arbitrarySatisfiesInvariant :: T -> Property prop_arbitrarySatisfiesInvariant t = @@ -551,10 +631,16 @@ , "actual shape: " <> show shape ] -hasUnionWith :: (MTree Int -> Bool) -> Representation -> Property -hasUnionWith p rep = do +hasNoUnionLevel :: Representation -> Property +hasNoUnionLevel rep = do let (_, _, shape) = representationShape rep - QC.counterexample "expected suitable Union" $ + QC.counterexample "expected no union level" $ + Nothing === shape + +hasUnionLevelWith :: (MTree Int -> Bool) -> Representation -> Property +hasUnionLevelWith p rep = do + let (_, _, shape) = representationShape rep + QC.counterexample "expected suitable union level" $ QC.counterexample (show shape) $ case shape of Nothing -> False diff --git a/test-prototypes/Test/ScheduledMergesDL.hs b/test-prototypes/Test/ScheduledMergesDL.hs new file mode 100644 --- /dev/null +++ b/test-prototypes/Test/ScheduledMergesDL.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.ScheduledMergesDL (tests) where + +import ScheduledMerges as LSM +import Test.ScheduledMergesQLS as QLS (Action (..), Model, prop_LSM) + +import Test.QuickCheck (NonNegative (..), Property) +import Test.QuickCheck.DynamicLogic +import Test.QuickCheck.StateModel.Lockstep hiding (ModelOp) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +tests :: TestTree +tests = testGroup "Test.ScheduledMergesDL" [ + testProperty "prop_empty_union" prop_empty_union + ] + +instance DynLogicModel (Lockstep Model) + +prop_empty_union :: Property +prop_empty_union = forAllDL dl_empty_union prop_LSM + +-- | Create a table with an empty run in the union level, then run arbitrary +-- actions to see if all invariants still hold. +dl_empty_union :: DL (Lockstep Model) () +dl_empty_union = do + -- Create a union level that will result in an empty run. This is easy to + -- achieve if the inputs to the union only contain deletes (which will get + -- removed in a last level merge, which the union merges are). + tInput <- action $ ANew conf + _ <- action $ ADelete (unsafeMkGVar tInput opIdentity) (Right (K 0)) + tUnion <- action $ AUnions [unsafeMkGVar tInput opIdentity, unsafeMkGVar tInput opIdentity] + + -- Perform some actions so tUnion gets regular levels as well. + anyActions_ + + -- Now complete the union. + _ <- action $ ASupplyUnion (unsafeMkGVar tUnion opIdentity) (NonNegative (UnionCredits 100)) + + anyActions_ + where + conf = + LSMConfig + { configMaxWriteBufferSize = 2 + , configSizeRatio = 2 + } diff --git a/test-prototypes/Test/ScheduledMergesQLS.hs b/test-prototypes/Test/ScheduledMergesQLS.hs --- a/test-prototypes/Test/ScheduledMergesQLS.hs +++ b/test-prototypes/Test/ScheduledMergesQLS.hs @@ -3,7 +3,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Test.ScheduledMergesQLS (tests) where +module Test.ScheduledMergesQLS ( + tests + , Model + , prop_LSM + , Action (..) + ) where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.ST @@ -404,7 +409,7 @@ AUnions vars -> do tid <- incrTidVar tidVar stToIO $ unions tr tid (map lookUpVar vars) - ASupplyUnion var c -> stToIO $ supplyUnionCredits (lookUpVar var) (getNonNegative c) >> pure () + ASupplyUnion var c -> stToIO $ supplyUnionCredits tr (lookUpVar var) (getNonNegative c) >> pure () ADump var -> stToIO $ logicalValue (lookUpVar var) where lookUpVar :: ModelVar Model a -> a diff --git a/test/Database/LSMTree/Model/Session.hs b/test/Database/LSMTree/Model/Session.hs --- a/test/Database/LSMTree/Model/Session.hs +++ b/test/Database/LSMTree/Model/Session.hs @@ -598,7 +598,7 @@ }) openTableFromSnapshot :: - forall k v b m.( + forall k v b m. ( MonadState Model m , MonadError Err m , C k v b diff --git a/test/Test/Database/LSMTree/Internal/BloomFilter.hs b/test/Test/Database/LSMTree/Internal/BloomFilter.hs --- a/test/Test/Database/LSMTree/Internal/BloomFilter.hs +++ b/test/Test/Database/LSMTree/Internal/BloomFilter.hs @@ -44,6 +44,8 @@ prop_total_deserialisation_whitebox , testProperty "bloomQueries (bulk)" $ prop_bloomQueries + , testProperty "prop_packUnpack_RunIxKeyIx" prop_packUnpack_RunIxKeyIx + , testProperty "prop_packUnpack_RunIxKeyIx_limits" prop_packUnpack_RunIxKeyIx_limits ] testSalt :: Bloom.Salt @@ -168,3 +170,50 @@ === map (\(RunIxKeyIx rix kix) -> (rix, kix)) (VP.toList (bloomQueries testSalt (V.fromList filters') (V.fromList keys'))) + +{------------------------------------------------------------------------------- + RunIxKeyIx +-------------------------------------------------------------------------------} + +-- | Test that 'RunIx' and 'KeyIx' roundtrip through the 'RunIxKeyIx' pattern +-- synonym +-- +-- More specifically, if we apply a 'RunIxKeyIx' pattern synonym to a pair of +-- 'RunIx' and 'KeyIx', and then pattern match on it agains, then we would +-- expect to get the same 'RunIx' and 'KeyIx' out as the ones we put in. +-- +-- There used to be a bug where this went wrong because of a typo in a bit-mask. +-- This property test should ensure that we catch such mistakes in the future. +-- See PR #841 for more information. +-- +-- +-- +prop_packUnpack_RunIxKeyIx :: Int_0xffff -> Int_0xffff -> Property +prop_packUnpack_RunIxKeyIx r k = + case RunIxKeyIx r.unwrap k.unwrap of + RunIxKeyIx r' k' -> r.unwrap === r' .&&. k.unwrap === k' + +-- | A variant of 'prop_packUnpack_RunIxKeyIx' applied to 'RunIx' and 'KeyIx' +-- that are close to their upper bounds. +prop_packUnpack_RunIxKeyIx_limits :: Property +prop_packUnpack_RunIxKeyIx_limits = conjoin [ + prop_packUnpack_RunIxKeyIx 0xffff 0xffff + , prop_packUnpack_RunIxKeyIx (0xffff - 1) 0xffff + , prop_packUnpack_RunIxKeyIx 0xffff (0xffff - 1) + , prop_packUnpack_RunIxKeyIx (0xffff - 1) (0xffff - 1) + ] + +-- | An Int in the inclusive range @(0, 0xffff)@ +newtype Int_0xffff = Int_0xffff { unwrap :: Int } + deriving stock (Show, Eq) + deriving newtype Num + +instance Arbitrary Int_0xffff where + arbitrary = Int_0xffff <$> chooseInt (0, 0xffff) + shrink x = [ + Int_0xffff y + | y <- shrink x.unwrap + , 0 <= y + , y < 0xffff + ] + diff --git a/test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs b/test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs --- a/test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs +++ b/test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs @@ -7,9 +7,11 @@ , Annotation ) where +import Codec.CBOR.Read (deserialiseFromBytes) import Codec.CBOR.Write (toLazyByteString) import Control.Monad (when) -import qualified Data.ByteString.Lazy as BSL (writeFile) +import Control.Monad.Class.MonadThrow (Exception (displayException)) +import qualified Data.ByteString.Lazy as BSL import qualified Data.Set as Set import Data.Typeable import qualified Data.Vector as V @@ -38,14 +40,22 @@ import qualified Test.Tasty as Tasty import Test.Tasty (TestTree, testGroup) import qualified Test.Tasty.Golden as Au +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, + testCase) import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests = - handleOutputFiles $ - testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec.Golden" $ - concat (forallSnapshotTypes snapshotCodecGoldenTest) - ++ [testProperty "prop_noUnexpectedOrMissingGoldenFiles" prop_noUnexpectedOrMissingGoldenFiles] + testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec.Golden" [ + handleOutputFiles $ + testGroup "Generate golden files" $ + concat (forallSnapshotTypes snapshotCodecGoldenTest) ++ + [ testProperty "prop_noUnexpectedOrMissingGoldenFiles" prop_noUnexpectedOrMissingGoldenFiles + ] + , testGroup "Backwards compatibility" [ + testCase "test_compatTableConfigV0" test_compatTableConfigV0 + ] + ] {------------------------------------------------------------------------------- Configuration @@ -74,12 +84,12 @@ -> [TestTree] snapshotCodecGoldenTest proxy = [ go annotation datum - | (annotation, datum) <- enumGoldenAnnotated' proxy + | (annotation, datum) <- enumGoldenAnnotated' proxy v ] where + v = currentSnapshotVersion go ann datum = - let v = currentSnapshotVersion - outputFilePath = goldenDataFilePath filePathOutput proxy ann v + let outputFilePath = goldenDataFilePath filePathOutput proxy ann v goldenFilePath = goldenDataFilePath filePathGolden proxy ann v -- IO actions @@ -99,10 +109,11 @@ -- | Check that are no missing or unexpected files in the output directory prop_noUnexpectedOrMissingGoldenFiles :: Property prop_noUnexpectedOrMissingGoldenFiles = once $ ioProperty $ do - let expectedFiles = Set.fromList $ concat $ forallSnapshotTypes $ \p -> concat [ - filePathsGolden p v - | v <- supportedVersions p - ] + let expectedFiles = Set.fromList $ concat $ forallSnapshotTypes $ \p -> + concat [ + filePathsGolden p v + | v <- allCompatibleSnapshotVersions + ] let hfs = ioHasFS goldenDataMountPoint actualDirectoryEntries <- FS.listDirectory hfs (FS.mkFsPath []) @@ -122,6 +133,43 @@ pure $ propMissing .&&. propUnexpected {------------------------------------------------------------------------------- + Backwards compatibility tests +-------------------------------------------------------------------------------} + +test_compatTableConfigV0 :: Assertion +test_compatTableConfigV0 = + assertGoldenFileDecodesTo (Proxy @TableConfig) "A" V0 $ + TableConfig { + confMergePolicy = singGolden V0 + , confMergeSchedule = singGolden V0 + , confSizeRatio = singGolden V0 + , confWriteBufferAlloc = singGolden V0 + , confBloomFilterAlloc = singGolden V0 + , confFencePointerIndex = singGolden V0 + , confDiskCachePolicy = singGolden V0 + -- MergeBatchSize not included in V0, decoder uses WriteBufferAlloc + , confMergeBatchSize = MergeBatchSize magicNumber2 + } + +-- | For types that changed their snapshot format between versions, we should +-- also test that we can in fact still decode the old format. +assertGoldenFileDecodesTo :: + (DecodeVersioned a, Eq a, Show a, Typeable a) + => Proxy a + -> String + -> SnapshotVersion + -> a + -> Assertion +assertGoldenFileDecodesTo proxy ann v expected = do + let fp = goldenDataFilePath filePathGolden proxy ann v + lbs <- BSL.readFile fp + case deserialiseFromBytes (decodeVersioned v) lbs of + Left err -> + assertFailure $ "Error decoding " ++ fp ++ ": " ++ displayException err + Right (_, decoded) -> + assertEqual "" expected decoded + +{------------------------------------------------------------------------------- Mapping -------------------------------------------------------------------------------} @@ -206,31 +254,32 @@ -- -- The default implementation is to return a singleton list containing -- 'singGolden'. - enumGolden :: [a] - enumGolden = [ singGolden ] + enumGolden :: SnapshotVersion -> [a] + enumGolden v = [ singGolden v ] -- | Enumerated values with an annotation for naming purposes. The enumeration -- should be /shallow/, and the annotations should be unique. -- -- The default implementation is to annotate 'enumGolden' with capital letters -- starting with @\'A\'@. - enumGoldenAnnotated :: [(Annotation, a)] - enumGoldenAnnotated = zip [[c] | c <- ['A' .. 'Z']] enumGolden + enumGoldenAnnotated :: SnapshotVersion -> [(Annotation, a)] + enumGoldenAnnotated v = zip [[c] | c <- ['A' .. 'Z']] (enumGolden v) -- | A singleton enumerated value. This is mainly useful for superclass -- instances. -- -- The default implementation is to take the 'head' of 'enumGoldenAnnotated'. - singGolden :: a - singGolden = snd $ head enumGoldenAnnotated - - supportedVersions :: Proxy a -> [SnapshotVersion] - supportedVersions _ = allCompatibleSnapshotVersions + singGolden :: SnapshotVersion -> a + singGolden v = snd $ head (enumGoldenAnnotated v) type Annotation = String -enumGoldenAnnotated' :: EnumGolden a => Proxy a -> [(Annotation, a)] -enumGoldenAnnotated' _ = enumGoldenAnnotated +enumGoldenAnnotated' :: + EnumGolden a + => Proxy a + -> SnapshotVersion + -> [(Annotation, a)] +enumGoldenAnnotated' _ v = enumGoldenAnnotated v {------------------------------------------------------------------------------- Enumeration class: names and file paths @@ -250,7 +299,7 @@ -> [String] filePathsGolden p v = [ filePathGolden p annotation v - | (annotation, _) <- enumGoldenAnnotated' p + | (annotation, _) <- enumGoldenAnnotated' p v ] filePathOutput :: Typeable a => Proxy a -> String -> SnapshotVersion -> String @@ -264,13 +313,14 @@ -------------------------------------------------------------------------------} instance EnumGolden SnapshotMetaData where - singGolden = SnapshotMetaData singGolden singGolden singGolden singGolden singGolden + singGolden v = SnapshotMetaData (singGolden v) (singGolden v) (singGolden v) + (singGolden v) (singGolden v) where _coveredAllCases = \case SnapshotMetaData{} -> () instance EnumGolden SnapshotLabel where - enumGolden = [ + enumGolden _v = [ SnapshotLabel "UserProvidedLabel" , SnapshotLabel "" ] @@ -279,47 +329,48 @@ SnapshotLabel{} -> () instance EnumGolden TableConfig where - singGolden = TableConfig singGolden singGolden singGolden singGolden - singGolden singGolden singGolden singGolden + singGolden v = TableConfig (singGolden v) (singGolden v) (singGolden v) + (singGolden v) (singGolden v) (singGolden v) + (singGolden v) (singGolden v) where _coveredAllCases = \case TableConfig{} -> () instance EnumGolden MergePolicy where - singGolden = LazyLevelling + singGolden _v = LazyLevelling where _coveredAllCases = \case LazyLevelling{} -> () instance EnumGolden SizeRatio where - singGolden = Four + singGolden _v = Four where _coveredAllCases = \case Four{} -> () instance EnumGolden WriteBufferAlloc where - singGolden = AllocNumEntries magicNumber2 + singGolden _v = AllocNumEntries magicNumber2 where _coveredAllCases = \case AllocNumEntries{} -> () instance EnumGolden BloomFilterAlloc where - enumGolden = [ AllocFixed magicNumber3, AllocRequestFPR pi ] + enumGolden _v = [ AllocFixed magicNumber3, AllocRequestFPR pi ] where _coveredAllCases = \case AllocFixed{} -> () AllocRequestFPR{} -> () instance EnumGolden FencePointerIndexType where - enumGolden = [ CompactIndex, OrdinaryIndex ] + enumGolden _v = [ CompactIndex, OrdinaryIndex ] where _coveredAllCases = \case CompactIndex{} -> () OrdinaryIndex{} -> () instance EnumGolden DiskCachePolicy where - enumGolden = [ DiskCacheAll, DiskCacheLevelOneTo magicNumber3, DiskCacheNone ] + enumGolden _v = [ DiskCacheAll, DiskCacheLevelOneTo magicNumber3, DiskCacheNone ] where _coveredAllCases = \case DiskCacheAll{} -> () @@ -327,32 +378,34 @@ DiskCacheNone{} -> () instance EnumGolden MergeSchedule where - enumGolden = [ OneShot, Incremental ] + enumGolden _v = [ OneShot, Incremental ] where _coveredAllCases = \case OneShot{} -> () Incremental{} -> () instance EnumGolden MergeBatchSize where - enumGolden = map MergeBatchSize [ 1, 1000 ] - supportedVersions _ = [V1] + enumGolden v + | v >= V1 = map MergeBatchSize [ 1, 1000 ] + | otherwise = [] instance EnumGolden (SnapLevels SnapshotRun) where - singGolden = SnapLevels singGolden + singGolden v = SnapLevels (singGolden v) where _coveredAllCases = \case SnapLevels{} -> () instance EnumGolden (SnapLevel SnapshotRun) where - singGolden = SnapLevel singGolden singGolden + singGolden v = SnapLevel (singGolden v) (singGolden v) where _coveredAllCases = \case SnapLevel{} -> () instance EnumGolden (SnapIncomingRun SnapshotRun) where - enumGolden = [ - SnapIncomingMergingRun singGolden singGolden singGolden singGolden - , SnapIncomingSingleRun singGolden + enumGolden v = [ + SnapIncomingMergingRun (singGolden v) (singGolden v) (singGolden v) + (singGolden v) + , SnapIncomingSingleRun (singGolden v) ] where _coveredAllCases = \case @@ -360,30 +413,30 @@ SnapIncomingSingleRun{} -> () instance EnumGolden MergePolicyForLevel where - enumGolden = [ LevelTiering, LevelLevelling ] + enumGolden _v = [ LevelTiering, LevelLevelling ] where _coveredAllCases = \case LevelTiering -> () LevelLevelling -> () instance EnumGolden LevelMergeType where - enumGolden = [ MergeMidLevel, MergeLastLevel ] + enumGolden _v = [ MergeMidLevel, MergeLastLevel ] where _coveredAllCases = \case MergeMidLevel{} -> () MergeLastLevel{} -> () instance EnumGolden (SnapMergingTree SnapshotRun) where - singGolden = SnapMergingTree singGolden + singGolden v = SnapMergingTree (singGolden v) where _coveredAllCases = \case SnapMergingTree{} -> () instance EnumGolden (SnapMergingTreeState SnapshotRun) where - enumGolden = [ - SnapCompletedTreeMerge singGolden - , SnapPendingTreeMerge singGolden - , SnapOngoingTreeMerge singGolden + enumGolden v = [ + SnapCompletedTreeMerge (singGolden v) + , SnapPendingTreeMerge (singGolden v) + , SnapOngoingTreeMerge (singGolden v) ] where _coveredAllCases = \case @@ -392,9 +445,9 @@ SnapOngoingTreeMerge{} -> () instance EnumGolden (SnapPendingMerge SnapshotRun) where - enumGolden = [ - SnapPendingLevelMerge singGolden singGolden - , SnapPendingUnionMerge singGolden + enumGolden v = [ + SnapPendingLevelMerge (singGolden v) (singGolden v) + , SnapPendingUnionMerge (singGolden v) ] where _coveredAllCases = \case @@ -402,9 +455,9 @@ SnapPendingUnionMerge{} -> () instance EnumGolden (SnapPreExistingRun SnapshotRun) where - enumGolden = [ - SnapPreExistingRun singGolden - , SnapPreExistingMergingRun singGolden + enumGolden v = [ + SnapPreExistingRun (singGolden v) + , SnapPreExistingMergingRun (singGolden v) ] where _coveredAllCases = \case @@ -412,43 +465,44 @@ SnapPreExistingMergingRun{} -> () instance EnumGolden TreeMergeType where - enumGolden = [ MergeLevel, MergeUnion ] + enumGolden _v = [ MergeLevel, MergeUnion ] where _coveredAllCases = \case MergeLevel{} -> () MergeUnion{} -> () instance EnumGolden a => EnumGolden (Maybe a) where - enumGolden = [ Just singGolden, Nothing ] + enumGolden v = [ Just (singGolden v), Nothing ] where _coveredAllCases = \case Just{} -> () Nothing{} -> () instance EnumGolden a => EnumGolden (V.Vector a) where - enumGolden = [ - V.fromList [ singGolden, singGolden ] + enumGolden v = [ + V.fromList [ singGolden v, singGolden v ] , mempty - , V.fromList [ singGolden ] + , V.fromList [ singGolden v ] ] instance EnumGolden a => EnumGolden [a] where - enumGolden = [ - [singGolden, singGolden] + enumGolden v = [ + [ singGolden v, singGolden v ] , [] - , [singGolden] + , [ singGolden v] ] instance EnumGolden RunParams where - singGolden = RunParams singGolden singGolden singGolden + singGolden v = RunParams (singGolden v) (singGolden v) (singGolden v) where _coveredAllCases = \case RunParams{} -> () instance EnumGolden t => EnumGolden (SnapMergingRun t SnapshotRun) where - enumGolden = [ - SnapCompletedMerge singGolden singGolden - , SnapOngoingMerge singGolden singGolden singGolden singGolden + enumGolden v = [ + SnapCompletedMerge (singGolden v) (singGolden v) + , SnapOngoingMerge (singGolden v) (singGolden v) (singGolden v) + (singGolden v) ] where _coveredAllCases = \case @@ -456,7 +510,7 @@ SnapOngoingMerge{} -> () instance EnumGolden RunBloomFilterAlloc where - enumGolden = [ + enumGolden _v = [ RunAllocFixed magicNumber3 , RunAllocRequestFPR pi ] @@ -466,13 +520,13 @@ RunAllocRequestFPR{} -> () instance EnumGolden RunNumber where - singGolden = RunNumber magicNumber3 + singGolden _v = RunNumber magicNumber3 where _coveredAllCases = \case RunNumber{} -> () instance EnumGolden IndexType where - enumGolden = [ + enumGolden _v = [ Compact , Ordinary ] @@ -482,7 +536,7 @@ Ordinary{} -> () instance EnumGolden RunDataCaching where - enumGolden = [ + enumGolden _v = [ CacheRunData , NoCacheRunData ] @@ -492,31 +546,31 @@ NoCacheRunData{} -> () instance EnumGolden SnapshotRun where - singGolden = SnapshotRun singGolden singGolden singGolden + singGolden v = SnapshotRun (singGolden v) (singGolden v) (singGolden v) where _coveredAllCases = \case SnapshotRun{} -> () instance EnumGolden MergeDebt where - singGolden = MergeDebt magicNumber2 + singGolden _v = MergeDebt magicNumber2 where _coveredAllCases = \case MergeDebt{} -> () instance EnumGolden MergeCredits where - singGolden = MergeCredits magicNumber2 + singGolden _v = MergeCredits magicNumber2 where _coveredAllCases = \case MergeCredits{} -> () instance EnumGolden NominalDebt where - singGolden = NominalDebt magicNumber2 + singGolden _v = NominalDebt magicNumber2 where _coveredAllCases = \case NominalDebt{} -> () instance EnumGolden NominalCredits where - singGolden = NominalCredits magicNumber1 + singGolden _v = NominalCredits magicNumber1 where _coveredAllCases = \case NominalCredits{} -> ()