{-# LANGUAGE RankNTypes #-}

-- | Logger
--
-- The Logger is an configurable entity that is used by the compiler to output
-- messages on the console (stdout, stderr) and in dump files.
--
-- The behaviour of default Logger returned by `initLogger` can be modified with
-- hooks. The compiler itself uses hooks in multithreaded code (--make) and it
-- is also probably used by ghc-api users (IDEs, etc.).
--
-- In addition to hooks, the Logger suppors LogFlags: basically a subset of the
-- command-line flags that control the logger behaviour at a higher level than
-- hooks.
--
--  1. Hooks are used to define how to generate a info/warning/error/dump messages
--  2. LogFlags are used to decide when and how to generate messages
--
module GHC.Utils.Logger
    ( Logger
    , HasLogger (..)
    , ContainsLogger (..)

    -- * Logger setup
    , initLogger
    , LogAction
    , DumpAction
    , TraceAction
    , DumpFormat (..)

    -- ** Hooks
    , popLogHook
    , pushLogHook
    , popDumpHook
    , pushDumpHook
    , popTraceHook
    , pushTraceHook
    , makeThreadSafe

    -- ** Flags
    , LogFlags (..)
    , defaultLogFlags
    , log_dopt
    , log_set_dopt
    , setLogFlags
    , updateLogFlags
    , logFlags
    , logHasDumpFlag
    , logVerbAtLeast

    -- * Logging
    , jsonLogAction
    , putLogMsg
    , defaultLogAction
    , defaultLogActionHPrintDoc
    , defaultLogActionHPutStrDoc
    , logMsg
    , logDumpMsg

    -- * Dumping
    , defaultDumpAction
    , putDumpFile
    , putDumpFileMaybe
    , putDumpFileMaybe'
    , withDumpFileHandle
    , touchDumpFile
    , logDumpFile

    -- * Tracing
    , defaultTraceAction
    , putTraceMsg
    , loggerTraceFlushUpdate
    , loggerTraceFlush
    , logTraceMsg
    )
where

import GHC.Prelude
import GHC.Driver.Flags
import GHC.Types.Error
import GHC.Types.SrcLoc

import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Outputable
import GHC.Utils.Json
import GHC.Utils.Panic

import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet

import Data.IORef
import System.Directory
import System.FilePath  ( takeDirectory, (</>) )
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (intercalate, stripPrefix)
import qualified Data.List.NonEmpty as NE
import Data.Time
import System.IO
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe
import Debug.Trace (trace)

---------------------------------------------------------------
-- Log flags
---------------------------------------------------------------

-- | Logger flags
data LogFlags = LogFlags
  { LogFlags -> SDocContext
log_default_user_context :: SDocContext
  , LogFlags -> SDocContext
log_default_dump_context :: SDocContext
  , LogFlags -> EnumSet DumpFlag
log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags
  , LogFlags -> Bool
log_show_caret           :: !Bool               -- ^ Show caret in diagnostics
  , LogFlags -> Bool
log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups
  , LogFlags -> Bool
log_enable_timestamps    :: !Bool               -- ^ Enable timestamps
  , LogFlags -> Bool
log_dump_to_file         :: !Bool               -- ^ Enable dump to file
  , LogFlags -> Maybe FilePath
log_dump_dir             :: !(Maybe FilePath)   -- ^ Dump directory
  , LogFlags -> FilePath
log_dump_prefix          :: !FilePath           -- ^ Normal dump path ("basename.")
  , LogFlags -> Maybe FilePath
log_dump_prefix_override :: !(Maybe FilePath)   -- ^ Overriden dump path
  , LogFlags -> Bool
log_enable_debug         :: !Bool               -- ^ Enable debug output
  , LogFlags -> Int
log_verbosity            :: !Int                -- ^ Verbosity level
  }

-- | Default LogFlags
defaultLogFlags :: LogFlags
defaultLogFlags :: LogFlags
defaultLogFlags = LogFlags
  { log_default_user_context :: SDocContext
log_default_user_context = SDocContext
defaultSDocContext
  , log_default_dump_context :: SDocContext
log_default_dump_context = SDocContext
defaultSDocContext
  , log_dump_flags :: EnumSet DumpFlag
log_dump_flags           = EnumSet DumpFlag
forall a. EnumSet a
EnumSet.empty
  , log_show_caret :: Bool
log_show_caret           = Bool
True
  , log_show_warn_groups :: Bool
log_show_warn_groups     = Bool
True
  , log_enable_timestamps :: Bool
log_enable_timestamps    = Bool
True
  , log_dump_to_file :: Bool
log_dump_to_file         = Bool
False
  , log_dump_dir :: Maybe FilePath
log_dump_dir             = Maybe FilePath
forall a. Maybe a
Nothing
  , log_dump_prefix :: FilePath
log_dump_prefix          = FilePath
""
  , log_dump_prefix_override :: Maybe FilePath
log_dump_prefix_override = Maybe FilePath
forall a. Maybe a
Nothing
  , log_enable_debug :: Bool
log_enable_debug         = Bool
False
  , log_verbosity :: Int
log_verbosity            = Int
0
  }

-- | Test if a DumpFlag is enabled
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
f LogFlags
logflags = DumpFlag
f DumpFlag -> EnumSet DumpFlag -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
`EnumSet.member` LogFlags -> EnumSet DumpFlag
log_dump_flags LogFlags
logflags

-- | Enable a DumpFlag
log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
f LogFlags
logflags = LogFlags
logflags { log_dump_flags :: EnumSet DumpFlag
log_dump_flags = DumpFlag -> EnumSet DumpFlag -> EnumSet DumpFlag
forall a. Enum a => a -> EnumSet a -> EnumSet a
EnumSet.insert DumpFlag
f (LogFlags -> EnumSet DumpFlag
log_dump_flags LogFlags
logflags) }

-- | Test if a DumpFlag is set
logHasDumpFlag :: Logger -> DumpFlag -> Bool
logHasDumpFlag :: Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
f = DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
f (Logger -> LogFlags
logFlags Logger
logger)

-- | Test if verbosity is >= to the given value
logVerbAtLeast :: Logger -> Int -> Bool
logVerbAtLeast :: Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
v = LogFlags -> Int
log_verbosity (Logger -> LogFlags
logFlags Logger
logger) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
v

-- | Update LogFlags
updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger LogFlags -> LogFlags
f = Logger -> LogFlags -> Logger
setLogFlags Logger
logger (LogFlags -> LogFlags
f (Logger -> LogFlags
logFlags Logger
logger))

-- | Set LogFlags
setLogFlags :: Logger -> LogFlags -> Logger
setLogFlags :: Logger -> LogFlags -> Logger
setLogFlags Logger
logger LogFlags
flags = Logger
logger { logFlags :: LogFlags
logFlags = LogFlags
flags }


---------------------------------------------------------------
-- Logger
---------------------------------------------------------------

type LogAction = LogFlags
              -> MessageClass
              -> SrcSpan
              -> SDoc
              -> IO ()

type DumpAction = LogFlags
               -> PprStyle
               -> DumpFlag
               -> String
               -> DumpFormat
               -> SDoc
               -> IO ()

type TraceAction a = LogFlags -> String -> SDoc -> a -> a

-- | Format of a dump
--
-- Dump formats are loosely defined: dumps may contain various additional
-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
-- (e.g. for syntax highlighters).
data DumpFormat
   = FormatHaskell   -- ^ Haskell
   | FormatCore      -- ^ Core
   | FormatSTG       -- ^ STG
   | FormatByteCode  -- ^ ByteCode
   | FormatCMM       -- ^ Cmm
   | FormatASM       -- ^ Assembly code
   | FormatC         -- ^ C code/header
   | FormatLLVM      -- ^ LLVM bytecode
   | FormatText      -- ^ Unstructured dump
   deriving (Int -> DumpFormat -> ShowS
[DumpFormat] -> ShowS
DumpFormat -> FilePath
(Int -> DumpFormat -> ShowS)
-> (DumpFormat -> FilePath)
-> ([DumpFormat] -> ShowS)
-> Show DumpFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DumpFormat -> ShowS
showsPrec :: Int -> DumpFormat -> ShowS
$cshow :: DumpFormat -> FilePath
show :: DumpFormat -> FilePath
$cshowList :: [DumpFormat] -> ShowS
showList :: [DumpFormat] -> ShowS
Show,DumpFormat -> DumpFormat -> Bool
(DumpFormat -> DumpFormat -> Bool)
-> (DumpFormat -> DumpFormat -> Bool) -> Eq DumpFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DumpFormat -> DumpFormat -> Bool
== :: DumpFormat -> DumpFormat -> Bool
$c/= :: DumpFormat -> DumpFormat -> Bool
/= :: DumpFormat -> DumpFormat -> Bool
Eq)

type DumpCache = IORef (Set FilePath)

data Logger = Logger
    { Logger -> [LogAction -> LogAction]
log_hook   :: [LogAction -> LogAction]
        -- ^ Log hooks stack

    , Logger -> [DumpAction -> DumpAction]
dump_hook  :: [DumpAction -> DumpAction]
        -- ^ Dump hooks stack

    , Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook :: forall a. [TraceAction a -> TraceAction a]
        -- ^ Trace hooks stack

    , Logger -> DumpCache
generated_dumps :: DumpCache
        -- ^ Already dumped files (to append instead of overwriting them)

    , Logger -> IO ()
trace_flush :: IO ()
        -- ^ Flush the trace buffer

    , Logger -> LogFlags
logFlags :: !LogFlags
        -- ^ Logger flags
    }

-- | Set the trace flushing function
--
-- The currently set trace flushing function is passed to the updating function
loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
loggerTraceFlushUpdate Logger
logger IO () -> IO ()
upd = Logger
logger { trace_flush :: IO ()
trace_flush = IO () -> IO ()
upd (Logger -> IO ()
trace_flush Logger
logger) }

-- | Calls the trace flushing function
loggerTraceFlush :: Logger -> IO ()
loggerTraceFlush :: Logger -> IO ()
loggerTraceFlush Logger
logger = Logger -> IO ()
trace_flush Logger
logger

-- | Default trace flushing function (flush stderr)
defaultTraceFlush :: IO ()
defaultTraceFlush :: IO ()
defaultTraceFlush = Handle -> IO ()
hFlush Handle
stderr

initLogger :: IO Logger
initLogger :: IO Logger
initLogger = do
    DumpCache
dumps <- Set FilePath -> IO DumpCache
forall a. a -> IO (IORef a)
newIORef Set FilePath
forall a. Set a
Set.empty
    Logger -> IO Logger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ Logger
        { log_hook :: [LogAction -> LogAction]
log_hook        = []
        , dump_hook :: [DumpAction -> DumpAction]
dump_hook       = []
        , trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook      = []
        , generated_dumps :: DumpCache
generated_dumps = DumpCache
dumps
        , trace_flush :: IO ()
trace_flush     = IO ()
defaultTraceFlush
        , logFlags :: LogFlags
logFlags        = LogFlags
defaultLogFlags
        }

-- | Log something
putLogMsg :: Logger -> LogAction
putLogMsg :: Logger -> LogAction
putLogMsg Logger
logger = ((LogAction -> LogAction) -> LogAction -> LogAction)
-> LogAction -> [LogAction -> LogAction] -> LogAction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LogAction -> LogAction) -> LogAction -> LogAction
forall a b. (a -> b) -> a -> b
($) LogAction
defaultLogAction (Logger -> [LogAction -> LogAction]
log_hook Logger
logger)

