    {-# LANGUAGE RankNTypes #-}

    -- | Logger
    module GHC.Utils.Logger
        ( Logger
        , initLogger
        , HasLogger (..)
        , ContainsLogger (..)
        , LogAction
        , DumpAction
        , TraceAction
        , DumpFormat (..)
        , putLogMsg
        , putDumpMsg
        , putTraceMsg

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

        -- * Logging
        , jsonLogAction
        , defaultLogAction
        , defaultLogActionHPrintDoc
        , defaultLogActionHPutStrDoc

        -- * Dumping
        , defaultDumpAction
        , withDumpFileHandle
        , touchDumpFile
        , dumpIfSet
        , dumpIfSet_dyn
        , dumpIfSet_dyn_printer

        -- * Tracing
        , defaultTraceAction
        )
    where

    import GHC.Prelude
    import GHC.Driver.Session
    import GHC.Driver.Ppr
    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 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 Data.Time
    import System.IO
    import Control.Monad
    import Control.Concurrent.MVar
    import System.IO.Unsafe

    type LogAction = DynFlags
                  -> WarnReason
                  -> Severity
                  -> SrcSpan
                  -> SDoc
                  -> IO ()

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

    type TraceAction a = DynFlags -> 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
    showList :: [DumpFormat] -> ShowS
    $cshowList :: [DumpFormat] -> ShowS
    show :: DumpFormat -> FilePath
    $cshow :: DumpFormat -> FilePath
    showsPrec :: Int -> DumpFormat -> ShowS
    $cshowsPrec :: Int -> DumpFormat -> ShowS
    Show,DumpFormat -> DumpFormat -> Bool
    (DumpFormat -> DumpFormat -> Bool)
    -> (DumpFormat -> DumpFormat -> Bool) -> Eq DumpFormat
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: DumpFormat -> DumpFormat -> Bool
    $c/= :: DumpFormat -> DumpFormat -> Bool
    == :: DumpFormat -> DumpFormat -> Bool
    $c== :: 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)
        }

    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 (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
            }

    -- | Log something
    putLogMsg :: Logger -> LogAction
    putLogMsg :: Logger -> LogAction
    putLogMsg Logger
    logger = ((LogAction -> LogAction) -> LogAction -> LogAction)
    -> LogAction -> [LogAction -> LogAction] -> LogAction
    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
    putDumpMsg :: Logger -> DumpAction
    putDumpMsg :: Logger -> DumpAction
    putDumpMsg 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 (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 (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. [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 -> t -> IO a) -> t -> t -> t -> t -> t -> IO a
    log t -> t -> t -> t -> t -> IO a
    action t
    dflags t
    reason t
    sev t
    loc t
    doc =
                IO a -> IO a
    forall a. IO a -> IO a
    with_lock (t -> t -> t -> t -> t -> IO a
    action t
    dflags t
    reason t
    sev 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
    dflags 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
    dflags 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 DynFlags
    dflags 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 (m :: * -> *) a. Monad m => a -> m a
    return (a -> IO a) -> a -> IO a
    forall a b. (a -> b) -> a -> b
    $! TraceAction a
    action DynFlags
    dflags FilePath
    str SDoc
    doc a
    v))

        Logger -> IO Logger
    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} {t} {a}.
    (t -> t -> t -> t -> t -> IO a) -> t -> 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 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 DynFlags
    dflags WarnReason
    reason Severity
    severity SrcSpan
    srcSpan SDoc
    msg
      =
        DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPutStrDoc DynFlags
    dflags 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 (DynFlags -> PprStyle -> SDocContext
    initSDocContext DynFlags
    dflags PprStyle
    defaultUserStyle) 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
    "severity", Severity -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json Severity
    severity )
                           , ( FilePath
    "reason" ,   WarnReason -> JsonDoc
    forall a. ToJson a => a -> JsonDoc
    json WarnReason
    reason )
                           ]

    defaultLogAction :: LogAction
    defaultLogAction :: LogAction
    defaultLogAction DynFlags
    dflags WarnReason
    reason Severity
    severity SrcSpan
    srcSpan SDoc
    msg
      | DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_json DynFlags
    dflags = LogAction
    jsonLogAction DynFlags
    dflags WarnReason
    reason Severity
    severity SrcSpan
    srcSpan SDoc
    msg
      | Bool
    otherwise = case Severity
    severity of
          Severity
    SevOutput      -> SDoc -> IO ()
    printOut SDoc
    msg
          Severity
    SevDump        -> SDoc -> IO ()
    printOut (SDoc
    msg SDoc -> SDoc -> SDoc
    $$ SDoc
    blankLine)
          Severity
    SevInteractive -> SDoc -> IO ()
    putStrSDoc SDoc
    msg
          Severity
    SevInfo        -> SDoc -> IO ()
    printErrs SDoc
    msg
          Severity
    SevFatal       -> SDoc -> IO ()
    printErrs SDoc
    msg
          Severity
    SevWarning     -> IO ()
    printWarns
          Severity
    SevError       -> IO ()
    printWarns
        where
          printOut :: SDoc -> IO ()
    printOut   = DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPrintDoc  DynFlags
    dflags Bool
    False Handle
    stdout
          printErrs :: SDoc -> IO ()
    printErrs  = DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPrintDoc  DynFlags
    dflags Bool
    False Handle
    stderr
          putStrSDoc :: SDoc -> IO ()
    putStrSDoc = DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPutStrDoc DynFlags
    dflags Bool
    False Handle
    stdout
          -- Pretty print the warning flag, if any (#10752)
          message :: SDoc
    message = Maybe FilePath -> Severity -> SrcSpan -> SDoc -> SDoc
    mkLocMessageAnn Maybe FilePath
    flagMsg Severity
    severity SrcSpan
    srcSpan SDoc
    msg

          printWarns :: IO ()
    printWarns = do
            Handle -> Char -> IO ()
    hPutChar Handle
    stderr Char
    '\n'
            SDoc
    caretDiagnostic <-
                if GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DiagnosticsShowCaret DynFlags
    dflags
                then Severity -> SrcSpan -> IO SDoc
    getCaretDiagnostic Severity
    severity SrcSpan
    srcSpan
                else SDoc -> IO SDoc
    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)
                (SDoc
    message 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 :: Maybe FilePath
    flagMsg =
            case WarnReason
    reason of
              WarnReason
    NoReason -> Maybe FilePath
    forall a. Maybe a
    Nothing
              Reason WarningFlag
    wflag -> do
                FlagSpec WarningFlag
    spec <- WarningFlag -> Maybe (FlagSpec WarningFlag)
    flagSpecOf WarningFlag
    wflag
                FilePath -> Maybe FilePath
    forall (m :: * -> *) a. Monad m => a -> m a
    return (FilePath
    "-W" FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FlagSpec WarningFlag -> FilePath
    forall flag. FlagSpec flag -> FilePath
    flagSpecName FlagSpec WarningFlag
    spec FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ WarningFlag -> FilePath
    warnFlagGrp WarningFlag
    wflag)
              ErrReason Maybe WarningFlag
    Nothing ->
                FilePath -> Maybe FilePath
    forall (m :: * -> *) a. Monad m => a -> m a
    return FilePath
    "-Werror"
              ErrReason (Just WarningFlag
    wflag) -> do
                FlagSpec WarningFlag
    spec <- WarningFlag -> Maybe (FlagSpec WarningFlag)
    flagSpecOf WarningFlag
    wflag
                FilePath -> Maybe FilePath
    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]
    ++ FlagSpec WarningFlag -> FilePath
    forall flag. FlagSpec flag -> FilePath
    flagSpecName FlagSpec WarningFlag
    spec 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]
    ++ FlagSpec WarningFlag -> FilePath
    forall flag. FlagSpec flag -> FilePath
    flagSpecName FlagSpec WarningFlag
    spec

          warnFlagGrp :: WarningFlag -> FilePath
    warnFlagGrp WarningFlag
    flag
              | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_ShowWarnGroups DynFlags
    dflags =
                    case WarningFlag -> [FilePath]
    smallestGroups 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 :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPrintDoc DynFlags
    dflags Bool
    asciiSpace Handle
    h SDoc
    d
     = DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPutStrDoc DynFlags
    dflags 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 :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPutStrDoc DynFlags
    dflags 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 SDocContext
    ctx (Bool -> Mode
    Pretty.PageMode Bool
    asciiSpace) Handle
    h SDoc
    d
        where
          ctx :: SDocContext
    ctx = DynFlags -> PprStyle -> SDocContext
    initSDocContext DynFlags
    dflags PprStyle
    defaultUserStyle

    --
    -- 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 DynFlags
    dflags PprStyle
    sty DumpFlag
    flag FilePath
    title DumpFormat
    _fmt SDoc
    doc =
      DumpCache
    -> LogAction
    -> PprStyle
    -> DynFlags
    -> DumpFlag
    -> FilePath
    -> SDoc
    -> IO ()
    dumpSDocWithStyle DumpCache
    dumps LogAction
    log_action PprStyle
    sty DynFlags
    dflags 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 -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
    dumpSDocWithStyle :: DumpCache
    -> LogAction
    -> PprStyle
    -> DynFlags
    -> DumpFlag
    -> FilePath
    -> SDoc
    -> IO ()
    dumpSDocWithStyle DumpCache
    dumps LogAction
    log_action PprStyle
    sty DynFlags
    dflags DumpFlag
    flag FilePath
    hdr SDoc
    doc =
        DumpCache
    -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
    withDumpFileHandle DumpCache
    dumps DynFlags
    dflags 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 (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    hdr
                    then SDoc -> IO SDoc
    forall (m :: * -> *) a. Monad m => a -> m a
    return SDoc
    doc
                    else do UTCTime
    t <- IO UTCTime
    getCurrentTime
                            let timeStamp :: SDoc
    timeStamp = if (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_SuppressTimestamps DynFlags
    dflags)
                                              then SDoc
    empty
                                              else FilePath -> SDoc
    text (UTCTime -> FilePath
    forall a. Show a => a -> FilePath
    show UTCTime
    t)
                            let d :: SDoc
    d = SDoc
    timeStamp
                                    SDoc -> SDoc -> SDoc
    $$ SDoc
    blankLine
                                    SDoc -> SDoc -> SDoc
    $$ SDoc
    doc
                            SDoc -> IO SDoc
    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.
            DynFlags -> Bool -> Handle -> SDoc -> IO ()
    defaultLogActionHPrintDoc DynFlags
    dflags 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', Severity
    severity)
                  | FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    hdr  = (SDoc
    doc, Severity
    SevOutput)
                  | Bool
    otherwise = (FilePath -> SDoc -> SDoc
    mkDumpDoc FilePath
    hdr SDoc
    doc, Severity
    SevDump)
            LogAction
    log_action DynFlags
    dflags WarnReason
    NoReason Severity
    severity 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 -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
    withDumpFileHandle :: DumpCache
    -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
    withDumpFileHandle DumpCache
    dumps DynFlags
    dflags DumpFlag
    flag Maybe Handle -> IO ()
    action = do
        let mFile :: Maybe FilePath
    mFile = DynFlags -> DumpFlag -> Maybe FilePath
    chooseDumpFile DynFlags
    dflags 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 DynFlags and DumpFlag
    chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
    chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
    chooseDumpFile DynFlags
    dflags DumpFlag
    flag
        | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DumpToFile DynFlags
    dflags Bool -> Bool -> Bool
    || Bool
    forced_to_file
        , Just FilePath
    prefix <- Maybe FilePath
    getPrefix
        = 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
    prefix 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 :: Maybe FilePath
    getPrefix
             -- dump file location is being forced
             --      by the --ddump-file-prefix flag.
           | Just FilePath
    prefix <- DynFlags -> Maybe FilePath
    dumpPrefixForce DynFlags
    dflags
              = FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just FilePath
    prefix
             -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
           | Just FilePath
    prefix <- DynFlags -> Maybe FilePath
    dumpPrefix DynFlags
    dflags
              = FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just FilePath
    prefix
             -- we haven't got a place to put a dump file.
           | Bool
    otherwise
              = Maybe FilePath
    forall a. Maybe a
    Nothing
        setDir :: ShowS
    setDir FilePath
    f = case DynFlags -> Maybe FilePath
    dumpDir DynFlags
    dflags of
                     Just FilePath
    d  -> FilePath
    d FilePath -> ShowS
    </> FilePath
    f
                     Maybe FilePath
    Nothing ->       FilePath
    f

    -- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated
    -- despite the fact that 'dumpIfSet' has an @INLINE@.
    doDump :: Logger -> DynFlags -> String -> SDoc -> IO ()
    doDump :: Logger -> DynFlags -> FilePath -> SDoc -> IO ()
    doDump Logger
    logger DynFlags
    dflags FilePath
    hdr SDoc
    doc =
      Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags
                WarnReason
    NoReason
                Severity
    SevDump
                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
    "===================="

    dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
    dumpIfSet :: Logger -> DynFlags -> Bool -> FilePath -> SDoc -> IO ()
    dumpIfSet Logger
    logger DynFlags
    dflags Bool
    flag FilePath
    hdr SDoc
    doc
      | Bool -> Bool
    not Bool
    flag   = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      | Bool
    otherwise  = Logger -> DynFlags -> FilePath -> SDoc -> IO ()
    doDump Logger
    logger DynFlags
    dflags FilePath
    hdr SDoc
    doc
    {-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]

    -- | A wrapper around 'dumpAction'.
    -- First check whether the dump flag is set
    -- Do nothing if it is unset
    dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn :: Logger
    -> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn = PrintUnqualified
    -> Logger
    -> DynFlags
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    dumpIfSet_dyn_printer PrintUnqualified
    alwaysQualify
    {-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]

    -- | A wrapper around 'putDumpMsg'.
    -- First check whether the dump flag is set
    -- Do nothing if it is unset
    --
    -- Unlike 'dumpIfSet_dyn', has a printer argument
    dumpIfSet_dyn_printer
        :: PrintUnqualified
        -> Logger
        -> DynFlags
        -> DumpFlag
        -> String
        -> DumpFormat
        -> SDoc
        -> IO ()
    dumpIfSet_dyn_printer :: PrintUnqualified
    -> Logger
    -> DynFlags
    -> DumpFlag
    -> FilePath
    -> DumpFormat
    -> SDoc
    -> IO ()
    dumpIfSet_dyn_printer PrintUnqualified
    printer Logger
    logger DynFlags
    dflags DumpFlag
    flag FilePath
    hdr DumpFormat
    fmt SDoc
    doc
      = Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    flag DynFlags
    dflags) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
          let sty :: PprStyle
    sty = PrintUnqualified -> PprStyle
    mkDumpStyle PrintUnqualified
    printer
          Logger -> DumpAction
    putDumpMsg Logger
    logger DynFlags
    dflags PprStyle
    sty DumpFlag
    flag FilePath
    hdr DumpFormat
    fmt SDoc
    doc
    {-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]

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

    -- | Default action for 'traceAction' hook
    defaultTraceAction :: TraceAction a
    defaultTraceAction :: forall a. TraceAction a
    defaultTraceAction DynFlags
    dflags FilePath
    title SDoc
    doc = DynFlags -> FilePath -> SDoc -> a -> a
    forall a. TraceAction a
    pprTraceWithFlags DynFlags
    dflags FilePath
    title SDoc
    doc

    class HasLogger m where
        getLogger :: m Logger

    class ContainsLogger t where
        extractLogger :: t -> Logger