Skip to content

Commit c1d4a85

Browse files
authored
Merge pull request #666 from well-typed/dom/662-tracers-log-level-improvements
Tracers log level improvements
2 parents f15c886 + 3f89083 commit c1d4a85

File tree

14 files changed

+315
-141
lines changed

14 files changed

+315
-141
lines changed

hs-bindgen/app/HsBindgen/App/Common.hs

Lines changed: 19 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@ data GlobalOpts = GlobalOpts {
3939
, globalOptsClangArgs :: ClangArgs
4040
, globalOptsExtBindings :: [FilePath]
4141
}
42-
deriving (Show)
42+
deriving stock (Show)
4343

4444
parseGlobalOpts :: Parser GlobalOpts
4545
parseGlobalOpts =
@@ -56,16 +56,24 @@ parseTracerConf = TracerConf <$> parseVerbosity
5656

5757
parseVerbosity :: Parser Verbosity
5858
parseVerbosity =
59-
countToVerbosity . length <$> many (flag' () $
60-
mconcat [ short 'v'
61-
, long "verbose"
62-
, help "Verbose output (-v for verbose, -vv for debug)"
63-
])
64-
65-
where countToVerbosity x = case x `compare` 1 of
66-
LT -> Verbosity Warning
67-
EQ -> Verbosity Info
68-
GT -> Verbosity Debug
59+
nToVerbosity <$>
60+
(option auto $
61+
mconcat [ short 'v'
62+
, long "verbosity"
63+
, metavar "INT"
64+
, value 1
65+
, help "Specify verbosity (0: error, 1: warning, 2: info, 3: debug);"
66+
, showDefault
67+
])
68+
69+
where
70+
nToVerbosity :: Int -> Verbosity
71+
nToVerbosity = Verbosity . \case
72+
n | n <= 0 -> Error
73+
1 -> Warning
74+
2 -> Info
75+
-- n | n >= 3 -- (But exhaustive checker complains).
76+
_nGe3 -> Debug
6977

7078
parseShowTimeStamp :: Parser ShowTimeStamp
7179
parseShowTimeStamp = flag DisableTimeStamp EnableTimeStamp $ mconcat [

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

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

2627
data LiterateFileException = LiterateFileException FilePath String
2728
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) $ \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: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -23,9 +23,9 @@ import Clang.LowLevel.Doxygen
2323
import Clang.Paths
2424
import HsBindgen.Clang.Args (withExtraClangArgs)
2525
import HsBindgen.Resolve (resolveHeader)
26-
import HsBindgen.Util.Tracer (Level (Warning), TracerConf (tVerbosity),
27-
Verbosity (Verbosity), defaultTracerConf,
28-
withTracerStdOut)
26+
import HsBindgen.Util.Tracer (CustomLogLevel (DefaultLogLevel), Level (Warning),
27+
TracerConf (tVerbosity), Verbosity (Verbosity),
28+
defaultTracerConf, withTracerStdOut)
2929