-- | Dump something
putDumpFile :: Logger -> DumpAction
putDumpFile :: Logger -> DumpAction
putDumpFile Logger
logger =
    let
        fallback :: LogAction
fallback = Logger -> LogAction
putLogMsg Logger
logger
        dumps :: DumpCache
dumps    = Logger -> DumpCache
generated_dumps Logger
logger
        deflt :: DumpAction
deflt    = DumpCache -> LogAction -> DumpAction
defaultDumpAction DumpCache
dumps LogAction
fallback
    in ((DumpAction -> DumpAction) -> DumpAction -> DumpAction)
-> DumpAction -> [DumpAction -> DumpAction] -> DumpAction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DumpAction -> DumpAction) -> DumpAction -> DumpAction
forall a b. (a -> b) -> a -> b
($) DumpAction
deflt (Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger)

-- | Trace something
putTraceMsg :: Logger -> TraceAction a
putTraceMsg :: forall a. Logger -> TraceAction a
putTraceMsg Logger
logger = ((TraceAction a -> TraceAction a)
 -> TraceAction a -> TraceAction a)
-> TraceAction a
-> [TraceAction a -> TraceAction a]
-> TraceAction a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TraceAction a -> TraceAction a) -> TraceAction a -> TraceAction a
forall a b. (a -> b) -> a -> b
($) TraceAction a
forall a. TraceAction a
defaultTraceAction (Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger)


