Allow IOG's contra-tracer

Author: jasagredo

bench/macro/lsm-tree-bench-wp8.hs

@@ -194,13 +194,21 @@ mkOverrideDiskCachePolicy GlobalOpts{diskCachePolicy} = LSM.OverrideDiskCachePol
 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
           LSM.TraceTable _ LSM.TraceUpdates{} -> False
           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
 
 -------------------------------------------------------------------------------

lsm-tree.cabal

@@ -484,6 +484,14 @@ source-repository this
   location: https://github.com/IntersectMBO/lsm-tree
   tag:      lsm-tree-0.1.0.0
 
+flag iog-contra-tracer
+  description: IOG's contra-tracer (https://chap.intersectmbo.org/package/contra-tracer-0.1.0.2/)
+               is slightly different than the one on Hackage. This flag is
+               expected to be switched automatically by Cabal if this library is
+               used in some project which uses the IOG fork of contra-tracer.
+  manual: False
+  default: False
+
 common warnings
   ghc-options:
     -Wall -Wcompat -Wincomplete-uni-patterns
@@ -582,7 +590,6 @@ library
     , bytestring              ^>=0.11.4.0 || ^>=0.12.1.0
     , cborg                   ^>=0.2.10.0
     , containers              ^>=0.6      || ^>=0.7
-    , contra-tracer           ^>=0.2
     , crc32c                  ^>=0.2.1
     , deepseq                 ^>=1.4      || ^>=1.5
     , filepath
@@ -600,6 +607,13 @@ library
     , vector                  ^>=0.13
     , vector-algorithms       ^>=0.9
 
+  if flag(iog-contra-tracer)
+    build-depends:
+      contra-tracer ^>= 0.1
+  else
+    build-depends:
+      contra-tracer ^>= 0.2
+
   if impl(ghc >=9.4)
     other-modules: Database.LSMTree.Internal.StrictArray
     build-depends: data-elevator ^>=0.1.0.2 || ^>=0.2

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

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

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