Skip to content

Commit 37c5f8f

Browse files
dschrempfdschrempf
committed
Tracing: Compute maximum log level of traces
1 parent 40abbcf commit 37c5f8f

File tree

11 files changed

+226
-125
lines changed

11 files changed

+226
-125
lines changed

‎hs-bindgen/app/hs-bindgen-cli.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,9 @@ import HsBindgen.Lib
1919
main :: IO ()
2020
main = handle exceptionHandler $ do
2121
cli@Cli{..} <- getCli
22-
withTracerStdOut (globalOptsTracerConf cliGlobalOpts) DefaultLogLevel $ \tracer ->
22+
_ <- withTracerStdOut (globalOptsTracerConf cliGlobalOpts) DefaultLogLevel $ \tracer ->
2323
execMode cli tracer cliMode
24+
pure ()
2425

2526
data LiterateFileException = LiterateFileException FilePath String
2627
deriving Show

‎hs-bindgen/app/hs-bindgen-dev.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,8 +15,9 @@ import HsBindgen.Pipeline qualified as Pipeline
1515
main :: IO ()
1616
main = do
1717
dev@Dev{..} <- getDev
18-
withTracerStdOut (globalOptsTracerConf devGlobalOpts) DefaultLogLevel $ \tracer ->
18+
_ <- withTracerStdOut (globalOptsTracerConf devGlobalOpts) DefaultLogLevel $ \tracer ->
1919
execMode dev tracer devMode
20+
pure ()
2021

2122
execMode :: HasCallStack
2223
=> Dev -> Tracer IO (TraceWithCallStack Trace) -> Mode -> IO ()

‎hs-bindgen/clang-ast-dump/Main.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ clangAstDump opts@Options{..} = do
5252
putStrLn $ "## `" ++ renderCHeaderIncludePath optFile ++ "`"
5353
putStrLn ""
5454

55-
withTracerStdOut tracerConf DefaultLogLevel $ \tracer ->
55+
_ <- withTracerStdOut tracerConf DefaultLogLevel $ \tracer ->
5656
withExtraClangArgs tracer cArgs $ \cArgs' -> do
5757
src <- resolveHeader tracer cArgs' optFile
5858
HighLevel.withIndex DontDisplayDiagnostics $ \index ->
@@ -65,6 +65,7 @@ clangAstDump opts@Options{..} = do
6565
| optSameFile && SourcePath file /= src -> pure $ Continue Nothing
6666
| not optBuiltin && isBuiltIn file -> pure $ Continue Nothing
6767
| otherwise -> foldDecls opts cursor
68+
pure ()
6869
where
6970
tracerConf :: TracerConf
7071
tracerConf = defaultTracerConf { tVerbosity = Verbosity Warning }

‎hs-bindgen/hs-bindgen.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -280,6 +280,7 @@ test-suite test-internal
280280
-- Internal
281281
Test.HsBindgen.C.Parser
282282
Test.HsBindgen.Clang.Args
283+
Test.HsBindgen.Util.Tracer
283284
Test.Internal.Misc
284285
Test.Internal.Rust
285286
Test.Internal.TastyGolden

‎hs-bindgen/src-internal/HsBindgen/Util/Tracer.hs

Lines changed: 66 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -23,21 +23,20 @@ module HsBindgen.Util.Tracer (
2323
, traceWithCallStack
2424
, useTrace
2525
-- | Tracers
26-
, mkTracer
2726
, withTracerStdOut
2827
, withTracerFile
29-
, withTracerQ
28+
, withTracerCustom
3029
) where
3130