-- | Push a log hook
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
pushLogHook LogAction -> LogAction
h Logger
logger = Logger
logger { log_hook :: [LogAction -> LogAction]
log_hook = LogAction -> LogAction
h(LogAction -> LogAction)
-> [LogAction -> LogAction] -> [LogAction -> LogAction]
forall a. a -> [a] -> [a]
:Logger -> [LogAction -> LogAction]
log_hook Logger
logger }

-- | Pop a log hook
popLogHook :: Logger -> Logger
popLogHook :: Logger -> Logger
popLogHook Logger
logger = case Logger -> [LogAction -> LogAction]
log_hook Logger
logger of
    []   -> FilePath -> Logger
forall a. FilePath -> a
panic FilePath
"popLogHook: empty hook stack"
    LogAction -> LogAction
_:[LogAction -> LogAction]
hs -> Logger
logger { log_hook :: [LogAction -> LogAction]
log_hook = [LogAction -> LogAction]
hs }

-- | Push a dump hook
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook DumpAction -> DumpAction
h Logger
logger = Logger
logger { dump_hook :: [DumpAction -> DumpAction]
dump_hook = DumpAction -> DumpAction
h(DumpAction -> DumpAction)
-> [DumpAction -> DumpAction] -> [DumpAction -> DumpAction]
forall a. a -> [a] -> [a]
:Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger }

-- | Pop a dump hook
popDumpHook :: Logger -> Logger
popDumpHook :: Logger -> Logger
popDumpHook Logger
logger = case Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger of
    []   -> FilePath -> Logger
forall a. FilePath -> a
panic FilePath
"popDumpHook: empty hook stack"
    DumpAction -> DumpAction
_:[DumpAction -> DumpAction]
hs -> Logger
logger { dump_hook :: [DumpAction -> DumpAction]
dump_hook = [DumpAction -> DumpAction]
hs }

-- | Push a trace hook
pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook forall a. TraceAction a -> TraceAction a
h Logger
logger = Logger
logger { trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook = TraceAction a -> TraceAction a
forall a. TraceAction a -> TraceAction a
h(TraceAction a -> TraceAction a)
-> [TraceAction a -> TraceAction a]
-> [TraceAction a -> TraceAction a]
forall a. a -> [a] -> [a]
:Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger }

-- | Pop a trace hook
popTraceHook :: Logger -> Logger
popTraceHook :: Logger -> Logger
popTraceHook Logger
logger = case Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger of
    [] -> FilePath -> Logger
forall a. FilePath -> a
panic FilePath
"popTraceHook: empty hook stack"
    [TraceAction Any -> TraceAction Any]
_  -> Logger
logger { trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook = [TraceAction a -> TraceAction a]
-> [TraceAction a -> TraceAction a]
forall a. HasCallStack => [a] -> [a]
tail (Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger) }

-- | Make the logger thread-safe
makeThreadSafe :: Logger -> IO Logger
makeThreadSafe :: Logger -> IO Logger
makeThreadSafe Logger
logger = do
    MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let
        with_lock :: forall a. IO a -> IO a
        with_lock :: forall a. IO a -> IO a
with_lock IO a
act = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
act)

        log :: (t -> t -> t -> t -> IO a) -> t -> t -> t -> t -> IO a
log t -> t -> t -> t -> IO a
action t
logflags t
msg_class t
loc t
doc =
            IO a -> IO a
forall a. IO a -> IO a
with_lock (t -> t -> t -> t -> IO a
action t
logflags t
msg_class t
loc t
doc)

        dmp :: (t -> t -> t -> t -> t -> t -> IO a)
-> t -> t -> t -> t -> t -> t -> IO a
dmp t -> t -> t -> t -> t -> t -> IO a
action t
logflags t
sty t
opts t
str t
fmt t
doc =
            IO a -> IO a
forall a. IO a -> IO a
with_lock (t -> t -> t -> t -> t -> t -> IO a
action t
logflags t
sty t
opts t
str t
fmt t
doc)

        trc :: forall a. TraceAction a -> TraceAction a
        trc :: forall a. TraceAction a -> TraceAction a
trc TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v =
            IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> IO a
