trace-embrace 1.0.5 → 1.0.10

raw patch · 10 files changed

+71/−23 lines, 10 filesdep +th-lock

Dependencies added: th-lock

Files

• changelog.md +4/−0
• src/Debug/TraceEmbrace/Config/Load.hs +26/−8
• src/Debug/TraceEmbrace/Config/Type/Mode.hs +1/−1
• src/Debug/TraceEmbrace/Internal/TH.hs +10/−7
• test/Debug/TraceEmbrace/Test/TraceEmbrace/TH.hs +15/−6
• test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Event.hs +3/−0
• test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Format/Lifted.hs +4/−0
• test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Format/Unboxed.hs +4/−0
• test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Threshold.hs +2/−0
• trace-embrace.cabal +2/−1

@@ -1,5 +1,9 @@ # trace-embrace changelog +## Version 1.0.8 2025-03-14+  * bugfix: serialize test compilation with [th-lock](https://hackage.haskell.org/package/th-lock)+  * bugfix: serialize yaml config loading and on demand initialization+ ## Version 1.0.4 2025-03-11   * bugfix: multiple traces on the same line 

@@ -82,10 +82,15 @@ loadYamlConfig :: IO YamlConfig loadYamlConfig = do   doesFileExist fp >>= \case-    True -> configFromJust . (<> defaultYamlConfig) =<< catch (Y.decodeFileThrow fp) badYaml+    True -> do+      putStrLn $ "Loading existish trace-embrace config from [" <> fp <> "]"+      configFromJust . (<> defaultYamlConfig) =<< catch (Y.decodeFileThrow fp) badYaml     False -> do-      Y.encodeFile fp newYamlConfig-      traceIO $ "New default config trace-embrace file is generated: [" <> fp <> "]"+      catch (do+                Y.encodeFile fp newYamlConfig+                putStrLn $ "New default config trace-embrace file is generated: [" <> fp <> "]")+            (\e -> putStrLn $ "Failed to create config file [" <> fp <> "] due: " <>+              prettyPrintParseException e)       configFromJust newYamlConfig   where     configFromJust :: YamlConfigMaybe -> IO YamlConfig@@ -125,17 +130,30 @@   (mkPrefixTree . unrefine $ yc.levels)   (unrefine $ yc.runtimeLevelsOverrideEnvVar) +configReadToken :: MVar ()+configReadToken = unsafePerformIO (newMVar ())+{-# NOINLINE configReadToken #-}+ getConfig :: Q TraceEmbraceConfig getConfig = do-  c <- runIO (readIORef traceEmbraceConfigRef) >>= loadIfNothing+  c <- runIO readConfigRef >>= loadIfNothing   addDependentFile traceEmbraceConfigFileName   pure c   where+    readConfigRef = readIORef traceEmbraceConfigRef     loadIfNothing = \case-      Nothing -> do-        c <- yaml2Config <$> runIO loadYamlConfig-        runIO (atomicWriteIORef traceEmbraceConfigRef (Just c))-        pure c+      Nothing -> runIO $ do+        bracket (takeMVar configReadToken)+          (putMVar configReadToken)+          (\() ->+             readConfigRef >>= \case+               Just c -> do+                 putStrLn "trace-embrace.yaml Config is already loaded after resume"+                 pure c+               Nothing -> do+                 c <- yaml2Config <$> loadYamlConfig+                 (atomicWriteIORef traceEmbraceConfigRef (Just c))+                 pure c)       Just c -> pure c  traceAll :: [LeveledModulePrefix]

@@ -23,7 +23,7 @@   | TraceStd   | TraceUnsafeIo { sink :: IoSink }   | TraceEvent-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Lift)  instance ToJSON SinkMode where   toEncoding = genericToEncoding defaultOptions