3231
import Control.Applicative (ZipList (ZipList, getZipList))
3332
import Control.Monad (when)
3433
import Control.Monad.IO.Class (MonadIO (liftIO))
3534
import Control.Tracer (Contravariant (contramap), Tracer (Tracer), emit,
3635
squelchUnless, traceWith)
36+
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
3737
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
3838
import Data.Time.Format (FormatTime)
3939
import GHC.Stack (CallStack, prettyCallStack)
40-
import Language.Haskell.TH.Syntax (Quasi)
4140
import System.Console.ANSI (Color (..), ColorIntensity (Vivid),
4241
ConsoleIntensity (BoldIntensity),
4342
ConsoleLayer (Foreground),
@@ -93,7 +92,7 @@ alignSource = \case
9392
class HasSource a where
9493
getSource :: a -> Source
9594

96-
data Verbosity = Verbosity !Level | Quiet
95+
newtype Verbosity = Verbosity { unwrapVerbosity :: Level }
9796
deriving stock (Show, Eq)
9897

9998
{-------------------------------------------------------------------------------
@@ -142,21 +141,40 @@ mkTracer :: forall m a. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSour
142141
=> AnsiColor
143142
-> TracerConf
144143
-> CustomLogLevel a
144+
-> IORef Level
145145
-> (String -> m ())
146146
-> Tracer m (TraceWithCallStack a)
147-
mkTracer ansiColor (TracerConf {..}) customLogLevel report =
148-
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit prettyReport
147+
mkTracer ansiColor (TracerConf {..}) customLogLevel maxLogLevelRef report =
148+
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit $ traceAction
149149
where
150+
isLogLevelHighEnough :: a -> Bool
151+
isLogLevelHighEnough trace = getLogLevel trace >= unwrapVerbosity tVerbosity
152+
153+
-- Log format:
154+
-- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
155+
-- Indent subsequent lines.
156+
-- OPTION CALL STACK.
157+
traceAction :: TraceWithCallStack a -> m ()
158+
traceAction TraceWithCallStack {..} = do
159+
updateMaxLogLevel level
160+
time <- case tShowTimeStamp of
161+
DisableTimeStamp -> pure Nothing
162+
EnableTimeStamp -> Just <$> liftIO getCurrentTime
163+
mapM_ report $ getZipList $ formatLines time level source <*> traces
164+
when (tShowCallStack == EnableCallStack) $
165+
mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
166+
where level = getLogLevel tTrace
167+
source = getSource tTrace
168+
traces = ZipList $ lines $ prettyTrace tTrace
169+
170+
updateMaxLogLevel :: Level -> m ()
171+
updateMaxLogLevel level = liftIO $ modifyIORef maxLogLevelRef $ max level
172+
150173
getLogLevel :: a -> Level
151174
getLogLevel x = case customLogLevel of
152175
DefaultLogLevel -> getDefaultLogLevel x
153176
CustomLogLevel f -> f x
154177

155-
isLogLevelHighEnough :: a -> Bool
156-
isLogLevelHighEnough x = case tVerbosity of
157-
Quiet -> False
158-
Verbosity v -> getLogLevel x >= v
159-
160178
showTime :: FormatTime t => t -> String
161179
showTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%3QZ"
162180

@@ -185,58 +203,50 @@ mkTracer ansiColor (TracerConf {..}) customLogLevel report =
185203
indent :: String -> String
186204
indent = (" " <>)
187205

188-
-- Log format:
189-
-- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
190-
-- Indent subsequent lines.
191-
-- OPTION CALL STACK.
192-
prettyReport :: TraceWithCallStack a -> m ()
193-
prettyReport TraceWithCallStack {..} = do
194-
time <- case tShowTimeStamp of
195-
DisableTimeStamp -> pure Nothing
196-
EnableTimeStamp -> Just <$> liftIO getCurrentTime
197-
mapM_ report $ getZipList $ formatLines time level source <*> traces
198-
when (tShowCallStack == EnableCallStack) $
199-
mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
200-
where level = getLogLevel tTrace
201-
source = getSource tTrace
202-
traces = ZipList $ lines $ prettyTrace tTrace
203-
204206
-- | Run an action with a tracer writing to 'stdout'. Use ANSI colors, if available.
205-
withTracerStdOut :: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
207+
--
208+
-- Also return the maximum log level of traces.
209+
withTracerStdOut :: MonadIO m => (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
206210
=> TracerConf
207211
-> CustomLogLevel a
208-
-> (Tracer IO (TraceWithCallStack a) -> IO b)
209-
-> IO b
212+
-> (Tracer m (TraceWithCallStack a) -> m b)
213+
-> m (b, Level)
210214
withTracerStdOut tracerConf customLogLevel action = do
211-
supportsAnsiColor <- hSupportsANSIColor stdout
215+
supportsAnsiColor <- liftIO $ hSupportsANSIColor stdout
212216
let ansiColor = if supportsAnsiColor then EnableAnsiColor else DisableAnsiColor
213-
action $ mkTracer ansiColor tracerConf customLogLevel putStrLn
217+
withIORef Debug $ \ref ->
218+
action $ mkTracer ansiColor tracerConf customLogLevel ref (liftIO . putStrLn)
214219

215220
-- | Run an action with a tracer writing to a file. Do not use ANSI colors.
221+
--
222+
-- Also return the maximum log level of traces.
216223
withTracerFile
217224
:: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
218225
=> FilePath
219226
-> TracerConf
220227
-> CustomLogLevel a
221228
-> (Tracer IO (TraceWithCallStack a) -> IO b)
222-
-> IO b
223-
withTracerFile file tracerConf customLogLevel action = withFile file AppendMode $ \handle ->
224-
let tracer = mkTracer DisableAnsiColor tracerConf customLogLevel (hPutStrLn handle)
225-
in action tracer
226-
227-
-- | Run an action with a tracer in TH mode. Do not use ANSI colors.
228-
withTracerQ :: forall m a b. (Quasi m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
229-
=> TracerConf
229+
-> IO (b, Level)
230+
withTracerFile file tracerConf customLogLevel action =
231+
withFile file AppendMode $ \handle ->
232+
withIORef Debug $ \ref ->
233+
action $
234+
mkTracer DisableAnsiColor tracerConf customLogLevel ref (hPutStrLn handle)
235+
236+
-- | Run an action with a tracer using a custom report function.
237+
--
238+
-- Also return the maximum log level of traces.
239+
withTracerCustom
240+
:: forall m a b. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
241+
=> AnsiColor
242+
-> TracerConf
230243
-> CustomLogLevel a
244+
-> (String -> m ())
231245
-> (Tracer m (TraceWithCallStack a) -> m b)
232-
-> m b
233-
withTracerQ tracerConf customLogLevel action =
234-
action $ mkTracer DisableAnsiColor tracerConf customLogLevel report
235-
where
236-
report :: String -> m ()
237-
-- Use 'putStrLn' instead of 'qReport', to avoid the "Template Haskell
238-
-- error:" prefix. We are not exclusively reporting errors.
239-
report = liftIO . putStrLn
246+
-> m (b, Level)
247+
withTracerCustom ansiColor tracerConf customLogLevel report action =
248+
withIORef Debug $ \ref ->
249+
action $ mkTracer ansiColor tracerConf customLogLevel ref report
240250

241251
{-------------------------------------------------------------------------------
242252
Trace with call stack
@@ -257,7 +267,7 @@ traceWithCallStack tracer stack trace =
257267
--
258268
-- > useDiagnostic :: Tracer IO (TraceWithCallStack Trace)
259269
-- > -> Tracer IO (TraceWithCallStack Diagnostic)
260-
-- > useDiagnsotic = useTrace TraceDiagnostic
270+
-- > useDiagnostic = useTrace TraceDiagnostic
261271
useTrace :: (Contravariant c, Functor f) => (b -> a) -> c (f a) -> c (f b)
262272
useTrace = contramap . fmap
263273

@@ -281,3 +291,10 @@ withColor EnableAnsiColor level = withColor' (getColorForLevel level)
281291

282292
resetColor :: String
283293
resetColor = setSGRCode []
294+
295+
withIORef :: MonadIO m => b -> (IORef b -> m a) -> m (a, b)
296+
withIORef initialValue action = do
297+
ref <- liftIO $ newIORef initialValue
298+
actionResult <- action ref
299+
refResult <- liftIO $ readIORef ref
300+
pure (actionResult, refResult)

‎hs-bindgen/src/HsBindgen/Lib.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ import HsBindgen.ModuleUnique
8080
import HsBindgen.Pipeline qualified as Pipeline
8181
import HsBindgen.Resolve qualified as Resolve
8282
import HsBindgen.Util.Trace qualified as Trace
83-
import HsBindgen.Util.Tracer hiding (withTracerQ)
83+
import HsBindgen.Util.Tracer
8484

8585
{-------------------------------------------------------------------------------
8686
Parsing and translating

‎hs-bindgen/src/HsBindgen/TH.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,7 @@ import HsBindgen.Hs.Translation qualified as Hs
6060
import HsBindgen.Pipeline qualified as Pipeline
6161
import HsBindgen.Resolve qualified as Resolve
6262
import HsBindgen.Util.Trace qualified as Trace
63-
import HsBindgen.Util.Tracer hiding (withTracerFile, withTracerStdOut)
63+
import HsBindgen.Util.Tracer hiding (withTracerFile)
6464

6565
#ifdef MIN_VERSION_th_compat
6666
import Language.Haskell.TH.Syntax.Compat qualified as THSyntax

‎hs-bindgen/test/internal/Test/HsBindgen/Util/Tracer.hs

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
module Test.HsBindgen.Util.Tracer
2+
( tests
3+
) where
4+
5+
import GHC.Stack (callStack)
6+
import Test.Tasty (TestTree, testGroup)
7+
import Test.Tasty.HUnit (Assertion, testCase, (@?=))
8+
9+
import HsBindgen.Lib
10+
11+
data TestTrace = TestDebug String | TestWarning String | TestError String
12+
13+
instance PrettyTrace TestTrace where
14+
prettyTrace = \case
15+
TestDebug x -> x
16+
TestWarning x -> x
17+
TestError x -> x
18+
19+
instance HasDefaultLogLevel TestTrace where
20+
getDefaultLogLevel = \case
21+
TestDebug _ -> Debug
22+
TestWarning _ -> Warning
23+
TestError _ -> Error
24+
25+
instance HasSource TestTrace where
26+
getSource = const HsBindgen
27+
28+
assertMaxLevel :: [TestTrace] -> Level -> Assertion
29+
assertMaxLevel = assertMaxLevelWithCustomLogLevel DefaultLogLevel
30+
31+
assertMaxLevelWithDegrade :: [TestTrace] -> Level -> Assertion
32+
assertMaxLevelWithDegrade =
33+
assertMaxLevelWithCustomLogLevel (CustomLogLevel $ const Info)
34+
35+
assertMaxLevelWithCustomLogLevel
36+
:: CustomLogLevel TestTrace -> [TestTrace] -> Level -> Assertion
37+
assertMaxLevelWithCustomLogLevel customLogLevel traces expectedLevel = do
38+
lvl <- testTracerIO customLogLevel traces
39+
lvl @?= expectedLevel
40+
41+
testTracerIO :: CustomLogLevel TestTrace -> [TestTrace] -> IO Level
42+
testTracerIO customLogLevel traces = do
43+
let noOutput _ = pure ()
44+
tracerConf = defaultTracerConf { tVerbosity = Verbosity Debug }
45+
withTracer = withTracerCustom DisableAnsiColor tracerConf customLogLevel noOutput
46+
(_, maxLogLevel) <- withTracer $ \tracer -> do
47+
mapM_ (traceWithCallStack tracer callStack) traces
48+
pure maxLogLevel
49+
50+
tests :: TestTree
51+
tests = testGroup "HsBindgen.Util.Tracer"
52+
[ testGroup "DefaultLogLevel"
53+
[ testCase "none" $ assertMaxLevel [] Debug
54+
, testCase "warning" $ assertMaxLevel [wn] Warning
55+
, testCase "error" $ assertMaxLevel [er] Error
56+
, testCase "error1" $ assertMaxLevel [wn, er] Error
57+
, testCase "error2" $ assertMaxLevel [wn, er, wn] Error
58+
, testCase "error3" $ assertMaxLevel [er, wn] Error
59+
]
60+
, testGroup "CustomLogLevel"
61+
[ testCase "none" $ assertMaxLevelWithDegrade [] Debug
62+
, testCase "warning" $ assertMaxLevelWithDegrade [wn] Info
63+
, testCase "warning1" $ assertMaxLevelWithDegrade [db, wn] Info
64+
, testCase "warning2" $ assertMaxLevelWithDegrade [wn, db] Info
65+
, testCase "warning3" $ assertMaxLevelWithDegrade [db, wn, db] Info
66+
, testCase "error" $ assertMaxLevelWithDegrade [er] Info
67+
, testCase "error1" $ assertMaxLevelWithDegrade [wn, er] Info
68+
, testCase "error2" $ assertMaxLevelWithDegrade [wn, er, wn] Info
69+
, testCase "error3" $ assertMaxLevelWithDegrade [er, wn] Info
70+
]
71+
]
72+
where db = TestDebug "Debug message."
73+
wn = TestWarning "Be careful!"
74+
er = TestError "Error!"

‎hs-bindgen/test/internal/Test/Internal/TH.hs

Lines changed: 28 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -23,37 +23,38 @@ import Test.Internal.Trace (degradeKnownTraces)
2323

2424
goldenTh :: HasCallStack => FilePath -> TestName -> TestTree
2525
goldenTh packageRoot name = goldenVsStringDiff_ "th" ("fixtures" </> (name ++ ".th.txt")) $ \report -> do
26-
-- -<.> does weird stuff for filenames with multiple dots;
27-
-- I usually simply avoid using it.
28-
let headerIncludePath = CHeaderQuoteIncludePath $ name ++ ".h"
29-
tracer = mkTracer EnableAnsiColor defaultTracerConf degradeKnownTraces report
30-
opts = Pipeline.defaultOpts {
31-
Pipeline.optsClangArgs = clangArgs packageRoot
32-
, Pipeline.optsTracer = tracer
33-
}
34-
(depPaths, cheader) <- Pipeline.parseCHeader opts headerIncludePath
26+
(logs, _) <- withTracerCustom EnableAnsiColor defaultTracerConf degradeKnownTraces report $ \tracer -> do
27+
-- -<.> does weird stuff for filenames with multiple dots;
28+
-- I usually simply avoid using it.
29+
let headerIncludePath = CHeaderQuoteIncludePath $ name ++ ".h"
30+
opts = Pipeline.defaultOpts {
31+
Pipeline.optsClangArgs = clangArgs packageRoot
32+
, Pipeline.optsTracer = tracer
33+
}
34+
(depPaths, cheader) <- Pipeline.parseCHeader opts headerIncludePath
3535

36-
let decls :: Qu [TH.Dec]
37-
decls = Pipeline.genBindingsFromCHeader opts depPaths cheader
36+
let decls :: Qu [TH.Dec]
37+
decls = Pipeline.genBindingsFromCHeader opts depPaths cheader
3838

39-
-- unqualify names, qualified names are noisy *and*
40-
-- GHC.Base names have moved.
41-
unqualNames :: [TH.Dec] -> [TH.Dec]
42-
unqualNames = SYB.everywhere $ SYB.mkT mangleName
39+
-- unqualify names, qualified names are noisy *and*
40+
-- GHC.Base names have moved.
41+
unqualNames :: [TH.Dec] -> [TH.Dec]
42+
unqualNames = SYB.everywhere $ SYB.mkT mangleName
4343

44-
mangleName :: TH.Name -> TH.Name
45-
mangleName n | n == ''() = TH.Name (TH.OccName "Unit") TH.NameS
46-
mangleName (TH.Name occ TH.NameG {}) = TH.Name occ TH.NameS
47-
mangleName n = n
44+
mangleName :: TH.Name -> TH.Name
45+
mangleName n | n == ''() = TH.Name (TH.OccName "Unit") TH.NameS
46+
mangleName (TH.Name occ TH.NameG {}) = TH.Name occ TH.NameS
47+
mangleName n = n
4848

49-
let (depfiles, csources, thdecs) = runQu decls
50-
return $ unlines $
51-
-- here we might have headers outside of our package,
52-
-- but in our test setup that SHOULD cause an error, as we use bundled stdlib,
53-
-- And we will cause those on CI, which runs tests on different systems
54-
[ "-- addDependentFile " ++ convertWindows (makeRelative packageRoot fp) | fp <- depfiles ] ++
55-
[ "-- " ++ l | src <- csources, l <- lines src ] ++
56-
[ show $ TH.ppr d | d <- unqualNames thdecs ]
49+
let (depfiles, csources, thdecs) = runQu decls
50+
pure $ unlines $
51+
-- here we might have headers outside of our package,
52+
-- but in our test setup that SHOULD cause an error, as we use bundled stdlib,
53+
-- And we will cause those on CI, which runs tests on different systems
54+
[ "-- addDependentFile " ++ convertWindows (makeRelative packageRoot fp) | fp <- depfiles ] ++
55+
[ "-- " ++ l | src <- csources, l <- lines src ] ++
56+
[ show $ TH.ppr d | d <- unqualNames thdecs ]
57+
pure logs
5758

5859
convertWindows :: FilePath -> FilePath
5960
convertWindows = map f where

0 commit comments

Comments
 (0)