    {-# 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 supports 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
        , LogJsonAction
        , DumpAction
        , TraceAction
        , DumpFormat (..)

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

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

        -- * Logging
        , putLogMsg
        , defaultLogAction
        , defaultLogJsonAction
        , defaultLogActionHPrintDoc
        , defaultLogActionHPutStrDoc
        , logMsg
        , logJsonMsg
        , 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 GHC.Data.FastString

    import System.Directory
    import System.FilePath  ( takeDirectory, (</>) )
    import qualified Data.Map.Strict as Map
    import Data.Map.Strict (Map)
    import Data.List (stripPrefix)
    import Data.Time
    import System.IO
    import Control.Monad
    import Control.Concurrent.MVar
    import System.IO.Unsafe
    import Debug.Trace (trace)
    import GHC.Platform.Ways

    ---------------------------------------------------------------
    -- 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_diagnostics_as_json  :: !Bool               -- ^ Format diagnostics as JSON
      , 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_with_ways            :: !Bool               -- ^ Use different dump files names for different ways
      , LogFlags -> Bool
    log_enable_debug         :: !Bool               -- ^ Enable debug output
      , LogFlags -> Int
    log_verbosity            :: !Int                -- ^ Verbosity level
      , LogFlags -> Maybe Ways
    log_ways                 :: !(Maybe Ways)         -- ^ Current ways (to name dump files)
      }

    -- | 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 {k} (a :: k). EnumSet a
    EnumSet.empty
      , log_show_caret :: Bool
    log_show_caret           = Bool
    True
      , log_diagnostics_as_json :: Bool
    log_diagnostics_as_json  = Bool
    False
      , 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_with_ways :: Bool
    log_with_ways           = Bool
    True
      , log_enable_debug :: Bool
    log_enable_debug         = Bool
    False
      , log_verbosity :: Int
    log_verbosity            = Int
    0
      , log_ways :: Maybe Ways
    log_ways                 = Maybe Ways
    forall a. Maybe a
    Nothing
      }

    -- | Test if a DumpFlag is enabled
    log_dopt :: DumpFlag -> LogFlags -> Bool
    log_dopt :: DumpFlag -> LogFlags -> Bool
    log_dopt = (LogFlags -> Int)
    -> (LogFlags -> EnumSet DumpFlag) -> DumpFlag -> LogFlags -> Bool
    forall a.
    (a -> Int) -> (a -> EnumSet DumpFlag) -> DumpFlag -> a -> Bool
    getDumpFlagFrom LogFlags -> Int
    log_verbosity LogFlags -> EnumSet DumpFlag
    log_dump_flags

    -- | 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.insert f (log_dump_flags 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 = flags }

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

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

    type LogJsonAction = LogFlags
                       -> MessageClass
                       -> JsonDoc
                       -> 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
       | FormatJS        -- ^ JavaScript code
       | 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)

    -- | A set of the dump files to which we have written thusfar. Each dump file
    -- has a corresponding MVar to ensure that a dump file has at most one active
    -- writer at a time, avoiding interleaved output.
    type DumpCache = MVar (Map FilePath (MVar ()))

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

        , Logger -> [LogJsonAction -> LogJsonAction]
    json_log_hook :: [LogJsonAction -> LogJsonAction]
            -- ^ Json 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 = upd (trace_flush 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
        dumps <- Map FilePath (MVar ()) -> IO DumpCache
    forall a. a -> IO (MVar a)
    newMVar Map FilePath (MVar ())
    forall k a. Map k a
    Map.empty
        return $ Logger
            { log_hook        = []
            , json_log_hook   = []
            , dump_hook       = []
            , trace_hook      = []
            , generated_dumps = dumps
            , trace_flush     = defaultTraceFlush
            , 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)

    -- | Log a JsonDoc
    putJsonLogMsg :: Logger -> LogJsonAction
    putJsonLogMsg :: Logger -> LogJsonAction
    putJsonLogMsg Logger
    logger = ((LogJsonAction -> LogJsonAction)
     -> LogJsonAction -> LogJsonAction)
    -> LogJsonAction
    -> [LogJsonAction -> LogJsonAction]
    -> LogJsonAction
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (LogJsonAction -> LogJsonAction) -> LogJsonAction -> LogJsonAction
    forall a b. (a -> b) -> a -> b
    ($) LogJsonAction
    defaultLogJsonAction (Logger -> [LogJsonAction -> LogJsonAction]
    json_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 = h:log_hook 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. HasCallStack => FilePath -> a
    panic FilePath
    "popLogHook: empty hook stack"
        LogAction -> LogAction
    _:[LogAction -> LogAction]
    hs -> Logger
    logger { log_hook = hs }

    -- | Push a json log hook
    pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
    pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
    pushJsonLogHook LogJsonAction -> LogJsonAction
    h Logger
    logger = Logger
    logger { json_log_hook = h:json_log_hook logger }

    popJsonLogHook :: Logger -> Logger
    popJsonLogHook :: Logger -> Logger
    popJsonLogHook Logger
    logger = case Logger -> [LogJsonAction -> LogJsonAction]
    json_log_hook Logger
    logger of
        []   -> FilePath -> Logger
    forall a. HasCallStack => FilePath -> a
    panic FilePath
    "popJsonLogHook: empty hook stack"
        LogJsonAction -> LogJsonAction
    _:[LogJsonAction -> LogJsonAction]
    hs -> Logger
    logger { json_log_hook = 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 = h:dump_hook 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. HasCallStack => FilePath -> a
    panic FilePath
    "popDumpHook: empty hook stack"
        DumpAction -> DumpAction
    _:[DumpAction -> DumpAction]
    hs -> Logger
    logger { dump_hook = 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 = h:trace_hook 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. HasCallStack => FilePath -> a
    panic FilePath
    "popTraceHook: empty hook stack"
        [TraceAction (ZonkAny 0) -> TraceAction (ZonkAny 0)]
    _  -> Logger
    logger { trace_hook = tail (trace_hook logger) }

    -- | Make the logger thread-safe
    makeThreadSafe :: Logger -> IO Logger
    makeThreadSafe :: Logger -> IO Logger
    makeThreadSafe Logger
    logger = do
        lock <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
        let
            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
    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
    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 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))

        return $ pushLogHook log
               $ pushDumpHook dmp
               $ pushTraceHook trc
               $ logger

    -- See Note [JSON Error Messages]
    defaultLogJsonAction :: LogJsonAction
    defaultLogJsonAction :: LogJsonAction
    defaultLogJsonAction LogFlags
    logflags MessageClass
    msg_class JsonDoc
    jsdoc =
      case MessageClass
    msg_class of
          MessageClass
    MCOutput                     -> SDoc -> IO ()
    printOut SDoc
    msg
          MessageClass
    MCDump                       -> SDoc -> IO ()
    printOut (SDoc
    msg SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ 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 ResolvedDiagnosticReason
    _ Maybe DiagnosticCode
    _   -> () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure () -- suppress the message
          MCDiagnostic Severity
    _sev ResolvedDiagnosticReason
    _rea Maybe DiagnosticCode
    _code -> SDoc -> IO ()
    printErrs SDoc
    msg
      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
        msg :: SDoc
    msg = JsonDoc -> SDoc
    renderJSON JsonDoc
    jsdoc
    -- See Note [JSON Error Messages]
    -- this is to be removed
    jsonLogAction :: LogAction
    jsonLogAction :: LogAction
    jsonLogAction LogFlags
    _ (MCDiagnostic Severity
    SevIgnore ResolvedDiagnosticReason
    _ Maybe DiagnosticCode
    _) 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 PprStyle
    PprCode (SDoc
    doc SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    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
    spanToDumpJSON SrcSpan
    srcSpan )
                           , ( FilePath
    "doc" , FilePath -> JsonDoc
    JSString FilePath
    str )
                           , ( FilePath
    "messageClass", MessageClass -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json MessageClass
    msg_class )
                           ]
          spanToDumpJSON :: SrcSpan -> JsonDoc
          spanToDumpJSON :: SrcSpan -> JsonDoc
    spanToDumpJSON SrcSpan
    s = case SrcSpan
    s of
                     (RealSrcSpan RealSrcSpan
    rss Maybe BufSpan
    _) -> [(FilePath, JsonDoc)] -> JsonDoc
    JSObject [ (FilePath
    "file", FilePath -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json FilePath
    file)
                                                    , (FilePath
    "startLine", Int -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json (Int -> JsonDoc) -> Int -> JsonDoc
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> Int
    srcSpanStartLine RealSrcSpan
    rss)
                                                    , (FilePath
    "startCol", Int -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json (Int -> JsonDoc) -> Int -> JsonDoc
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> Int
    srcSpanStartCol RealSrcSpan
    rss)
                                                    , (FilePath
    "endLine", Int -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json (Int -> JsonDoc) -> Int -> JsonDoc
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> Int
    srcSpanEndLine RealSrcSpan
    rss)
                                                    , (FilePath
    "endCol", Int -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json (Int -> JsonDoc) -> Int -> JsonDoc
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> Int
    srcSpanEndCol RealSrcSpan
    rss)
                                                    ]
                       where file :: FilePath
    file = FastString -> FilePath
    unpackFS (FastString -> FilePath) -> FastString -> FilePath
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> FastString
    srcSpanFile RealSrcSpan
    rss
                     UnhelpfulSpan UnhelpfulSpanReason
    _ -> JsonDoc
    JSNull

    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
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ 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 ResolvedDiagnosticReason
    _ Maybe DiagnosticCode
    _   -> () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure () -- suppress the message
          MCDiagnostic Severity
    _sev ResolvedDiagnosticReason
    _rea Maybe DiagnosticCode
    _code -> IO ()
    printDiagnostics
        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 :: SDoc
    message = Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
    mkLocMessageWarningGroups (LogFlags -> Bool
    log_show_warn_groups LogFlags
    logflags) MessageClass
    msg_class SrcSpan
    srcSpan SDoc
    msg

          printDiagnostics :: IO ()
    printDiagnostics = do
            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
    forall doc. IsOutput doc => doc
    empty
            printErrs $ getPprStyle $ \PprStyle
    style ->
              PprStyle -> SDoc -> SDoc
    withPprStyle (Bool -> PprStyle -> PprStyle
    setStyleColoured Bool
    True PprStyle
    style)
                (SDoc
    message SDoc -> SDoc -> SDoc
    $+$ SDoc
    caretDiagnostic SDoc -> SDoc -> SDoc
    $+$ SDoc
    blankLine)
            -- 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.

    -- | 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
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    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.
    --
    -- The recent work here replaces the purpose of flag -ddump-json with
    -- -fdiagnostics-as-json. For temporary backwards compatibility while
    -- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
    -- it should be removed along with -ddump-json. Similarly, the guard in
    -- `defaultLogAction` should be removed. This cleanup is tracked in #24113.

    -- | 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 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
            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 timeStamp <- if LogFlags -> Bool
    log_enable_timestamps LogFlags
    logflags
                              then (FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    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
    forall doc. IsOutput doc => doc
    empty
                            let d = SDoc
    timeStamp
                                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    blankLine
                                    SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    doc
                            return $ mkDumpDoc hdr d
            -- When we dump to files we use UTF8. Which allows ascii spaces.
            defaultLogActionHPrintDoc logflags True handle (withPprStyle sty 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 dump_ways :: Maybe Ways
    dump_ways = LogFlags -> Maybe Ways
    log_ways LogFlags
    logflags
        let mFile :: Maybe FilePath
    mFile = LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath
    chooseDumpFile LogFlags
    logflags Maybe Ways
    dump_ways DumpFlag
    flag
        case Maybe FilePath
    mFile of
          Just FilePath
    fileName -> do
            lock <- DumpCache
    -> (Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
    -> IO (MVar ())
    forall a b. MVar a -> (a -> IO (a, b)) -> IO b
    modifyMVar DumpCache
    dumps ((Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
     -> IO (MVar ()))
    -> (Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
    -> IO (MVar ())
    forall a b. (a -> b) -> a -> b
    $ \Map FilePath (MVar ())
    gd ->
                case FilePath -> Map FilePath (MVar ()) -> Maybe (MVar ())
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup FilePath
    fileName Map FilePath (MVar ())
    gd of
                  Maybe (MVar ())
    Nothing -> do
                      lock <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
                      let gd' = FilePath
    -> MVar () -> Map FilePath (MVar ()) -> Map FilePath (MVar ())
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert FilePath
    fileName MVar ()
    lock Map FilePath (MVar ())
    gd
                      -- ensure that file exists so we can append to it
                      createDirectoryIfMissing True (takeDirectory fileName)
                      writeFile fileName ""
                      return (gd', lock)
                  Just MVar ()
    lock -> do
                      (Map FilePath (MVar ()), MVar ())
    -> IO (Map FilePath (MVar ()), MVar ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map FilePath (MVar ())
    gd, MVar ()
    lock)

            let withLock IO ()
    k = MVar () -> (() -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar ()
    lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \() -> IO ()
    k IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            withLock $ withFile fileName AppendMode $ \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 -> Maybe Ways -> DumpFlag -> Maybe FilePath
    chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath
    chooseDumpFile LogFlags
    logflags Maybe Ways
    ways 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
    way_infix FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    dump_suffix)

        | Bool
    otherwise
        = Maybe FilePath
    forall a. Maybe a
    Nothing
      where
        way_infix :: FilePath
    way_infix = case Maybe Ways
    ways of
          Maybe Ways
    _ | Bool -> Bool
    not (LogFlags -> Bool
    log_with_ways LogFlags
    logflags) -> FilePath
    ""
          Maybe Ways
    Nothing -> FilePath
    ""
          Just Ways
    ws
            | Ways -> Bool
    forall a. Set a -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null Ways
    ws Bool -> Bool -> Bool
    || FilePath -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Ways -> FilePath
    waysTag Ways
    ws) -> FilePath
    ""
            | Bool
    otherwise -> Ways -> FilePath
    waysTag Ways
    ws FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "."
        (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. HasCallStack => 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
    forall doc. IsLine doc => [doc] -> doc
    sep [FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    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

    logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
    logJsonMsg :: forall a. ToJson a => Logger -> MessageClass -> a -> IO ()
    logJsonMsg Logger
    logger MessageClass
    mc a
    d = Logger -> LogJsonAction
    putJsonLogMsg Logger
    logger (Logger -> LogFlags
    logFlags Logger
    logger) MessageClass
    mc  (a -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json a
    d)

    -- | 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
    forall doc. IsDoc doc => [doc] -> doc
    vcat [SDoc
    blankLine,
               SDoc
    line SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    text FilePath
    hdr SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    line,
               SDoc
    doc,
               SDoc
    blankLine]
         where
            line :: SDoc
    line = FilePath -> SDoc
    forall doc. IsLine doc => FilePath -> doc
    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
    -> NamePprCtx
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    putDumpFileMaybe' Logger
    logger NamePprCtx
    alwaysQualify
    {-# INLINE putDumpFileMaybe #-}  -- see Note [INLINE conditional tracing utilities]

    -- | Dump if the given DumpFlag is set
    --
    -- Unlike 'putDumpFileMaybe', has a NamePprCtx argument
    putDumpFileMaybe'
        :: Logger
        -> NamePprCtx
        -> DumpFlag
        -> String
        -> DumpFormat
        -> SDoc
        -> IO ()
    putDumpFileMaybe' :: Logger
    -> NamePprCtx
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    putDumpFileMaybe' Logger
    logger NamePprCtx
    name_ppr_ctx 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
    -> NamePprCtx
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    logDumpFile' Logger
    logger NamePprCtx
    name_ppr_ctx DumpFlag
    flag FilePath
    hdr DumpFormat
    fmt SDoc
    doc
    {-# INLINE putDumpFileMaybe' #-}  -- see Note [INLINE conditional tracing utilities]

    logDumpFile' :: Logger -> NamePprCtx -> 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
    -> NamePprCtx
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    logDumpFile' Logger
    logger NamePprCtx
    name_ppr_ctx DumpFlag
    flag FilePath
    hdr DumpFormat
    fmt SDoc
    doc
      = Logger
    -> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
    logDumpFile Logger
    logger (NamePprCtx -> PprStyle
    mkDumpStyle NamePprCtx
    name_ppr_ctx) 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