Skip to content

Tracers log level improvements #666

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
May 23, 2025
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 19 additions & 11 deletions hs-bindgen/app/HsBindgen/App/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ data GlobalOpts = GlobalOpts {
, globalOptsClangArgs :: ClangArgs
, globalOptsExtBindings :: [FilePath]
}
deriving (Show)
deriving stock (Show)

parseGlobalOpts :: Parser GlobalOpts
parseGlobalOpts =
Expand All @@ -56,16 +56,24 @@ parseTracerConf = TracerConf <$> parseVerbosity

parseVerbosity :: Parser Verbosity
parseVerbosity =
countToVerbosity . length <$> many (flag' () $
mconcat [ short 'v'
, long "verbose"
, help "Verbose output (-v for verbose, -vv for debug)"
])

where countToVerbosity x = case x `compare` 1 of
LT -> Verbosity Warning
EQ -> Verbosity Info
GT -> Verbosity Debug
nToVerbosity <$>
(option auto $
mconcat [ short 'v'
, long "verbosity"
, metavar "INT"
, value 1
, help "Specify verbosity (0: error, 1: warning, 2: info, 3: debug);"
, showDefault
])

where
nToVerbosity :: Int -> Verbosity
nToVerbosity = Verbosity . \case
n | n <= 0 -> Error
1 -> Warning
2 -> Info
-- n | n >= 3 -- (But exhaustive checker complains).
_nGe3 -> Debug

