never executed always true always false
    1 {-# LANGUAGE RankNTypes #-}
    2 
    3 -- | Logger
    4 --
    5 -- The Logger is an configurable entity that is used by the compiler to output
    6 -- messages on the console (stdout, stderr) and in dump files.
    7 --
    8 -- The behaviour of default Logger returned by `initLogger` can be modified with
    9 -- hooks. The compiler itself uses hooks in multithreaded code (--make) and it
   10 -- is also probably used by ghc-api users (IDEs, etc.).
   11 --
   12 -- In addition to hooks, the Logger suppors LogFlags: basically a subset of the
   13 -- command-line flags that control the logger behaviour at a higher level than
   14 -- hooks.
   15 --
   16 --  1. Hooks are used to define how to generate a info/warning/error/dump messages
   17 --  2. LogFlags are used to decide when and how to generate messages
   18 --
   19 module GHC.Utils.Logger
   20     ( Logger
   21     , HasLogger (..)
   22     , ContainsLogger (..)
   23 
   24     -- * Logger setup
   25     , initLogger
   26     , LogAction
   27     , DumpAction
   28     , TraceAction
   29     , DumpFormat (..)
   30 
   31     -- ** Hooks
   32     , popLogHook
   33     , pushLogHook
   34     , popDumpHook
   35     , pushDumpHook
   36     , popTraceHook
   37     , pushTraceHook
   38     , makeThreadSafe
   39 
   40     -- ** Flags
   41     , LogFlags (..)
   42     , defaultLogFlags
   43     , log_dopt
   44     , log_set_dopt
   45     , setLogFlags
   46     , updateLogFlags
   47     , logFlags
   48     , logHasDumpFlag
   49     , logVerbAtLeast
   50 
   51     -- * Logging
   52     , jsonLogAction
   53     , putLogMsg
   54     , defaultLogAction
   55     , defaultLogActionHPrintDoc
   56     , defaultLogActionHPutStrDoc
   57     , logMsg
   58     , logDumpMsg
   59 
   60     -- * Dumping
   61     , defaultDumpAction
   62     , putDumpFile
   63     , putDumpFileMaybe
   64     , putDumpFileMaybe'
   65     , withDumpFileHandle
   66     , touchDumpFile
   67     , logDumpFile
   68 
   69     -- * Tracing
   70     , defaultTraceAction
   71     , putTraceMsg
   72     , loggerTraceFlushUpdate
   73     , loggerTraceFlush
   74     , logTraceMsg
   75     )
   76 where
   77 
   78 import GHC.Prelude
   79 import GHC.Driver.Flags
   80 import GHC.Types.Error
   81 import GHC.Types.SrcLoc
   82 
   83 import qualified GHC.Utils.Ppr as Pretty
   84 import GHC.Utils.Outputable
   85 import GHC.Utils.Json
   86 import GHC.Utils.Panic
   87 
   88 import GHC.Data.EnumSet (EnumSet)
   89 import qualified GHC.Data.EnumSet as EnumSet
   90 
   91 import Data.IORef
   92 import System.Directory
   93 import System.FilePath  ( takeDirectory, (</>) )
   94 import qualified Data.Set as Set
   95 import Data.Set (Set)
   96 import Data.List (intercalate, stripPrefix)
   97 import qualified Data.List.NonEmpty as NE
   98 import Data.Time
   99 import System.IO
  100 import Control.Monad
  101 import Control.Concurrent.MVar
  102 import System.IO.Unsafe
  103 import Debug.Trace (trace)
  104 
  105 ---------------------------------------------------------------
  106 -- Log flags
  107 ---------------------------------------------------------------
  108 
  109 -- | Logger flags
  110 data LogFlags = LogFlags
  111   { log_default_user_context :: SDocContext
  112   , log_default_dump_context :: SDocContext
  113   , log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags
  114   , log_show_caret           :: !Bool               -- ^ Show caret in diagnostics
  115   , log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups
  116   , log_enable_timestamps    :: !Bool               -- ^ Enable timestamps
  117   , log_dump_to_file         :: !Bool               -- ^ Enable dump to file
  118   , log_dump_dir             :: !(Maybe FilePath)   -- ^ Dump directory
  119   , log_dump_prefix          :: !(Maybe FilePath)   -- ^ Normal dump path ("basename.")
  120   , log_dump_prefix_override :: !(Maybe FilePath)   -- ^ Overriden dump path
  121   , log_enable_debug         :: !Bool               -- ^ Enable debug output
  122   , log_verbosity            :: !Int                -- ^ Verbosity level
  123   }
  124 
  125 -- | Default LogFlags
  126 defaultLogFlags :: LogFlags
  127 defaultLogFlags = LogFlags
  128   { log_default_user_context = defaultSDocContext
  129   , log_default_dump_context = defaultSDocContext
  130   , log_dump_flags           = EnumSet.empty
  131   , log_show_caret           = True
  132   , log_show_warn_groups     = True
  133   , log_enable_timestamps    = True
  134   , log_dump_to_file         = False
  135   , log_dump_dir             = Nothing
  136   , log_dump_prefix          = Nothing
  137   , log_dump_prefix_override = Nothing
  138   , log_enable_debug         = False
  139   , log_verbosity            = 0
  140   }
  141 
  142 -- | Test if a DumpFlag is enabled
  143 log_dopt :: DumpFlag -> LogFlags -> Bool
  144 log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags
  145 
  146 -- | Enable a DumpFlag
  147 log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
  148 log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) }
  149 
  150 -- | Test if a DumpFlag is set
  151 logHasDumpFlag :: Logger -> DumpFlag -> Bool
  152 logHasDumpFlag logger f = log_dopt f (logFlags logger)
  153 
  154 -- | Test if verbosity is >= to the given value
  155 logVerbAtLeast :: Logger -> Int -> Bool
  156 logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v
  157 
  158 -- | Update LogFlags
  159 updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
  160 updateLogFlags logger f = setLogFlags logger (f (logFlags logger))
  161 
  162 -- | Set LogFlags
  163 setLogFlags :: Logger -> LogFlags -> Logger
  164 setLogFlags logger flags = logger { logFlags = flags }
  165 
  166 
  167 ---------------------------------------------------------------
  168 -- Logger
  169 ---------------------------------------------------------------
  170 
  171 type LogAction = LogFlags
  172               -> MessageClass
  173               -> SrcSpan
  174               -> SDoc
  175               -> IO ()
  176 
  177 type DumpAction = LogFlags
  178                -> PprStyle
  179                -> DumpFlag
  180                -> String
  181                -> DumpFormat
  182                -> SDoc
  183                -> IO ()
  184 
  185 type TraceAction a = LogFlags -> String -> SDoc -> a -> a
  186 
  187 -- | Format of a dump
  188 --
  189 -- Dump formats are loosely defined: dumps may contain various additional
  190 -- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
  191 -- (e.g. for syntax highlighters).
  192 data DumpFormat
  193    = FormatHaskell   -- ^ Haskell
  194    | FormatCore      -- ^ Core
  195    | FormatSTG       -- ^ STG
  196    | FormatByteCode  -- ^ ByteCode
  197    | FormatCMM       -- ^ Cmm
  198    | FormatASM       -- ^ Assembly code
  199    | FormatC         -- ^ C code/header
  200    | FormatLLVM      -- ^ LLVM bytecode
  201    | FormatText      -- ^ Unstructured dump
  202    deriving (Show,Eq)
  203 
  204 type DumpCache = IORef (Set FilePath)
  205 
  206 data Logger = Logger
  207     { log_hook   :: [LogAction -> LogAction]
  208         -- ^ Log hooks stack
  209 
  210     , dump_hook  :: [DumpAction -> DumpAction]
  211         -- ^ Dump hooks stack
  212 
  213     , trace_hook :: forall a. [TraceAction a -> TraceAction a]
  214         -- ^ Trace hooks stack
  215 
  216     , generated_dumps :: DumpCache
  217         -- ^ Already dumped files (to append instead of overwriting them)
  218 
  219     , trace_flush :: IO ()
  220         -- ^ Flush the trace buffer
  221 
  222     , logFlags :: !LogFlags
  223         -- ^ Logger flags
  224     }
  225 
  226 -- | Set the trace flushing function
  227 --
  228 -- The currently set trace flushing function is passed to the updating function
  229 loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
  230 loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) }
  231 
  232 -- | Calls the trace flushing function
  233 loggerTraceFlush :: Logger -> IO ()
  234 loggerTraceFlush logger = trace_flush logger
  235 
  236 -- | Default trace flushing function (flush stderr)
  237 defaultTraceFlush :: IO ()
  238 defaultTraceFlush = hFlush stderr
  239 
  240 initLogger :: IO Logger
  241 initLogger = do
  242     dumps <- newIORef Set.empty
  243     return $ Logger
  244         { log_hook        = []
  245         , dump_hook       = []
  246         , trace_hook      = []
  247         , generated_dumps = dumps
  248         , trace_flush     = defaultTraceFlush
  249         , logFlags        = defaultLogFlags
  250         }
  251 
  252 -- | Log something
  253 putLogMsg :: Logger -> LogAction
  254 putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
  255 
  256 -- | Dump something
  257 putDumpFile :: Logger -> DumpAction
  258 putDumpFile logger =
  259     let
  260         fallback = putLogMsg logger
  261         dumps    = generated_dumps logger
  262         deflt    = defaultDumpAction dumps fallback
  263     in foldr ($) deflt (dump_hook logger)
  264 
  265 -- | Trace something
  266 putTraceMsg :: Logger -> TraceAction a
  267 putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)
  268 
  269 
  270 -- | Push a log hook
  271 pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
  272 pushLogHook h logger = logger { log_hook = h:log_hook logger }
  273 
  274 -- | Pop a log hook
  275 popLogHook :: Logger -> Logger
  276 popLogHook logger = case log_hook logger of
  277     []   -> panic "popLogHook: empty hook stack"
  278     _:hs -> logger { log_hook = hs }
  279 
  280 -- | Push a dump hook
  281 pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
  282 pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
  283 
  284 -- | Pop a dump hook
  285 popDumpHook :: Logger -> Logger
  286 popDumpHook logger = case dump_hook logger of
  287     []   -> panic "popDumpHook: empty hook stack"
  288     _:hs -> logger { dump_hook = hs }
  289 
  290 -- | Push a trace hook
  291 pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
  292 pushTraceHook h logger = logger { trace_hook = h:trace_hook logger }
  293 
  294 -- | Pop a trace hook
  295 popTraceHook :: Logger -> Logger
  296 popTraceHook logger = case trace_hook logger of
  297     [] -> panic "popTraceHook: empty hook stack"
  298     _  -> logger { trace_hook = tail (trace_hook logger) }
  299 
  300 -- | Make the logger thread-safe
  301 makeThreadSafe :: Logger -> IO Logger
  302 makeThreadSafe logger = do
  303     lock <- newMVar ()
  304     let
  305         with_lock :: forall a. IO a -> IO a
  306         with_lock act = withMVar lock (const act)
  307 
  308         log action logflags msg_class loc doc =
  309             with_lock (action logflags msg_class loc doc)
  310 
  311         dmp action logflags sty opts str fmt doc =
  312             with_lock (action logflags sty opts str fmt doc)
  313 
  314         trc :: forall a. TraceAction a -> TraceAction a
  315         trc action logflags str doc v =
  316             unsafePerformIO (with_lock (return $! action logflags str doc v))
  317 
  318     return $ pushLogHook log
  319            $ pushDumpHook dmp
  320            $ pushTraceHook trc
  321            $ logger
  322 
  323 -- See Note [JSON Error Messages]
  324 --
  325 jsonLogAction :: LogAction
  326 jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message
  327 jsonLogAction logflags msg_class srcSpan msg
  328   =
  329     defaultLogActionHPutStrDoc logflags True stdout
  330       (withPprStyle (PprCode CStyle) (doc $$ text ""))
  331     where
  332       str = renderWithContext (log_default_user_context logflags) msg
  333       doc = renderJSON $
  334               JSObject [ ( "span", json srcSpan )
  335                        , ( "doc" , JSString str )
  336                        , ( "messageClass", json msg_class )
  337                        ]
  338 
  339 defaultLogAction :: LogAction
  340 defaultLogAction logflags msg_class srcSpan msg
  341   | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg
  342   | otherwise = case msg_class of
  343       MCOutput                 -> printOut msg
  344       MCDump                   -> printOut (msg $$ blankLine)
  345       MCInteractive            -> putStrSDoc msg
  346       MCInfo                   -> printErrs msg
  347       MCFatal                  -> printErrs msg
  348       MCDiagnostic SevIgnore _ -> pure () -- suppress the message
  349       MCDiagnostic sev rea     -> printDiagnostics sev rea
  350     where
  351       printOut   = defaultLogActionHPrintDoc  logflags False stdout
  352       printErrs  = defaultLogActionHPrintDoc  logflags False stderr
  353       putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
  354       -- Pretty print the warning flag, if any (#10752)
  355       message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg
  356 
  357       printDiagnostics severity reason = do
  358         hPutChar stderr '\n'
  359         caretDiagnostic <-
  360             if log_show_caret logflags
  361             then getCaretDiagnostic msg_class srcSpan
  362             else pure empty
  363         printErrs $ getPprStyle $ \style ->
  364           withPprStyle (setStyleColoured True style)
  365             (message severity reason $+$ caretDiagnostic)
  366         -- careful (#2302): printErrs prints in UTF-8,
  367         -- whereas converting to string first and using
  368         -- hPutStr would just emit the low 8 bits of
  369         -- each unicode char.
  370 
  371       flagMsg :: Severity -> DiagnosticReason -> Maybe String
  372       flagMsg SevIgnore _                 =  panic "Called flagMsg with SevIgnore"
  373       flagMsg SevError WarningWithoutFlag =  Just "-Werror"
  374       flagMsg SevError (WarningWithFlag wflag) = do
  375         let name = NE.head (warnFlagNames wflag)
  376         return $
  377           "-W" ++ name ++ warnFlagGrp wflag ++
  378           ", -Werror=" ++ name
  379       flagMsg SevError ErrorWithoutFlag = Nothing
  380       flagMsg SevWarning WarningWithoutFlag = Nothing
  381       flagMsg SevWarning (WarningWithFlag wflag) = do
  382         let name = NE.head (warnFlagNames wflag)
  383         return ("-W" ++ name ++ warnFlagGrp wflag)
  384       flagMsg SevWarning ErrorWithoutFlag =
  385         panic "SevWarning with ErrorWithoutFlag"
  386 
  387       warnFlagGrp flag
  388           | log_show_warn_groups logflags =
  389                 case smallestWarningGroups flag of
  390                     [] -> ""
  391                     groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
  392           | otherwise = ""
  393 
  394 -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
  395 defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
  396 defaultLogActionHPrintDoc logflags asciiSpace h d
  397  = defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "")
  398 
  399 -- | The boolean arguments let's the pretty printer know if it can optimize indent
  400 -- by writing ascii ' ' characters without going through decoding.
  401 defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
  402 defaultLogActionHPutStrDoc logflags asciiSpace h d
  403   -- Don't add a newline at the end, so that successive
  404   -- calls to this log-action can output all on the same line
  405   = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
  406 
  407 --
  408 -- Note [JSON Error Messages]
  409 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
  410 --
  411 -- When the user requests the compiler output to be dumped as json
  412 -- we used to collect them all in an IORef and then print them at the end.
  413 -- This doesn't work very well with GHCi. (See #14078) So instead we now
  414 -- use the simpler method of just outputting a JSON document inplace to
  415 -- stdout.
  416 --
  417 -- Before the compiler calls log_action, it has already turned the `ErrMsg`
  418 -- into a formatted message. This means that we lose some possible
  419 -- information to provide to the user but refactoring log_action is quite
  420 -- invasive as it is called in many places. So, for now I left it alone
  421 -- and we can refine its behaviour as users request different output.
  422 
  423 -- | Default action for 'dumpAction' hook
  424 defaultDumpAction :: DumpCache -> LogAction -> DumpAction
  425 defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
  426   dumpSDocWithStyle dumps log_action sty logflags flag title doc
  427 
  428 -- | Write out a dump.
  429 --
  430 -- If --dump-to-file is set then this goes to a file.
  431 -- otherwise emit to stdout (via the the LogAction parameter).
  432 --
  433 -- When @hdr@ is empty, we print in a more compact format (no separators and
  434 -- blank lines)
  435 dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()
  436 dumpSDocWithStyle dumps log_action sty logflags flag hdr doc =
  437     withDumpFileHandle dumps logflags flag writeDump
  438   where
  439     -- write dump to file
  440     writeDump (Just handle) = do
  441         doc' <- if null hdr
  442                 then return doc
  443                 else do timeStamp <- if log_enable_timestamps logflags
  444                           then (text . show) <$> getCurrentTime
  445                           else pure empty
  446                         let d = timeStamp
  447                                 $$ blankLine
  448                                 $$ doc
  449                         return $ mkDumpDoc hdr d
  450         -- When we dump to files we use UTF8. Which allows ascii spaces.
  451         defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc')
  452 
  453     -- write the dump to stdout
  454     writeDump Nothing = do
  455         let (doc', msg_class)
  456               | null hdr  = (doc, MCOutput)
  457               | otherwise = (mkDumpDoc hdr doc, MCDump)
  458         log_action logflags msg_class noSrcSpan (withPprStyle sty doc')
  459 
  460 
  461 -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
  462 -- file, otherwise 'Nothing'.
  463 withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
  464 withDumpFileHandle dumps logflags flag action = do
  465     let mFile = chooseDumpFile logflags flag
  466     case mFile of
  467       Just fileName -> do
  468         gd <- readIORef dumps
  469         let append = Set.member fileName gd
  470             mode = if append then AppendMode else WriteMode
  471         unless append $
  472             writeIORef dumps (Set.insert fileName gd)
  473         createDirectoryIfMissing True (takeDirectory fileName)
  474         withFile fileName mode $ \handle -> do
  475             -- We do not want the dump file to be affected by
  476             -- environment variables, but instead to always use
  477             -- UTF8. See:
  478             -- https://gitlab.haskell.org/ghc/ghc/issues/10762
  479             hSetEncoding handle utf8
  480 
  481             action (Just handle)
  482       Nothing -> action Nothing
  483 
  484 -- | Choose where to put a dump file based on LogFlags and DumpFlag
  485 chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath
  486 chooseDumpFile logflags flag
  487     | log_dump_to_file logflags || forced_to_file
  488     , Just prefix <- getPrefix
  489     = Just $ setDir (prefix ++ dump_suffix)
  490 
  491     | otherwise
  492     = Nothing
  493   where
  494     (forced_to_file, dump_suffix) = case flag of
  495         -- -dth-dec-file dumps expansions of TH
  496         -- splices into MODULE.th.hs even when
  497         -- -ddump-to-file isn't set
  498         Opt_D_th_dec_file -> (True, "th.hs")
  499         _                 -> (False, default_suffix)
  500 
  501     -- build a suffix from the flag name
  502     -- e.g. -ddump-asm => ".dump-asm"
  503     default_suffix = map (\c -> if c == '_' then '-' else c) $
  504       let str = show flag
  505       in case stripPrefix "Opt_D_" str of
  506         Just x  -> x
  507         Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str)
  508 
  509     getPrefix
  510          -- dump file location is being forced
  511          --      by the --ddump-file-prefix flag.
  512        | Just prefix <- log_dump_prefix_override logflags
  513           = Just prefix
  514          -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
  515        | Just prefix <- log_dump_prefix logflags
  516           = Just prefix
  517          -- we haven't got a place to put a dump file.
  518        | otherwise
  519           = Nothing
  520     setDir f = case log_dump_dir logflags of
  521                  Just d  -> d </> f
  522                  Nothing ->       f
  523 
  524 
  525 
  526 -- | Default action for 'traceAction' hook
  527 defaultTraceAction :: TraceAction a
  528 defaultTraceAction logflags title doc x =
  529   if not (log_enable_debug logflags)
  530     then x
  531     else trace (renderWithContext (log_default_dump_context logflags)
  532                              (sep [text title, nest 2 doc])) x
  533 
  534 
  535 -- | Log something
  536 logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
  537 logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
  538 
  539 -- | Dump something
  540 logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
  541 logDumpFile logger = putDumpFile logger (logFlags logger)
  542 
  543 -- | Log a trace message
  544 logTraceMsg :: Logger -> String -> SDoc -> a -> a
  545 logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a
  546 
  547 -- | Log a dump message (not a dump file)
  548 logDumpMsg :: Logger -> String -> SDoc -> IO ()
  549 logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan
  550   (withPprStyle defaultDumpStyle
  551   (mkDumpDoc hdr doc))
  552 
  553 mkDumpDoc :: String -> SDoc -> SDoc
  554 mkDumpDoc hdr doc
  555    = vcat [blankLine,
  556            line <+> text hdr <+> line,
  557            doc,
  558            blankLine]
  559      where
  560         line = text "===================="
  561 
  562 
  563 -- | Dump if the given DumpFlag is set
  564 putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
  565 putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify
  566 {-# INLINE putDumpFileMaybe #-}  -- see Note [INLINE conditional tracing utilities]
  567 
  568 -- | Dump if the given DumpFlag is set
  569 --
  570 -- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument
  571 putDumpFileMaybe'
  572     :: Logger
  573     -> PrintUnqualified
  574     -> DumpFlag
  575     -> String
  576     -> DumpFormat
  577     -> SDoc
  578     -> IO ()
  579 putDumpFileMaybe' logger printer flag hdr fmt doc
  580   = when (logHasDumpFlag logger flag) $
  581     logDumpFile' logger printer flag hdr fmt doc
  582 {-# INLINE putDumpFileMaybe' #-}  -- see Note [INLINE conditional tracing utilities]
  583 
  584 
  585 logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag
  586              -> String -> DumpFormat -> SDoc -> IO ()
  587 {-# NOINLINE logDumpFile' #-}
  588 -- NOINLINE: Now we are past the conditional, into the "cold" path,
  589 --           don't inline, to reduce code size at the call site
  590 -- See Note [INLINE conditional tracing utilities]
  591 logDumpFile' logger printer flag hdr fmt doc
  592   = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc
  593 
  594 -- | Ensure that a dump file is created even if it stays empty
  595 touchDumpFile :: Logger -> DumpFlag -> IO ()
  596 touchDumpFile logger flag =
  597     withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ()))
  598 
  599 class HasLogger m where
  600     getLogger :: m Logger
  601 
  602 class ContainsLogger t where
  603     extractLogger :: t -> Logger
  604