forall a. IO a -> IO a
with_lock (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v))

    Logger -> IO Logger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ (LogAction -> LogAction) -> Logger -> Logger
pushLogHook LogAction -> LogAction
forall {t} {t} {t} {t} {a}.
(t -> t -> t -> t -> IO a) -> t -> t -> t -> t -> IO a
log
           (Logger -> Logger) -> Logger -> Logger
forall a b. (a -> b) -> a -> b
$ (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook DumpAction -> DumpAction
forall {t} {t} {t} {t} {t} {t} {a}.
(t -> t -> t -> t -> t -> t -> IO a)
-> t -> t -> t -> t -> t -> t -> IO a
dmp
           (Logger -> Logger) -> Logger -> Logger
forall a b. (a -> b) -> a -> b
$ (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook TraceAction a -> TraceAction a
forall a. TraceAction a -> TraceAction a
trc
           (Logger -> Logger) -> Logger -> Logger
forall a b. (a -> b) -> a -> b
$ Logger
logger

-- See Note [JSON Error Messages]
--
jsonLogAction :: LogAction
jsonLogAction :: LogAction
jsonLogAction LogFlags
_ (MCDiagnostic Severity
SevIgnore DiagnosticReason
_) SrcSpan
_ SDoc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- suppress the message
jsonLogAction LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  =
    LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
True Handle
stdout
      (PprStyle -> SDoc -> SDoc
withPprStyle (LabelStyle -> PprStyle
PprCode LabelStyle
CStyle) (SDoc
doc SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
""))
    where
      str :: FilePath
str = SDocContext -> SDoc -> FilePath
renderWithContext (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) SDoc
msg
      doc :: SDoc
doc = JsonDoc -> SDoc
renderJSON (JsonDoc -> SDoc) -> JsonDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              [(FilePath, JsonDoc)] -> JsonDoc
JSObject [ ( FilePath
"span", SrcSpan -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json SrcSpan
srcSpan )
                       , ( FilePath
"doc" , FilePath -> JsonDoc
JSString FilePath
str )
                       , ( FilePath
"messageClass", MessageClass -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json MessageClass
msg_class )
                       ]

defaultLogAction :: LogAction
defaultLogAction :: LogAction
defaultLogAction LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  | DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
Opt_D_dump_json LogFlags
logflags = LogAction
jsonLogAction LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  | Bool
otherwise = case MessageClass
msg_class of
      MessageClass
MCOutput                 -> SDoc -> IO ()
printOut SDoc
msg
      MessageClass
MCDump                   -> SDoc -> IO ()
printOut (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
blankLine)
      MessageClass
MCInteractive            -> SDoc -> IO ()
putStrSDoc SDoc
msg
      MessageClass
MCInfo                   -> SDoc -> IO ()
printErrs SDoc
msg
      MessageClass
MCFatal                  -> SDoc -> IO ()
printErrs SDoc
msg
      MCDiagnostic Severity
SevIgnore DiagnosticReason
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- suppress the message
      MCDiagnostic Severity
sev DiagnosticReason
rea     -> Severity -> DiagnosticReason -> IO ()
printDiagnostics Severity
sev DiagnosticReason
rea
    where
      printOut :: SDoc -> IO ()
printOut   = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
stdout
      printErrs :: SDoc -> IO ()
printErrs  = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
stderr
      putStrSDoc :: SDoc -> IO ()
putStrSDoc = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
False Handle
stdout
      -- Pretty print the warning flag, if any (#10752)
      message :: Severity -> DiagnosticReason -> SDoc
message Severity
sev DiagnosticReason
rea = Maybe FilePath -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn (Severity -> DiagnosticReason -> Maybe FilePath
flagMsg Severity
sev DiagnosticReason
rea) MessageClass
msg_class SrcSpan
srcSpan SDoc
msg

      printDiagnostics :: Severity -> DiagnosticReason -> IO ()
printDiagnostics Severity
severity DiagnosticReason
reason = do
        Handle -> Char -> IO ()
hPutChar Handle
stderr Char
'\n'
        SDoc
caretDiagnostic <-
            if LogFlags -> Bool
log_show_caret LogFlags
logflags
            then MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
msg_class SrcSpan
srcSpan
            else SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
        SDoc -> IO ()
printErrs (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \PprStyle
style ->
          PprStyle -> SDoc -> SDoc
withPprStyle (Bool -> PprStyle -> PprStyle
setStyleColoured Bool
True PprStyle
style)
            (Severity -> DiagnosticReason -> SDoc
message Severity
severity DiagnosticReason
reason SDoc -> SDoc -> SDoc
$+$ SDoc
caretDiagnostic)
        -- careful (#2302): printErrs prints in UTF-8,
        -- whereas converting to string first and using
        -- hPutStr would just emit the low 8 bits of
        -- each unicode char.

      flagMsg :: Severity -> DiagnosticReason -> Maybe String
      flagMsg :: Severity -> DiagnosticReason -> Maybe FilePath
flagMsg Severity
SevIgnore DiagnosticReason
_                 =  FilePath -> Maybe FilePath
forall a. FilePath -> a
panic FilePath
"Called flagMsg with SevIgnore"
      flagMsg Severity
SevError DiagnosticReason
WarningWithoutFlag =  FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"-Werror"
      flagMsg Severity
SevError (WarningWithFlag WarningFlag
wflag) = do
        let name :: FilePath
name = NonEmpty FilePath -> FilePath
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty FilePath
warnFlagNames WarningFlag
wflag)
        FilePath -> Maybe FilePath
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
          FilePath
"-W" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> FilePath
warnFlagGrp WarningFlag
wflag FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
          FilePath
", -Werror=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
name
      flagMsg Severity
SevError DiagnosticReason
ErrorWithoutFlag = Maybe FilePath
forall a. Maybe a
Nothing
      flagMsg Severity
SevWarning DiagnosticReason
WarningWithoutFlag = Maybe FilePath
forall a. Maybe a
Nothing
      flagMsg Severity
SevWarning (WarningWithFlag WarningFlag
wflag) = do
        let name :: FilePath
name = NonEmpty FilePath -> FilePath
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty FilePath
warnFlagNames WarningFlag
wflag)
        FilePath -> Maybe FilePath
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
"-W" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> FilePath
warnFlagGrp WarningFlag
wflag)
      flagMsg Severity
SevWarning DiagnosticReason
ErrorWithoutFlag =
        FilePath -> Maybe FilePath
forall a. FilePath -> a
panic FilePath
"SevWarning with ErrorWithoutFlag"

      warnFlagGrp :: WarningFlag -> FilePath
warnFlagGrp WarningFlag
flag
          | LogFlags -> Bool
log_show_warn_groups LogFlags
logflags =
                case WarningFlag -> [FilePath]
smallestWarningGroups WarningFlag
flag of
                    [] -> FilePath
""
                    [FilePath]
groups -> FilePath
" (in " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-W"FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) [FilePath]
groups) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
")"
          | Bool
otherwise = FilePath
""

-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc LogFlags
logflags Bool
asciiSpace Handle
h SDoc
d
 = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
asciiSpace Handle
h (SDoc
d SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"")

-- | The boolean arguments let's the pretty printer know if it can optimize indent
-- by writing ascii ' ' characters without going through decoding.
defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
asciiSpace Handle
h SDoc
d
  -- Don't add a newline at the end, so that successive
  -- calls to this log-action can output all on the same line
  = SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDoc (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) (Bool -> Mode
Pretty.PageMode Bool
asciiSpace) Handle
h SDoc
d

--
-- Note [JSON Error Messages]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When the user requests the compiler output to be dumped as json
-- we used to collect them all in an IORef and then print them at the end.
-- This doesn't work very well with GHCi. (See #14078) So instead we now
-- use the simpler method of just outputting a JSON document inplace to
-- stdout.
--
-- Before the compiler calls log_action, it has already turned the `ErrMsg`
-- into a formatted message. This means that we lose some possible
-- information to provide to the user but refactoring log_action is quite
-- invasive as it is called in many places. So, for now I left it alone
-- and we can refine its behaviour as users request different output.

-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction DumpCache
dumps LogAction
log_action LogFlags
logflags PprStyle
sty DumpFlag
flag FilePath
title DumpFormat
_fmt SDoc
doc =
  DumpCache
-> LogAction
-> PprStyle
-> LogFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty LogFlags
logflags DumpFlag
flag FilePath
title SDoc
doc

-- | Write out a dump.
--
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout (via the the LogAction parameter).
--
-- When @hdr@ is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle :: DumpCache
-> LogAction
-> PprStyle
-> LogFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty LogFlags
logflags DumpFlag
flag FilePath
hdr SDoc
doc =
    DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps LogFlags
logflags DumpFlag
flag Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
        SDoc
doc' <- if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr
                then SDoc -> IO SDoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
                else do SDoc
timeStamp <- if LogFlags -> Bool
log_enable_timestamps LogFlags
logflags
                          then (FilePath -> SDoc
text (FilePath -> SDoc) -> (UTCTime -> FilePath) -> UTCTime -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> FilePath
forall a. Show a => a -> FilePath
show) (UTCTime -> SDoc) -> IO UTCTime -> IO SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
                          else SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
                        let d :: SDoc
d = SDoc
timeStamp
                                SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
                                SDoc -> SDoc -> SDoc
$$ SDoc
doc
                        SDoc -> IO SDoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> IO SDoc) -> SDoc -> IO SDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
