Merge pull request #666 from well-typed/dom/662-tracers-log-level-improvements

Tracers log level improvements

Author: dschrempf

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

@@ -39,7 +39,7 @@ data GlobalOpts = GlobalOpts {
     , globalOptsClangArgs   :: ClangArgs
     , globalOptsExtBindings :: [FilePath]
     }
-  deriving (Show)
+  deriving stock (Show)
 
 parseGlobalOpts :: Parser GlobalOpts
 parseGlobalOpts =
@@ -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 [

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

@@ -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

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

@@ -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 ()

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

@@ -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
@@ -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 ->
@@ -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 {

hs-bindgen/hs-bindgen.cabal

@@ -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
@@ -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:
@@ -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
 
@@ -361,6 +372,8 @@ test-suite test-pp
   build-depends:
       -- Internal dependencies
     , c-expr
+    , clang
+    , hs-bindgen
     , hs-bindgen-runtime
   build-depends:
       -- Inherited dependencies

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

@@ -29,6 +29,7 @@ data ExtraClangArgsLog =
     ExtraClangArgsNone
   | ExtraClangArgsParsed { envName    :: String
                          , envArgs    :: [String] }
+  deriving stock (Show)
 
 instance PrettyTrace ExtraClangArgsLog where
   prettyTrace = \case

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

@@ -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),
@@ -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)
 
 {-------------------------------------------------------------------------------
@@ -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
@@ -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"
@@ -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
@@ -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
 
@@ -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)

hs-bindgen/src/HsBindgen/Lib.hs

@@ -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