@@ -337,18 +337,21 @@                         (wrap x))        |] +chooseTraceIoFunOnTh :: Show s => TraceEmbraceConfig -> s -> Q Exp+chooseTraceIoFunOnTh c s =+  case c ^. #mode of+    TraceDisabled -> fail $ "Dead code on" <> show s+    TraceStd -> pure $ VarE 'T.traceIO+    TraceUnsafeIo snk -> [| hPutStrLn (getSinkHandle snk) |]+    TraceEvent -> pure $ VarE 'T.traceEventIO+ trIo :: Q Exp -> String -> Q Exp trIo idF rawMsg = do   c <- getConfig   traceG c idF (go c) rawMsg   where-    go c s fmt = do-      let trFun = case c ^. #mode of-                    TraceDisabled -> error $ "Dead code on" <> show s-                    TraceStd -> 'T.traceIO-                    TraceUnsafeIo _ -> 'safePutStrLn-                    TraceEvent -> 'T.traceEventIO-      [| $(varE trFun) $(traceMessage s fmt svars) |]+    go c s fmt =+      [| $(chooseTraceIoFunOnTh c s) $(traceMessage s fmt svars) |]  trFunMarker :: Q Exp -> Q Exp trFunMarker idF = do

@@ -1,12 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Debug.TraceEmbrace.Test.TraceEmbrace.TH where  import Data.ByteString.Lazy import Debug.TraceEmbrace import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Language.Haskell.TH.Lock+import Language.Haskell.TH.Syntax import Test.Tasty.HUnit ((@=?)) +ensureSerialCompilationVerbose+ unit_tr_trace :: IO () unit_tr_trace = withPrefixEnvVar thresholdConfig "" $ go one   where@@ -55,9 +60,13 @@     go x = x @=? foo x     foo x = $(tw' "tw foo/x") x --- unit_trIo :: IO ()--- unit_trIo = withPrefixEnvVar thresholdConfig "" $ go one---   where---     go x = (x @=?) =<< foo x---       where---         foo y = $(trIo "foo info/y") >> pure y+unit_trIo :: IO ()+unit_trIo = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = (x @=?) =<< foo x+      where+        foo y = $(trIo "foo info/y") >> pure y++unit_ensure_mode_trace_std :: IO ()+unit_ensure_mode_trace_std =+  $( lift =<< ((.mode) <$> getConfig)  ) @=? TraceStd

@@ -5,8 +5,11 @@ import Debug.TraceEmbrace.Config.Type import Debug.TraceEmbrace.Internal.TH import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Language.Haskell.TH.Lock import Test.Tasty.HUnit ((@=?)) import System.Directory++ensureSerialCompilationVerbose  unit_unsafeio_stderr_mode :: IO () unit_unsafeio_stderr_mode =

@@ -5,10 +5,14 @@ import Data.ByteString.Lazy import Debug.TraceEmbrace.Internal.TH import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Language.Haskell.TH.Lock import Test.Tasty.HUnit ((@=?))  -- not working: https://gitlab.haskell.org/ghc/ghc/-/issues/25775 default (Int)+++ensureSerialCompilationVerbose  unit_traceMessage_const :: IO () unit_traceMessage_const =

@@ -9,7 +9,11 @@ import Debug.TraceEmbrace import Debug.TraceEmbrace.Test.TraceEmbrace.Config import GHC.Exts+import Language.Haskell.TH.Lock import Test.Tasty.HUnit ((@=?))+++ensureSerialCompilationVerbose  unit_unboxed_int :: IO () unit_unboxed_int = "foo; x#: 1#" @=? foo one

@@ -7,10 +7,12 @@ import Debug.TraceEmbrace.Internal.TH qualified as I import Debug.TraceEmbrace.Config import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Language.Haskell.TH.Lock import System.FilePath import System.IO.Temp import Test.Tasty.HUnit ((@=?)) +ensureSerialCompilationVerbose  unit_mode_disabled :: IO () unit_mode_disabled =

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            trace-embrace-version:         1.0.5+version:         1.0.10 license:         BSD-3-Clause license-file:    LICENSE category:        Development@@ -442,6 +442,7 @@     , template-haskell     , temporary < 1.5     , text+    , th-lock < 1.0.0     , trace-embrace     , yaml   default-language: Haskell2010