parseShowTimeStamp :: Parser ShowTimeStamp
parseShowTimeStamp = flag DisableTimeStamp EnableTimeStamp $ mconcat [
Expand Down
3 changes: 2 additions & 1 deletion hs-bindgen/app/hs-bindgen-cli.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,8 +20,9 @@ import HsBindgen.Lib
main :: IO ()
main = handle exceptionHandler $ do
cli@Cli{..} <- getCli
withTracerStdOut (globalOptsTracerConf cliGlobalOpts) $ \tracer ->
_ <- withTracerStdOut (globalOptsTracerConf cliGlobalOpts) DefaultLogLevel $ \tracer ->
execMode cli tracer cliMode
pure ()

data LiterateFileException = LiterateFileException FilePath String
deriving Show
Expand Down
3 changes: 2 additions & 1 deletion hs-bindgen/app/hs-bindgen-dev.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,8 +15,9 @@ import HsBindgen.Pipeline qualified as Pipeline
main :: IO ()
main = do
dev@Dev{..} <- getDev
withTracerStdOut (globalOptsTracerConf devGlobalOpts) $ \tracer ->
_ <- withTracerStdOut (globalOptsTracerConf devGlobalOpts) DefaultLogLevel $ \tracer ->
execMode dev tracer devMode
pure ()

execMode :: HasCallStack
=> Dev -> Tracer IO (TraceWithCallStack Trace) -> Mode -> IO ()
Expand Down
11 changes: 6 additions & 5 deletions hs-bindgen/clang-ast-dump/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,9 +23,9 @@ import Clang.LowLevel.Doxygen
import Clang.Paths
import HsBindgen.Clang.Args (withExtraClangArgs)
import HsBindgen.Resolve (resolveHeader)
import HsBindgen.Util.Tracer (Level (Warning), TracerConf (tVerbosity),
Verbosity (Verbosity), defaultTracerConf,
withTracerStdOut)
import HsBindgen.Util.Tracer (CustomLogLevel (DefaultLogLevel), Level (Warning),
TracerConf (tVerbosity), Verbosity (Verbosity),
defaultTracerConf, withTracerStdOut)

{-------------------------------------------------------------------------------
Options
Expand All @@ -52,7 +52,7 @@ clangAstDump opts@Options{..} = do
putStrLn $ "## `" ++ renderCHeaderIncludePath optFile ++ "`"
putStrLn ""

withTracerStdOut tracerConf $ \tracer ->
_ <- withTracerStdOut tracerConf DefaultLogLevel $ \tracer ->
withExtraClangArgs tracer cArgs $ \cArgs' -> do
src <- resolveHeader tracer cArgs' optFile
HighLevel.withIndex DontDisplayDiagnostics $ \index ->
Expand All @@ -65,9 +65,10 @@ clangAstDump opts@Options{..} = do
| optSameFile && SourcePath file /= src -> pure $ Continue Nothing
| not optBuiltin && isBuiltIn file -> pure $ Continue Nothing
| otherwise -> foldDecls opts cursor
pure ()
where
tracerConf :: TracerConf
tracerConf = defaultTracerConf { tVerbosity = Verbosity Warning}
tracerConf = defaultTracerConf { tVerbosity = Verbosity Warning }

cArgs :: ClangArgs
cArgs = defaultClangArgs {
Expand Down
19 changes: 16 additions & 3 deletions hs-bindgen/hs-bindgen.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -275,15 +275,19 @@ test-suite test-internal
import: lang
type: exitcode-stdio-1.0
main-is: test-internal.hs
hs-source-dirs: test/internal
hs-source-dirs: test/internal, test/common
other-modules:
-- Internal
Test.HsBindgen.C.Parser
Test.HsBindgen.Clang.Args
Test.HsBindgen.Util.Tracer
Test.Internal.Misc
Test.Internal.Rust
Test.Internal.TastyGolden
Test.Internal.TH
Test.Internal.TreeDiff.Orphans
-- Common
Test.Internal.Trace
build-depends:
-- Internal dependencies
, c-expr
Expand Down Expand Up @@ -317,16 +321,20 @@ test-suite test-internal
test-suite test-th
type: exitcode-stdio-1.0
main-is: test-th.hs
hs-source-dirs: test/th
hs-source-dirs: test/th, test/common
include-dirs: examples

other-modules:
-- TH
Test01
Test02
-- Common
Test.Internal.Trace

default-language: Haskell2010
build-depends:
-- Internal dependencies
, clang
, hs-bindgen
, hs-bindgen-runtime
build-depends:
Expand All @@ -342,12 +350,15 @@ test-suite test-th
test-suite test-pp
type: exitcode-stdio-1.0
main-is: ../th/test-th.hs
hs-source-dirs: test/pp
hs-source-dirs: test/pp, test/common
include-dirs: examples

other-modules:
-- PP
Test01
Test02
-- Common
Test.Internal.Trace

default-language: Haskell2010

Expand All @@ -361,6 +372,8 @@ test-suite test-pp
build-depends:
-- Internal dependencies
, c-expr
, clang
, hs-bindgen
, hs-bindgen-runtime
build-depends:
-- Inherited dependencies
Expand Down
1 change: 1 addition & 0 deletions hs-bindgen/src-internal/HsBindgen/Clang/Args.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ data ExtraClangArgsLog =
ExtraClangArgsNone
| ExtraClangArgsParsed { envName :: String
, envArgs :: [String] }
deriving stock (Show)

instance PrettyTrace ExtraClangArgsLog where
prettyTrace = \case
Expand Down
140 changes: 93 additions & 47 deletions hs-bindgen/src-internal/HsBindgen/Util/Tracer.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,26 +17,26 @@ module HsBindgen.Util.Tracer (
, ShowCallStack (..)
, TracerConf (..)
, defaultTracerConf
, CustomLogLevel (..)
-- | Trace with call stack
, TraceWithCallStack (..)
, traceWithCallStack
, useTrace
-- | Tracers
, mkTracer
, withTracerStdOut
, withTracerFile
, withTracerQ
, withTracerCustom
) where

import Control.Applicative (ZipList (ZipList, getZipList))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Tracer (Contravariant (contramap), Tracer (Tracer), emit,
squelchUnless, traceWith)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Data.Time.Format (FormatTime)
import GHC.Stack (CallStack, prettyCallStack)
import Language.Haskell.TH.Syntax (Quasi)
import System.Console.ANSI (Color (..), ColorIntensity (Vivid),
ConsoleIntensity (BoldIntensity),
ConsoleLayer (Foreground),
Expand Down Expand Up @@ -92,7 +92,7 @@ alignSource = \case
class HasSource a where
getSource :: a -> Source

data Verbosity = Verbosity !Level | Quiet
newtype Verbosity = Verbosity { unwrapVerbosity :: Level }
deriving stock (Show, Eq)

{-------------------------------------------------------------------------------
Expand All @@ -117,7 +117,15 @@ data TracerConf = TracerConf {
deriving stock (Show, Eq)

defaultTracerConf :: TracerConf
defaultTracerConf = TracerConf (Verbosity Info) DisableTimeStamp DisableCallStack
defaultTracerConf = TracerConf
{ tVerbosity = (Verbosity Info)
, tShowTimeStamp = DisableTimeStamp
, tShowCallStack = DisableCallStack
}

-- | Sometimes, we want to change log levels. For example, we want to suppress
-- specific traces in tests.
data CustomLogLevel a = DefaultLogLevel | CustomLogLevel (a -> Level)

{-------------------------------------------------------------------------------
Tracers
Expand All @@ -130,14 +138,42 @@ defaultTracerConf = TracerConf (Verbosity Info) DisableTimeStamp DisableCallStac
-- - the log level, and
-- - the source.
mkTracer :: forall m a. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> AnsiColor -> TracerConf -> (String -> m ()) -> Tracer m (TraceWithCallStack a)
mkTracer ansiColor (TracerConf {..}) report =
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit prettyReport
=> AnsiColor
-> TracerConf
-> CustomLogLevel a
-> IORef Level
-> (String -> m ())
-> Tracer m (TraceWithCallStack a)
mkTracer ansiColor (TracerConf {..}) customLogLevel maxLogLevelRef report =
squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit $ traceAction
where
isLogLevelHighEnough :: a -> Bool
isLogLevelHighEnough x = case tVerbosity of
Quiet -> False
Verbosity v -> getDefaultLogLevel x >= v
isLogLevelHighEnough trace = getLogLevel trace >= unwrapVerbosity tVerbosity

-- Log format:
-- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
-- Indent subsequent lines.
-- OPTION CALL STACK.
traceAction :: TraceWithCallStack a -> m ()
traceAction TraceWithCallStack {..} = do
updateMaxLogLevel level
time <- case tShowTimeStamp of
DisableTimeStamp -> pure Nothing
EnableTimeStamp -> Just <$> liftIO getCurrentTime
mapM_ report $ getZipList $ formatLines time level source <*> traces
when (tShowCallStack == EnableCallStack) $
mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
where level = getLogLevel tTrace
source = getSource tTrace
traces = ZipList $ lines $ prettyTrace tTrace

updateMaxLogLevel :: Level -> m ()
updateMaxLogLevel level = liftIO $ modifyIORef maxLogLevelRef $ max level

getLogLevel :: a -> Level
getLogLevel x = case customLogLevel of
DefaultLogLevel -> getDefaultLogLevel x
CustomLogLevel f -> f x

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

-- Log format:
-- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
-- Indent subsequent lines.
-- OPTION CALL STACK.
prettyReport :: TraceWithCallStack a -> m ()
prettyReport TraceWithCallStack {..} = do
time <- case tShowTimeStamp of
DisableTimeStamp -> pure Nothing
EnableTimeStamp -> Just <$> liftIO getCurrentTime
mapM_ report $ getZipList $ formatLines time level source <*> traces
when (tShowCallStack == EnableCallStack) $
mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
where level = getDefaultLogLevel tTrace
source = getSource tTrace
traces = ZipList $ lines $ prettyTrace tTrace

-- | Run an action with a tracer writing to 'stdout'. Use ANSI colors, if available.
withTracerStdOut :: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> TracerConf -> (Tracer IO (TraceWithCallStack a) -> IO b) -> IO b
withTracerStdOut tracerConf action = do
supportsAnsiColor <- hSupportsANSIColor stdout
--
-- Also return the maximum log level of traces.
withTracerStdOut :: MonadIO m => (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> TracerConf
-> CustomLogLevel a
-> (Tracer m (TraceWithCallStack a) -> m b)
-> m (b, Level)
withTracerStdOut tracerConf customLogLevel action = do
supportsAnsiColor <- liftIO $ hSupportsANSIColor stdout
let ansiColor = if supportsAnsiColor then EnableAnsiColor else DisableAnsiColor
action $ mkTracer ansiColor tracerConf putStrLn
withIORef Debug $ \ref ->
action $ mkTracer ansiColor tracerConf customLogLevel ref (liftIO . putStrLn)

-- | Run an action with a tracer writing to a file. Do not use ANSI colors.
--
-- Also return the maximum log level of traces.
withTracerFile
:: (PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> FilePath -> TracerConf -> (Tracer IO (TraceWithCallStack a) -> IO b) -> IO b
withTracerFile file tracerConf action = withFile file AppendMode $ \handle ->
let tracer = mkTracer DisableAnsiColor tracerConf (hPutStrLn handle)
in action tracer

-- | Run an action with a tracer in TH mode. Do not use ANSI colors.
withTracerQ :: forall m a b. (Quasi m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> TracerConf -> (Tracer m (TraceWithCallStack a) -> m b) -> m b
withTracerQ tracerConf action = action $ mkTracer DisableAnsiColor tracerConf report
where
report :: String -> m ()
-- Use 'putStrLn' instead of 'qReport', to avoid the "Template Haskell
-- error:" prefix. We are not exclusively reporting errors.
report = liftIO . putStrLn
=> FilePath
-> TracerConf
-> CustomLogLevel a
-> (Tracer IO (TraceWithCallStack a) -> IO b)
-> IO (b, Level)
withTracerFile file tracerConf customLogLevel action =
withFile file AppendMode $ \handle ->
withIORef Debug $ \ref ->
action $
mkTracer DisableAnsiColor tracerConf customLogLevel ref (hPutStrLn handle)

-- | Run an action with a tracer using a custom report function.
--
-- Also return the maximum log level of traces.
withTracerCustom
:: forall m a b. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSource a)
=> AnsiColor
-> TracerConf
-> CustomLogLevel a
-> (String -> m ())
-> (Tracer m (TraceWithCallStack a) -> m b)
-> m (b, Level)
withTracerCustom ansiColor tracerConf customLogLevel report action =
withIORef Debug $ \ref ->
action $ mkTracer ansiColor tracerConf customLogLevel ref report

{-------------------------------------------------------------------------------
Trace with call stack
Expand All @@ -228,7 +267,7 @@ traceWithCallStack tracer stack trace =
--
-- > useDiagnostic :: Tracer IO (TraceWithCallStack Trace)
-- > -> Tracer IO (TraceWithCallStack Diagnostic)
-- > useDiagnsotic = useTrace TraceDiagnostic
-- > useDiagnostic = useTrace TraceDiagnostic
useTrace :: (Contravariant c, Functor f) => (b -> a) -> c (f a) -> c (f b)
useTrace = contramap . fmap

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

resetColor :: String
resetColor = setSGRCode []

withIORef :: MonadIO m => b -> (IORef b -> m a) -> m (a, b)
withIORef initialValue action = do
ref <- liftIO $ newIORef initialValue
actionResult <- action ref
refResult <- liftIO $ readIORef ref
pure (actionResult, refResult)
2 changes: 1 addition & 1 deletion hs-bindgen/src/HsBindgen/Lib.hs
Original file line number Diff line number Diff line change
Expand Up @@ -80,7 +80,7 @@ import HsBindgen.ModuleUnique
import HsBindgen.Pipeline qualified as Pipeline
import HsBindgen.Resolve qualified as Resolve
import HsBindgen.Util.Trace qualified as Trace
import HsBindgen.Util.Tracer hiding (withTracerQ)
import HsBindgen.Util.Tracer

{-------------------------------------------------------------------------------
Parsing and translating
Expand Down
Loading
Loading