3030
{-------------------------------------------------------------------------------
3131
Options
@@ -52,7 +52,7 @@ clangAstDump opts@Options{..} = do
5252
putStrLn $ "## `" ++ renderCHeaderIncludePath optFile ++ "`"
5353
putStrLn ""
5454

55-
withTracerStdOut tracerConf $ \tracer ->
55+
_ <- withTracerStdOut tracerConf DefaultLogLevel $ \tracer ->
5656
withExtraClangArgs tracer cArgs $ \cArgs' -> do
5757
src <- resolveHeader tracer cArgs' optFile
5858
HighLevel.withIndex DontDisplayDiagnostics $ \index ->
@@ -65,9 +65,10 @@ 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
70-
tracerConf = defaultTracerConf { tVerbosity = Verbosity Warning}
71+
tracerConf = defaultTracerConf { tVerbosity = Verbosity Warning }
7172

7273
cArgs :: ClangArgs
7374
cArgs = defaultClangArgs {

hs-bindgen/hs-bindgen.cabal

Lines changed: 16 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -275,15 +275,19 @@ test-suite test-internal
275275
import: lang
276276
type: exitcode-stdio-1.0
277277
main-is: test-internal.hs
278-
hs-source-dirs: test/internal
278+
hs-source-dirs: test/internal, test/common
279279
other-modules:
280+
-- Internal
280281
Test.HsBindgen.C.Parser
281282
Test.HsBindgen.Clang.Args
283+
Test.HsBindgen.Util.Tracer
282284
Test.Internal.Misc
283285
Test.Internal.Rust
284286
Test.Internal.TastyGolden
285287
Test.Internal.TH
286288
Test.Internal.TreeDiff.Orphans
289+
-- Common
290+
Test.Internal.Trace
287291
build-depends:
288292
-- Internal dependencies
289293
, c-expr
@@ -317,16 +321,20 @@ test-suite test-internal
317321
test-suite test-th
318322
type: exitcode-stdio-1.0
319323
main-is: test-th.hs
320-
hs-source-dirs: test/th
324+
hs-source-dirs: test/th, test/common
321325
include-dirs: examples
322326

323327
other-modules:
328+
-- TH
324329
Test01
325330
Test02
331+
-- Common
332+
Test.Internal.Trace
326333

327334
default-language: Haskell2010
328335
build-depends:
329336
-- Internal dependencies
337+
, clang
330338
, hs-bindgen
331339
, hs-bindgen-runtime
332340
build-depends:
@@ -342,12 +350,15 @@ test-suite test-th
342350
test-suite test-pp
343351
type: exitcode-stdio-1.0
344352
main-is: ../th/test-th.hs
345-
hs-source-dirs: test/pp
353+
hs-source-dirs: test/pp, test/common
346354
include-dirs: examples
347355

348356
other-modules:
357+
-- PP
349358
Test01
350359
Test02
360+
-- Common
361+
Test.Internal.Trace
351362

352363
default-language: Haskell2010
353364

@@ -361,6 +372,8 @@ test-suite test-pp
361372
build-depends:
362373
-- Internal dependencies
363374
, c-expr
375+
, clang
376+
, hs-bindgen
364377
, hs-bindgen-runtime
365378
build-depends:
366379
-- Inherited dependencies

hs-bindgen/src-internal/HsBindgen/Clang/Args.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ data ExtraClangArgsLog =
2929
ExtraClangArgsNone
3030
| ExtraClangArgsParsed { envName :: String
3131
, envArgs :: [String] }
32+
deriving stock (Show)
3233

3334
instance PrettyTrace ExtraClangArgsLog where
3435
prettyTrace = \case

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

Lines changed: 93 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -17,26 +17,26 @@ module HsBindgen.Util.Tracer (
1717
, ShowCallStack (..)
1818
, TracerConf (..)
1919
, defaultTracerConf
20+
, CustomLogLevel (..)
2021
-- | Trace with call stack
2122
, TraceWithCallStack (..)
2223
, traceWithCallStack
2324
, useTrace
2425
-- | Tracers
25-
, mkTracer
2626
, withTracerStdOut
2727
, withTracerFile
28-
, withTracerQ
28+
, withTracerCustom
2929
) where
3030

3131
import Control.Applicative (ZipList (ZipList, getZipList))
3232
import Control.Monad (when)
3333
import Control.Monad.IO.Class (MonadIO (liftIO))
3434
import Control.Tracer (Contravariant (contramap), Tracer (Tracer), emit,
3535
squelchUnless, traceWith)
36+
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
3637
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
3738
import Data.Time.Format (FormatTime)
3839
import GHC.Stack (CallStack, prettyCallStack)
39-
import Language.Haskell.TH.Syntax (Quasi)
4040
import System.Console.ANSI (Color (..), ColorIntensity (Vivid),
4141
ConsoleIntensity (BoldIntensity),
4242
ConsoleLayer (Foreground),
@@ -92,7 +92,7 @@ alignSource = \case
9292
class HasSource a where
9393
getSource :: a -> Source
9494

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

9898
{-------------------------------------------------------------------------------
@@ -117,7 +117,15 @@ data TracerConf = TracerConf {
117117
deriving stock (Show, Eq)
118118

119119
defaultTracerConf :: TracerConf
120-
defaultTracerConf = TracerConf (Verbosity Info) DisableTimeStamp DisableCallStack
120+
defaultTracerConf = TracerConf
121+
{ tVerbosity = (Verbosity Info)
122+
, tShowTimeStamp = DisableTimeStamp
123+
, tShowCallStack = DisableCallStack
124+
}
125+
126+
-- | Sometimes, we want to change log levels. For example, we want to suppress
127+
-- specific traces in tests.
128+
data CustomLogLevel a = DefaultLogLevel | CustomLogLevel (a -> Level)
121129

122130
{-------------------------------------------------------------------------------
123131
Tracers
@@ -130,14 +138,42 @@ defaultTracerConf = TracerConf (Verbosity Info) DisableTimeStamp DisableCallStac
130138
-- - the log level, and
131139
-- - the source.
132140
mkTracer :: forall m a. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
133-
=> AnsiColor -> TracerConf -> (String -> m ()) -> Tracer m (TraceWithCallStack a)
134-
mkTracer ansiColor (TracerConf {..}) report =
135-
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit prettyReport
141+
=> AnsiColor
142+
-> TracerConf
143+
-> CustomLogLevel a
144+
-> IORef Level
145+
-> (String -> m ())
146+
-> Tracer m (TraceWithCallStack a)
147+
mkTracer ansiColor (TracerConf {..}) customLogLevel maxLogLevelRef report =
148+
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit $ traceAction
136149
where
137150
isLogLevelHighEnough :: a -> Bool
138-
isLogLevelHighEnough x = case tVerbosity of
139-
Quiet -> False
140-
Verbosity v -> getDefaultLogLevel x >= v
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+
173+
getLogLevel :: a -> Level
174+
getLogLevel x = case customLogLevel of
175+
DefaultLogLevel -> getDefaultLogLevel x
176+
CustomLogLevel f -> f x
141177

142178
showTime :: FormatTime t => t -> String
143179
showTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%3QZ"
@@ -167,47 +203,50 @@ mkTracer ansiColor (TracerConf {..}) report =
167203
indent :: String -> String
168204
indent = (" " <>)
169205

170-
-- Log format:
171-
-- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
172-
-- Indent subsequent lines.
173-
-- OPTION CALL STACK.
174-
prettyReport :: TraceWithCallStack a -> m ()
175-
prettyReport TraceWithCallStack {..} = do
176-
time <- case tShowTimeStamp of
177-
DisableTimeStamp -> pure Nothing
178-
EnableTimeStamp -> Just <$> liftIO getCurrentTime
179-
mapM_ report $ getZipList $ formatLines time level source <*> traces
180-
when (tShowCallStack == EnableCallStack) $
181-
mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
182-
where level = getDefaultLogLevel tTrace
183-
source = getSource tTrace
184-
traces = ZipList $ lines $ prettyTrace tTrace
185-
186206
-- | Run an action with a tracer writing to 'stdout'. Use ANSI colors, if available.
187-
withTracerStdOut :: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
188-
=> TracerConf -> (Tracer IO (TraceWithCallStack a) -> IO b) -> IO b
189-
withTracerStdOut tracerConf action = do
190-
supportsAnsiColor <- hSupportsANSIColor stdout
207+
--
208+
-- Also return the maximum log level of traces.
209+
withTracerStdOut :: MonadIO m => (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
210+
=> TracerConf
211+
-> CustomLogLevel a
212+
-> (Tracer m (TraceWithCallStack a) -> m b)
213+
-> m (b, Level)
214+
withTracerStdOut tracerConf customLogLevel action = do
215+
supportsAnsiColor <- liftIO $ hSupportsANSIColor stdout
191216
let ansiColor = if supportsAnsiColor then EnableAnsiColor else DisableAnsiColor
192-
action $ mkTracer ansiColor tracerConf putStrLn
217+
withIORef Debug $ \ref ->
218+
action $ mkTracer ansiColor tracerConf customLogLevel ref (liftIO . putStrLn)
193219

194220
-- | 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.
195223
withTracerFile
196224
:: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
197-
=> FilePath -> TracerConf -> (Tracer IO (TraceWithCallStack a) -> IO b) -> IO b
198-
withTracerFile file tracerConf action = withFile file AppendMode $ \handle ->
199-
let tracer = mkTracer DisableAnsiColor tracerConf (hPutStrLn handle)
200-
in action tracer
201-
202-
-- | Run an action with a tracer in TH mode. Do not use ANSI colors.
203-
withTracerQ :: forall m a b. (Quasi m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
204-
=> TracerConf -> (Tracer m (TraceWithCallStack a) -> m b) -> m b
205-
withTracerQ tracerConf action = action $ mkTracer DisableAnsiColor tracerConf report
206-
where
207-
report :: String -> m ()
208-
-- Use 'putStrLn' instead of 'qReport', to avoid the "Template Haskell
209-
-- error:" prefix. We are not exclusively reporting errors.
210-
report = liftIO . putStrLn
225+
=> FilePath
226+
-> TracerConf
227+
-> CustomLogLevel a
228+
-> (Tracer IO (TraceWithCallStack a) -> IO b)
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
243+
-> CustomLogLevel a
244+
-> (String -> m ())
245+
-> (Tracer m (TraceWithCallStack a) -> m b)
246+
-> m (b, Level)
247+
withTracerCustom ansiColor tracerConf customLogLevel report action =
248+
withIORef Debug $ \ref ->
249+
action $ mkTracer ansiColor tracerConf customLogLevel ref report
211250

212251
{-------------------------------------------------------------------------------
213252
Trace with call stack
@@ -228,7 +267,7 @@ traceWithCallStack tracer stack trace =
228267
--
229268
-- > useDiagnostic :: Tracer IO (TraceWithCallStack Trace)
230269
-- > -> Tracer IO (TraceWithCallStack Diagnostic)
231-
-- > useDiagnsotic = useTrace TraceDiagnostic
270+
-- > useDiagnostic = useTrace TraceDiagnostic
232271
useTrace :: (Contravariant c, Functor f) => (b -> a) -> c (f a) -> c (f b)
233272
useTrace = contramap . fmap
234273

@@ -252,3 +291,10 @@ withColor EnableAnsiColor level = withColor' (getColorForLevel level)
252291

253292
resetColor :: String
254293
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

0 commit comments

Comments
 (0)