packages feed

trace-embrace 1.0.11 → 1.1.0

raw patch · 9 files changed

+176/−40 lines, 9 files

Files

changelog.md view
@@ -1,5 +1,8 @@ # trace-embrace changelog +## Version 1.1.0 2025-06-04+  * add `a`, `u` and `tg` for tracing guarded functions+ ## 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
src/Debug/TraceEmbrace/FileIndex.hs view
@@ -28,7 +28,7 @@ import Unsafe.Coerce  -newtype FunName = FunName String deriving (Show, Eq, Ord, IsString, Lift)+newtype FunName = FunName { unFunName :: String } deriving (Show, Eq, Ord, IsString, Lift) type LineFileIndex = IM.IntMap FunName  unsafeRunTcM :: TcM a -> Q a
src/Debug/TraceEmbrace/Internal/TH.hs view
@@ -25,8 +25,8 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Printf -newtype TrMsgAndVars = TrMsgAndVars String deriving (Eq, P.Show)-newtype VarsPart = VarsPart String deriving (Eq, P.Show)+data TrMsgAndVars = TrMsgAndVars [Name] String  deriving (Eq, P.Show)+data VarsPart = VarsPart [Name] String deriving (Eq, P.Show) newtype ModTraceFlagVarName = ModTraceFlagVarName Name deriving (Eq, P.Show)  type SVarsFunM a = StateT (Maybe Name) Q a@@ -110,17 +110,22 @@  -} svars :: SVarsFun-svars tmf (VarsPart vars) = MT.lift $+svars tmf (VarsPart patVars vars) = MT.lift $   case span (';' /=) vars of     (showVars, ';' : traceVars) ->-      [| $(listE (wordsToVars 'show showVars-                   <> wordsToVars 'showTrace traceVars)) :: [String] |]+      [| $(listE (noTraceVars showVars <> wordsToVars 'showTrace traceVars)) :: [String] |]     (showVars, "") ->-      [| $(listE (wordsToVars 'show showVars)) :: [String] |]+      [| $(listE (noTraceVars showVars)) :: [String] |]     (sv, st) -> do       reportError $ printf "No case for %s %s" sv st       [| [] |]   where+    noTraceVars showVars =+      wordsToVars 'show showVars <> zipWith (name2Var 'show) [0 :: Int ..] patVars++    name2Var f 0 vn = [| $(lift . unrefine $ tmf ^. #entrySeparator) <> $(varE f) $(varE vn) |]+    name2Var f _ vn = [| " " <> $(varE f) $(varE vn) |]+     wordsToVars f vss = fmap go (varNamesFromPat vss)       where         go vs =@@ -136,14 +141,14 @@                |]  splitMessageFromVars :: TrMsgAndVars -> (String, VarsPart)-splitMessageFromVars (TrMsgAndVars trMsg) =+splitMessageFromVars (TrMsgAndVars patVars trMsg) =   case span ('/' /=) trMsg of-    (msgPart, '/':varPart) -> (msgPart, VarsPart varPart)-    (msgPart, []) -> (msgPart, VarsPart [])+    (msgPart, '/':varPart) -> (msgPart, VarsPart patVars varPart)+    (msgPart, []) -> (msgPart, VarsPart patVars [])     e ->  error $ "No case for:" <> show e -traceMessageLevel :: String -> (TraceLevel, TrMsgAndVars)-traceMessageLevel = fmap TrMsgAndVars . charToLevel+traceMessageLevel :: [Name] -> String -> (TraceLevel, TrMsgAndVars)+traceMessageLevel patVars = fmap (TrMsgAndVars patVars) . charToLevel  -- | Suffix 'svars' with return value. svarsWith :: SVarsFun@@ -160,6 +165,19 @@ concat2 = mconcat . mconcat {-# INLINE concat2 #-} +currentFunName :: Q FunName+currentFunName = do+  lc <- location+  let+    m = loc_module lc+    line = fst $ loc_start lc+  fmap snd . IM.lookupLE line <$> getLineFileIndex lc >>= \case+    Nothing -> do+      reportWarning (printf "No function name for line [%d] in module [%s]" line m)+      pure $ FunName "N/A"+    Just fn -> pure fn+  where+ -- | Format whole trace message traceMessage :: TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp traceMessage mavs tmf svarsFun =@@ -185,16 +203,7 @@         (eludom, htap) <- span (/= '.') . reverse . loc_module <$> loc         pStrL $ shortenModPath True (reverse htap) <> (reverse eludom)       PackageName -> strL . loc_package <$> loc-      FunctionName -> do-        lc <- loc-        let-          m = loc_module lc-          line = fst $ loc_start lc-        strL <$> MT.lift (fmap snd . IM.lookupLE line <$> getLineFileIndex lc >>= \case-          Nothing -> do-            reportWarning (printf "No function name for line [%d] in module [%s]" line m)-            pure "N/A"-          Just (FunName fn) -> pure fn)+      FunctionName -> strL <$> MT.lift (unFunName <$> currentFunName)       LineNumber -> strL . P.show . fst . loc_start <$> loc       Delimiter del -> pStrL del @@ -245,8 +254,13 @@           atomicWriteIORef fv (Just False) >> pure False {-# INLINE readTraceFlag #-} -traceG :: TraceEmbraceConfig -> Q Exp -> (TrMsgAndVars -> TraceMessageFormat -> Q Exp) -> String -> Q Exp-traceG c idF genTraceLine s =+traceG :: TraceEmbraceConfig ->+  Q Exp ->+  (TrMsgAndVars -> TraceMessageFormat -> Q Exp) ->+  String ->+  [Name] ->+  Q Exp+traceG c idF genTraceLine s patVars =   case c ^. #mode of     TraceDisabled -> idF     TraceStd -> go@@ -254,7 +268,7 @@     TraceEvent -> go   where     go =-      case traceMessageLevel s of+      case traceMessageLevel patVars s of         (TracingDisabled, _) -> idF         (tl, s') -> do           loc <- location@@ -308,9 +322,12 @@     TraceEvent -> pure $ VarE 'T.traceEvent  tr :: Q Exp -> String -> Q Exp-tr idF rawMsg = do+tr idF rawMsg = tr' idF rawMsg []++tr' :: Q Exp -> String -> [Name]-> Q Exp+tr' idF rawMsg patVars = do   c <- getConfig-  traceG c idF (go c) rawMsg+  traceG c idF (go c) rawMsg patVars   where     go c s fmt =       [| \x -> unwrap ($(chooseTraceFunOnTh c s) $(traceMessage s fmt svars) (wrap x)) |]@@ -318,7 +335,7 @@ tw :: Q Exp -> String -> Q Exp tw idF rawMsg = do   c <- getConfig-  traceG c idF (go c) rawMsg+  traceG c idF (go c) rawMsg []   where     go c s fmt =       [| \x -> unwrap ($(chooseTraceFunOnTh c s)@@ -329,7 +346,7 @@ tw' :: Q Exp -> String -> Q Exp tw' idF rawMsg = do   c <- getConfig-  traceG c idF (go c) rawMsg+  traceG c idF (go c) rawMsg []   where     go c s fmt =       [| \x -> unwrap ($(chooseTraceFunOnTh c s)@@ -348,7 +365,7 @@ trIo :: Q Exp -> String -> Q Exp trIo idF rawMsg = do   c <- getConfig-  traceG c idF (go c) rawMsg+  traceG c idF (go c) rawMsg []   where     go c s fmt =       [| $(chooseTraceIoFunOnTh c s) $(traceMessage s fmt svars) |]@@ -357,7 +374,7 @@ trFunMarker idF = do   c <- getConfig   let finalC = if c ^. #mode == TraceDisabled then c else markerConfig-  traceG finalC idF go "/"+  traceG finalC idF go "/" []   where     go s fmt =       [| \x -> unwrap (T.traceMarker $(traceMessage s fmt svars) (wrap x)) |]@@ -366,7 +383,7 @@ trIoFunMarker idF = do   c <- getConfig   let finalC = if c ^. #mode == TraceDisabled then c else markerConfig-  traceG finalC idF go "/"+  traceG finalC idF go "/" []   where     go s fmt =       [| T.traceMarkerIO $(traceMessage s fmt svars) |]
src/Debug/TraceEmbrace/TH.hs view
@@ -1,14 +1,16 @@ {-# OPTIONS_HADDOCK hide, prune #-}  -- | Tracing with TH-module Debug.TraceEmbrace.TH (tr, tw, tw', trIo, trFunMarker, trIoFunMarker) where+module Debug.TraceEmbrace.TH (tr, tw, tw', trIo, u, a, s_, tg, tg', underbar, trFunMarker, trIoFunMarker) where  import Debug.Trace import Debug.TraceEmbrace.Config+import Debug.TraceEmbrace.FileIndex (FunName (..)) import Debug.TraceEmbrace.Internal.Rewrap import Debug.TraceEmbrace.Internal.TH qualified as I import Haddock.UseRefs import Language.Haskell.TH+import Language.Haskell.TH.Syntax  countDocRefs @@ -24,8 +26,7 @@ -- -- > Module::foo get; x : 132 tr :: String -> Q Exp-tr = I.tr [| \x -> x |]-+tr tm = I.tr [| \x -> x |] tm  -- | TH version of 'traceWith' and 'traceEventWith' -- The message is formatted according to 'TraceMessageFormat'.@@ -66,3 +67,71 @@ -- are used as a marker. Trace level is not used. trIoFunMarker :: Q Exp trIoFunMarker = I.trIoFunMarker [| pure () |]++data ArgPatCounter+  = ArgPatCounter+    { funName :: FunName+    , argNames :: [Name]+    } deriving (Show)++data Undebar = Undebar++instance Show Undebar where+  show _ = "_"++underbar :: Undebar+underbar = Undebar+-- | Generates consequent pattern variable for tracing arguments of a guarded function.+-- It is assumed that 'a' is used together with 'tg' and 'u'.+--+-- > foo $a $a $a | $tg = $u+-- > foo 0  _  _ = 0+-- > foo x y z = x + y + z+--+a :: Q Pat+a = do+  cfn <- I.currentFunName+  getQ >>= \case+    Nothing -> reset cfn+    Just (ArgPatCounter fn aNames)+      | fn == cfn -> go aNames cfn+      | otherwise -> reset cfn+  where+    reset cfn = go [] cfn+    go ans cfn = do+      nn <- newName $ "traceEmbracePatArg" <> (show $ length ans)+      putQ (ArgPatCounter cfn $ nn : ans)+      varP nn++-- | Similar to 'a', but argument is not included in trace message.+s_ :: Q Pat+s_ = do+  cfn <- I.currentFunName+  getQ >>= \case+    Nothing -> reset cfn+    Just (ArgPatCounter fn aNames)+      | fn == cfn -> go aNames cfn+      | otherwise -> reset cfn+  where+    reset cfn = go [] cfn+    go ans cfn = putQ (ArgPatCounter cfn $ 'underbar : ans) >> [p|_|]++-- | Expands to @$(tr "/a b c d...") False@+tg :: Q Exp+tg = tg' ""++-- | Similar to 'tg' with message prefix with the argument.+tg' :: String -> Q Exp+tg' msgPrefix = do+  cfn <- I.currentFunName+  getQ >>= \case+    Nothing -> er+    Just (ArgPatCounter fn aNames)+      | fn == cfn -> [|$(I.tr' [| \x -> x |] msgPrefix $ reverse aNames) False|]+      | otherwise -> er+  where+    er = fail "Use 'Debug.TraceEmbrace.TH.a' macro to capture function arguments before calling 'tg'"++-- | Shortcut for 'undefined'+u :: Q Exp+u = [| undefined |]
test/Debug/TraceEmbrace/Test/TraceEmbrace/Config.hs view
@@ -47,10 +47,10 @@   }  trConstMsg :: String -> Q Exp-trConstMsg msgAndVars = traceMessage (TrMsgAndVars msgAndVars) msgAndVarsOnly svars+trConstMsg msgAndVars = traceMessage (TrMsgAndVars [] msgAndVars) msgAndVarsOnly svars  trFunMsg :: String -> Q Exp-trFunMsg msgAndVars = traceMessage (TrMsgAndVars msgAndVars) msgAndVarsOnly svarsWith+trFunMsg msgAndVars = traceMessage (TrMsgAndVars [] msgAndVars) msgAndVarsOnly svarsWith  one :: Int one = 1
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/GuardedFunction.hs view
@@ -0,0 +1,30 @@+-- {-# OPTIONS_GHC -ddump-splices #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.GuardedFunction where++import Debug.TraceEmbrace+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Language.Haskell.TH.Lock+import Test.Tasty.HUnit ((@=?))++ensureSerialCompilationVerbose++sum4 :: (Show a, Num a) => a -> a -> a -> a -> a+sum4 $a $a $s_ $a | $tg = $u+sum4 a1 a2 a3 a4 = a1 + a2 + a3 + a4++unit_sum4_a_tg_u :: IO ()+unit_sum4_a_tg_u = withPrefixEnvVar thresholdConfig "" $ sum4 one one one one @=? 4++sum1 :: Show a => a -> a+sum1 $a | $tg = $u+sum1 a1 = a1++unit_sum1_a_tg_u :: IO ()+unit_sum1_a_tg_u = withPrefixEnvVar thresholdConfig "" $ sum1 one @=? 1++sum2 :: (Show a, Num a) => a -> a -> a+sum2 $a $a | $(tg' "sum2/") = $u+sum2 a1 a2 = a1 + a2++unit_sum2_a_tg_u :: IO ()+unit_sum2_a_tg_u = withPrefixEnvVar thresholdConfig "" $ sum2 one one @=? 2
test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Format/Lifted.hs view
@@ -13,7 +13,7 @@ unit_traceMessage_const :: IO () unit_traceMessage_const =   ("Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Lifted::unit_traceMessage_const" :: String) @=?-     $(traceMessage (TrMsgAndVars "skipped") positionOnly svars)+     $(traceMessage (TrMsgAndVars [] "skipped") positionOnly svars)  unit_traceMessage_fun :: IO () unit_traceMessage_fun = ("foo => True" :: String) @=?  $(trFunMsg "foo") True
test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Line.hs view
@@ -8,4 +8,4 @@  unit_traceMessage_line :: IO () unit_traceMessage_line =-  ("11:" :: String) @=? $(traceMessage (TrMsgAndVars "skipped") lineOnly svars)+  ("11:" :: String) @=? $(traceMessage (TrMsgAndVars [] "skipped") lineOnly svars)
trace-embrace.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            trace-embrace-version:         1.0.11+version:         1.1.0 license:         BSD-3-Clause license-file:    LICENSE category:        Development@@ -258,6 +258,22 @@          Module:fun: 7 get; x: 1; y: 2; z: 3 => 6     +    === Guarded function+    #guarded-function#+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module Module where+    >+    > import Debug.TraceEmbrace+    >+    > fun :: Int -> Int -> Int -> Int+    > fun $a $a_ $a | $tg = $u+    > fun a b c = a + b + c+    +    A trace line for the snippet above would be:+    +    Module:fun: 7; 1 _ 3+         === Trace lazy ByteString structure     #trace-lazy-bytestring-structure#     @@ -398,6 +414,7 @@     Debug.TraceEmbrace.Test.TraceEmbrace.Config     Debug.TraceEmbrace.Test.TraceEmbrace.DemoIndex     Debug.TraceEmbrace.Test.TraceEmbrace.FileIndex+    Debug.TraceEmbrace.Test.TraceEmbrace.GuardedFunction     Debug.TraceEmbrace.Test.TraceEmbrace.TH     Debug.TraceEmbrace.Test.TraceEmbrace.TH.Event     Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Lifted