d
        -- When we dump to files we use UTF8. Which allows ascii spaces.
        LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc LogFlags
logflags Bool
True Handle
handle (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
sty SDoc
doc')

    -- write the dump to stdout
    writeDump Maybe Handle
Nothing = do
        let (SDoc
doc', MessageClass
msg_class)
              | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr  = (SDoc
doc, MessageClass
MCOutput)
              | Bool
otherwise = (FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc, MessageClass
MCDump)
        LogAction
log_action LogFlags
logflags MessageClass
msg_class SrcSpan
noSrcSpan (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
sty SDoc
doc')


-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
-- file, otherwise 'Nothing'.
withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps LogFlags
logflags DumpFlag
flag Maybe Handle -> IO ()
action = do
    let mFile :: Maybe FilePath
mFile = LogFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile LogFlags
logflags DumpFlag
flag
    case Maybe FilePath
mFile of
      Just FilePath
fileName -> do
        Set FilePath
gd <- DumpCache -> IO (Set FilePath)
forall a. IORef a -> IO a
readIORef DumpCache
dumps
        let append :: Bool
append = FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
fileName Set FilePath
gd
            mode :: IOMode
mode = if Bool
append then IOMode
AppendMode else IOMode
WriteMode
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
append (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            DumpCache -> Set FilePath -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef DumpCache
dumps (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
fileName Set FilePath
gd)
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
fileName)
        FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fileName IOMode
mode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8

            Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
      Maybe FilePath
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing

-- | Choose where to put a dump file based on LogFlags and DumpFlag
chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile LogFlags
logflags DumpFlag
flag
    | LogFlags -> Bool
log_dump_to_file LogFlags
logflags Bool -> Bool -> Bool
|| Bool
forced_to_file
    = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (FilePath
getPrefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dump_suffix)

    | Bool
otherwise
    = Maybe FilePath
forall a. Maybe a
Nothing
  where
    (Bool
forced_to_file, FilePath
dump_suffix) = case DumpFlag
flag of
        -- -dth-dec-file dumps expansions of TH
        -- splices into MODULE.th.hs even when
        -- -ddump-to-file isn't set
        DumpFlag
Opt_D_th_dec_file -> (Bool
True, FilePath
"th.hs")
        DumpFlag
_                 -> (Bool
False, FilePath
default_suffix)

    -- build a suffix from the flag name
    -- e.g. -ddump-asm => ".dump-asm"
    default_suffix :: FilePath
default_suffix = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      let str :: FilePath
str = DumpFlag -> FilePath
forall a. Show a => a -> FilePath
show DumpFlag
flag
      in case FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"Opt_D_" FilePath
str of
        Just FilePath
x  -> FilePath
x
        Maybe FilePath
Nothing -> ShowS
forall a. FilePath -> a
panic (FilePath
"chooseDumpFile: bad flag name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
str)

    getPrefix :: FilePath
getPrefix
         -- dump file location is being forced
         --      by the --ddump-file-prefix flag.
       | Just FilePath
prefix <- LogFlags -> Maybe FilePath
log_dump_prefix_override LogFlags
logflags
          = FilePath
prefix
         -- dump file locations, module specified to [modulename] set by
         -- GHC.Driver.Pipeline.runPipeline; non-module specific, e.g. Chasing dependencies,
         -- to 'non-module' by default.
       | Bool
otherwise
          = LogFlags -> FilePath
log_dump_prefix LogFlags
logflags
    setDir :: ShowS
setDir FilePath
f = case LogFlags -> Maybe FilePath
log_dump_dir LogFlags
logflags of
                 Just FilePath
d  -> FilePath
d FilePath -> ShowS
</> FilePath
f
                 Maybe FilePath
Nothing ->       FilePath
f



-- | Default action for 'traceAction' hook
defaultTraceAction :: TraceAction a
defaultTraceAction :: forall a. TraceAction a
defaultTraceAction LogFlags
logflags FilePath
title SDoc
doc a
x =
  if Bool -> Bool
not (LogFlags -> Bool
log_enable_debug LogFlags
logflags)
    then a
x
    else FilePath -> a -> a
forall a. FilePath -> a -> a
trace (SDocContext -> SDoc -> FilePath
renderWithContext (LogFlags -> SDocContext
log_default_dump_context LogFlags
logflags)
                             ([SDoc] -> SDoc
sep [FilePath -> SDoc
text FilePath
title, Int -> SDoc -> SDoc
nest Int
2 SDoc
doc])) a
x


-- | Log something
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
mc SrcSpan
loc SDoc
msg = Logger -> LogAction
putLogMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) MessageClass
mc SrcSpan
loc SDoc
msg

-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile :: Logger
-> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger = Logger -> DumpAction
putDumpFile Logger
logger (Logger -> LogFlags
logFlags Logger
logger)

-- | Log a trace message
logTraceMsg :: Logger -> String -> SDoc -> a -> a
logTraceMsg :: forall a. Logger -> FilePath -> SDoc -> a -> a
logTraceMsg Logger
logger FilePath
hdr SDoc
doc a
a = Logger -> TraceAction a
forall a. Logger -> TraceAction a
putTraceMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) FilePath
hdr SDoc
doc a
a

