From 55c4b99e3e569c168de38f6d351507236d027f49 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 26 Jun 2025 12:31:46 +0200 Subject: [PATCH] Allow IOG's contra-tracer --- bench/macro/lsm-tree-bench-wp8.hs | 8 ++++++++ lsm-tree.cabal | 2 +- src/Database/LSMTree/Internal/Unsafe.hs | 5 +++++ test-prototypes/Test/ScheduledMerges.hs | 10 +++++++++- test/Test/Database/LSMTree.hs | 16 +++++++++++----- 5 files changed, 34 insertions(+), 7 deletions(-) diff --git a/bench/macro/lsm-tree-bench-wp8.hs b/bench/macro/lsm-tree-bench-wp8.hs index 2ec493a56..bb24d6708 100644 --- a/bench/macro/lsm-tree-bench-wp8.hs +++ b/bench/macro/lsm-tree-bench-wp8.hs @@ -211,6 +211,7 @@ mkTableConfigOverride GlobalOpts{diskCachePolicy} RunOpts {pipelined} = mkTracer :: GlobalOpts -> Tracer IO LSM.LSMTreeTrace mkTracer gopts | trace gopts = +#if MIN_VERSION_contra_tracer(0,2,0) -- Don't trace update/lookup messages, because they are too noisy squelchUnless (\case @@ -218,6 +219,13 @@ mkTracer gopts LSM.TraceTable _ LSM.TraceLookups{} -> False _ -> True ) (show `contramap` stdoutTracer) +#else + Tracer $ + \case + LSM.TraceTable _ LSM.TraceUpdates{} -> pure () + LSM.TraceTable _ LSM.TraceLookups{} -> pure () + e -> traceWith (show `contramap` stdoutTracer) e +#endif | otherwise = nullTracer ------------------------------------------------------------------------------- diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 5acd79f27..9a10cd55f 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -613,7 +613,7 @@ library , bytestring ^>=0.11.4.0 || ^>=0.12.1.0 , cborg ^>=0.2.10.0 , containers ^>=0.6 || ^>=0.7 - , contra-tracer ^>=0.2 + , contra-tracer ^>=0.1 || ^>=0.2 , crc32c ^>=0.2.1 , deepseq ^>=1.4 || ^>=1.5 , filepath diff --git a/src/Database/LSMTree/Internal/Unsafe.hs b/src/Database/LSMTree/Internal/Unsafe.hs index eb79b11a2..eae72be55 100644 --- a/src/Database/LSMTree/Internal/Unsafe.hs +++ b/src/Database/LSMTree/Internal/Unsafe.hs @@ -202,12 +202,17 @@ data TableTrace = | TraceSupplyUnionCredits UnionCredits deriving stock Show +#if MIN_VERSION_contra_tracer(0,2,0) contramapTraceMerge :: Monad m => Tracer m TableTrace -> Tracer m (AtLevel MergeTrace) #ifdef DEBUG_TRACES contramapTraceMerge t = TraceMerge `contramap` t #else contramapTraceMerge t = traceMaybe (const Nothing) t #endif +#else +contramapTraceMerge :: Applicative m => Tracer m TableTrace -> Tracer m (AtLevel MergeTrace) +contramapTraceMerge _t = nullTracer +#endif data CursorTrace = TraceCreateCursor TableId diff --git a/test-prototypes/Test/ScheduledMerges.hs b/test-prototypes/Test/ScheduledMerges.hs index bcce9c836..38168817b 100644 --- a/test-prototypes/Test/ScheduledMerges.hs +++ b/test-prototypes/Test/ScheduledMerges.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE CPP #-} + module Test.ScheduledMerges (tests) where import Control.Exception import Control.Monad (replicateM_, when) import Control.Monad.ST import Control.Tracer (Tracer (Tracer)) +#if MIN_VERSION_contra_tracer(0,2,0) import qualified Control.Tracer as Tracer +#endif import Data.Foldable (find, traverse_) import Data.Maybe (fromJust) import Data.STRef @@ -526,7 +530,11 @@ genShrinkTrace !n x runWithTracer :: (Tracer (ST RealWorld) Event -> IO a) -> IO a runWithTracer action = do events <- stToIO $ newSTRef [] - let tracer = Tracer $ Tracer.emit $ \e -> modifySTRef events (e :) + let tracer = Tracer $ +#if MIN_VERSION_contra_tracer(0,2,0) + Tracer.emit $ +#endif + \e -> modifySTRef events (e :) action tracer `catch` \e -> do if isDiscard e -- don't intercept these then throwIO e diff --git a/test/Test/Database/LSMTree.hs b/test/Test/Database/LSMTree.hs index a645395b9..2fa0c1d30 100644 --- a/test/Test/Database/LSMTree.hs +++ b/test/Test/Database/LSMTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -134,11 +135,16 @@ prop_openSession_restoreSession = -- | A tracer that records session open, session new, and session restore -- messages in a mutable variable. mkSessionOpenModeTracer :: IORef [String] -> Tracer IO LSMTreeTrace -mkSessionOpenModeTracer var = Tracer $ emit $ \case - TraceOpenSession{} -> modifyIORef var ("Open" :) - TraceNewSession{} -> modifyIORef var ("New" :) - TraceRestoreSession{} -> modifyIORef var ("Restore" :) - _ -> pure () +mkSessionOpenModeTracer var = + Tracer $ +#if MIN_VERSION_contra_tracer(0,2,0) + emit $ +#endif + \case + TraceOpenSession{} -> modifyIORef var ("Open" :) + TraceNewSession{} -> modifyIORef var ("New" :) + TraceRestoreSession{} -> modifyIORef var ("Restore" :) + _ -> pure () {------------------------------------------------------------------------------- Session: happy path