-- | Log a dump message (not a dump file)
logDumpMsg :: Logger -> String -> SDoc -> IO ()
logDumpMsg :: Logger -> FilePath -> SDoc -> IO ()
logDumpMsg Logger
logger FilePath
hdr SDoc
doc = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCDump SrcSpan
noSrcSpan
  (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
  (FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc))

mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc :: FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc
   = [SDoc] -> SDoc
vcat [SDoc
blankLine,
           SDoc
line SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
hdr SDoc -> SDoc -> SDoc
<+> SDoc
line,
           SDoc
doc,
           SDoc
blankLine]
     where
        line :: SDoc
line = FilePath -> SDoc
text FilePath
"===================="


-- | Dump if the given DumpFlag is set
putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe :: Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger = Logger
-> PrintUnqualified
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
putDumpFileMaybe' Logger
logger PrintUnqualified
alwaysQualify
{-# INLINE putDumpFileMaybe #-}  -- see Note [INLINE conditional tracing utilities]

-- | Dump if the given DumpFlag is set
--
-- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument
putDumpFileMaybe'
    :: Logger
    -> PrintUnqualified
    -> DumpFlag
    -> String
    -> DumpFormat
    -> SDoc
    -> IO ()
putDumpFileMaybe' :: Logger
-> PrintUnqualified
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
putDumpFileMaybe' Logger
logger PrintUnqualified
printer DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
  = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger
-> PrintUnqualified
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
logDumpFile' Logger
logger PrintUnqualified
printer DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
{-# INLINE putDumpFileMaybe' #-}  -- see Note [INLINE conditional tracing utilities]


logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag
             -> String -> DumpFormat -> SDoc -> IO ()
{-# NOINLINE logDumpFile' #-}
-- NOINLINE: Now we are past the conditional, into the "cold" path,
--           don't inline, to reduce code size at the call site
-- See Note [INLINE conditional tracing utilities]
logDumpFile' :: Logger
-> PrintUnqualified
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
logDumpFile' Logger
logger PrintUnqualified
printer DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
  = Logger
-> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
printer) DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc

-- | Ensure that a dump file is created even if it stays empty
touchDumpFile :: Logger -> DumpFlag -> IO ()
touchDumpFile :: Logger -> DumpFlag -> IO ()
touchDumpFile Logger
logger DumpFlag
flag =
    DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle (Logger -> DumpCache
generated_dumps Logger
logger) (Logger -> LogFlags
logFlags Logger
logger) DumpFlag
flag (IO () -> Maybe Handle -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

class HasLogger m where
    getLogger :: m Logger

class ContainsLogger t where
    extractLogger :: t -> Logger