    {-# LANGUAGE ViewPatterns    #-}

    {-
    (c) The AQUA Project, Glasgow University, 1994-1998

    \section[ErrsUtils]{Utilities for error reporting}
    -}

    module GHC.Utils.Error (
            -- * Basic types
            Validity'(..), Validity, andValid, allValid, getInvalids,
            Severity(..),

            -- * Messages
            Diagnostic(..),
            MsgEnvelope(..),
            MessageClass(..),
            SDoc,
            DecoratedSDoc(unDecorated),
            Messages,
            mkMessages, unionMessages,
            errorsFound, isEmptyMessages,

            -- ** Formatting
            pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault,
            pprMessages,
            pprLocMsgEnvelope, pprLocMsgEnvelopeDefault,
            formatBulleted,

            -- ** Construction
            DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,
            emptyMessages, mkDecorated, mkLocMessage,
            mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
            mkErrorMsgEnvelope,
            mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,

            mkPlainError,
            mkPlainDiagnostic,
            mkDecoratedError,
            mkDecoratedDiagnostic,
            noHints,

            -- * Utilities
            getCaretDiagnostic,

            -- * Issuing messages during compilation
            putMsg, printInfoForUser, printOutputForUser,
            logInfo, logOutput,
            errorMsg,
            fatalErrorMsg,
            compilationProgressMsg,
            showPass,
            withTiming, withTimingSilent,
            debugTraceMsg,
            ghcExit,
            prettyPrintGhcErrors,
            traceCmd,
            traceSystoolCommand,

            sortMsgBag
        ) where

    import GHC.Prelude

    import GHC.Driver.Flags

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

    import GHC.Utils.Exception
    import GHC.Utils.Outputable as Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Logger
    import GHC.Types.Error
    import GHC.Types.SrcLoc as SrcLoc
    import GHC.Unit.Module.Warnings

    import System.Exit      ( ExitCode(..), exitWith )
    import Data.List        ( sortBy )
    import Data.Function
    import Debug.Trace
    import Control.Monad
    import Control.Monad.IO.Class
    import Control.Monad.Catch as MC (handle)
    import GHC.Conc         ( getAllocationCounter )
    import System.CPUTime
    import Data.List.NonEmpty (NonEmpty (..))
    import qualified Data.List.NonEmpty as NE

    data DiagOpts = DiagOpts
      { DiagOpts -> EnumSet WarningFlag
    diag_warning_flags       :: !(EnumSet WarningFlag) -- ^ Enabled warnings
      , DiagOpts -> EnumSet WarningFlag
    diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings
      , DiagOpts -> WarningCategorySet
    diag_custom_warning_categories       :: !WarningCategorySet -- ^ Enabled custom warning categories
      , DiagOpts -> WarningCategorySet
    diag_fatal_custom_warning_categories :: !WarningCategorySet -- ^ Fatal custom warning categories
      , DiagOpts -> Bool
    diag_warn_is_error       :: !Bool                  -- ^ Treat warnings as errors
      , DiagOpts -> Bool
    diag_reverse_errors      :: !Bool                  -- ^ Reverse error reporting order
      , DiagOpts -> Maybe Int
    diag_max_errors          :: !(Maybe Int)           -- ^ Max reported error count
      , DiagOpts -> SDocContext
    diag_ppr_ctx             :: !SDocContext           -- ^ Error printing context
      }

    emptyDiagOpts :: DiagOpts
    emptyDiagOpts :: DiagOpts
    emptyDiagOpts =
        DiagOpts
            { diag_warning_flags :: EnumSet WarningFlag
    diag_warning_flags = EnumSet WarningFlag
    forall {k} (a :: k). EnumSet a
    EnumSet.empty
            , diag_fatal_warning_flags :: EnumSet WarningFlag
    diag_fatal_warning_flags = EnumSet WarningFlag
    forall {k} (a :: k). EnumSet a
    EnumSet.empty
            , diag_custom_warning_categories :: WarningCategorySet
    diag_custom_warning_categories = WarningCategorySet
    emptyWarningCategorySet
            , diag_fatal_custom_warning_categories :: WarningCategorySet
    diag_fatal_custom_warning_categories = WarningCategorySet
    emptyWarningCategorySet
            , diag_warn_is_error :: Bool
    diag_warn_is_error = Bool
    False
            , diag_reverse_errors :: Bool
    diag_reverse_errors = Bool
    False
            , diag_max_errors :: Maybe Int
    diag_max_errors = Maybe Int
    forall a. Maybe a
    Nothing
            , diag_ppr_ctx :: SDocContext
    diag_ppr_ctx = SDocContext
    defaultSDocContext
            }

    diag_wopt :: WarningFlag -> DiagOpts -> Bool
    diag_wopt :: WarningFlag -> DiagOpts -> Bool
    diag_wopt WarningFlag
    wflag DiagOpts
    opts = WarningFlag
    wflag WarningFlag -> EnumSet WarningFlag -> Bool
    forall a. Enum a => a -> EnumSet a -> Bool
    `EnumSet.member` DiagOpts -> EnumSet WarningFlag
    diag_warning_flags DiagOpts
    opts

    diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
    diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
    diag_fatal_wopt WarningFlag
    wflag DiagOpts
    opts = WarningFlag
    wflag WarningFlag -> EnumSet WarningFlag -> Bool
    forall a. Enum a => a -> EnumSet a -> Bool
    `EnumSet.member` DiagOpts -> EnumSet WarningFlag
    diag_fatal_warning_flags DiagOpts
    opts

    diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool
    diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool
    diag_wopt_custom WarningCategory
    wflag DiagOpts
    opts = WarningCategory
    wflag WarningCategory -> WarningCategorySet -> Bool
    `elemWarningCategorySet` DiagOpts -> WarningCategorySet
    diag_custom_warning_categories DiagOpts
    opts

    diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool
    diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool
    diag_fatal_wopt_custom WarningCategory
    wflag DiagOpts
    opts = WarningCategory
    wflag WarningCategory -> WarningCategorySet -> Bool
    `elemWarningCategorySet` DiagOpts -> WarningCategorySet
    diag_fatal_custom_warning_categories DiagOpts
    opts

    -- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
    -- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed,
    -- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a
    -- particular diagnostic message is built, otherwise the computed 'Severity' might
    -- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
    --
    --
    diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
    diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
    diagReasonSeverity DiagOpts
    opts DiagnosticReason
    reason = (Severity, ResolvedDiagnosticReason) -> Severity
    forall a b. (a, b) -> a
    fst (DiagOpts
    -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
    diag_reason_severity DiagOpts
    opts DiagnosticReason
    reason)

    -- Like the diagReasonSeverity but the second half of the pair is a small
    -- ReasolvedDiagnosticReason which would cause the diagnostic to be triggered with the
    -- same severity.
    --
    -- See Note [Warnings controlled by multiple flags]
    --
    diag_reason_severity :: DiagOpts -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
    diag_reason_severity :: DiagOpts
    -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
    diag_reason_severity DiagOpts
    opts DiagnosticReason
    reason = (DiagnosticReason -> ResolvedDiagnosticReason)
    -> (Severity, DiagnosticReason)
    -> (Severity, ResolvedDiagnosticReason)
    forall a b. (a -> b) -> (Severity, a) -> (Severity, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap DiagnosticReason -> ResolvedDiagnosticReason
    ResolvedDiagnosticReason ((Severity, DiagnosticReason)
     -> (Severity, ResolvedDiagnosticReason))
    -> (Severity, DiagnosticReason)
    -> (Severity, ResolvedDiagnosticReason)
    forall a b. (a -> b) -> a -> b
    $ case DiagnosticReason
    reason of
      WarningWithFlags NonEmpty WarningFlag
    wflags -> case [WarningFlag]
    wflags' of
        []     -> (Severity
    SevIgnore, DiagnosticReason
    reason)
        WarningFlag
    w : [WarningFlag]
    ws -> case [WarningFlag]
    wflagsE of
          []     -> (Severity
    SevWarning, NonEmpty WarningFlag -> DiagnosticReason
    WarningWithFlags (WarningFlag
    w WarningFlag -> [WarningFlag] -> NonEmpty WarningFlag
    forall a. a -> [a] -> NonEmpty a
    :| [WarningFlag]
    ws))
          WarningFlag
    e : [WarningFlag]
    es -> (Severity
    SevError, NonEmpty WarningFlag -> DiagnosticReason
    WarningWithFlags (WarningFlag
    e WarningFlag -> [WarningFlag] -> NonEmpty WarningFlag
    forall a. a -> [a] -> NonEmpty a
    :| [WarningFlag]
    es))
        where
          wflags' :: [WarningFlag]
    wflags' = (WarningFlag -> Bool) -> NonEmpty WarningFlag -> [WarningFlag]
    forall a. (a -> Bool) -> NonEmpty a -> [a]
    NE.filter (\WarningFlag
    wflag -> WarningFlag -> DiagOpts -> Bool
    diag_wopt WarningFlag
    wflag DiagOpts
    opts) NonEmpty WarningFlag
    wflags
          wflagsE :: [WarningFlag]
    wflagsE = (WarningFlag -> Bool) -> [WarningFlag] -> [WarningFlag]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\WarningFlag
    wflag -> WarningFlag -> DiagOpts -> Bool
    diag_fatal_wopt WarningFlag
    wflag DiagOpts
    opts) [WarningFlag]
    wflags'

      WarningWithCategory WarningCategory
    wcat
        | Bool -> Bool
    not (WarningCategory -> DiagOpts -> Bool
    diag_wopt_custom WarningCategory
    wcat DiagOpts
    opts) -> (Severity
    SevIgnore, DiagnosticReason
    reason)
        | WarningCategory -> DiagOpts -> Bool
    diag_fatal_wopt_custom WarningCategory
    wcat DiagOpts
    opts -> (Severity
    SevError, DiagnosticReason
    reason)
        | Bool
    otherwise                        -> (Severity
    SevWarning, DiagnosticReason
    reason)
      DiagnosticReason
    WarningWithoutFlag
        | DiagOpts -> Bool
    diag_warn_is_error DiagOpts
    opts -> (Severity
    SevError, DiagnosticReason
    reason)
        | Bool
    otherwise             -> (Severity
    SevWarning, DiagnosticReason
    reason)
      DiagnosticReason
    ErrorWithoutFlag
        -> (Severity
    SevError, DiagnosticReason
    reason)

    -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
    -- 'DiagOpts'.
    mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    mkMCDiagnostic :: DiagOpts
    -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    mkMCDiagnostic DiagOpts
    opts DiagnosticReason
    reason Maybe DiagnosticCode
    code = Severity
    -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    MCDiagnostic Severity
    sev ResolvedDiagnosticReason
    reason' Maybe DiagnosticCode
    code
      where
        (Severity
    sev, ResolvedDiagnosticReason
    reason') = DiagOpts
    -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
    diag_reason_severity DiagOpts
    opts DiagnosticReason
    reason

    -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
    -- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code.
    errorDiagnostic :: MessageClass
    errorDiagnostic :: MessageClass
    errorDiagnostic = Severity
    -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    MCDiagnostic Severity
    SevError (DiagnosticReason -> ResolvedDiagnosticReason
    ResolvedDiagnosticReason DiagnosticReason
    ErrorWithoutFlag) Maybe DiagnosticCode
    forall a. Maybe a
    Nothing

    --
    -- Creating MsgEnvelope(s)
    --

    mk_msg_envelope
      :: Diagnostic e
      => Severity
      -> SrcSpan
      -> NamePprCtx
      -> ResolvedDiagnosticReason
      -> e
      -> MsgEnvelope e
    mk_msg_envelope :: forall e.
    Diagnostic e =>
    Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    mk_msg_envelope Severity
    severity SrcSpan
    locn NamePprCtx
    name_ppr_ctx ResolvedDiagnosticReason
    reason e
    err
     = MsgEnvelope { errMsgSpan :: SrcSpan
    errMsgSpan = SrcSpan
    locn
                   , errMsgContext :: NamePprCtx
    errMsgContext = NamePprCtx
    name_ppr_ctx
                   , errMsgDiagnostic :: e
    errMsgDiagnostic = e
    err
                   , errMsgSeverity :: Severity
    errMsgSeverity = Severity
    severity
                   , errMsgReason :: ResolvedDiagnosticReason
    errMsgReason = ResolvedDiagnosticReason
    reason
                   }

    -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
    -- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope',
    -- which does not require looking at the 'DiagOpts'
    mkMsgEnvelope
      :: Diagnostic e
      => DiagOpts
      -> SrcSpan
      -> NamePprCtx
      -> e
      -> MsgEnvelope e
    mkMsgEnvelope :: forall e.
    Diagnostic e =>
    DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
    mkMsgEnvelope DiagOpts
    opts SrcSpan
    locn NamePprCtx
    name_ppr_ctx e
    err
     = Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    forall e.
    Diagnostic e =>
    Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    mk_msg_envelope Severity
    sev SrcSpan
    locn NamePprCtx
    name_ppr_ctx ResolvedDiagnosticReason
    reason e
    err
      where
        (Severity
    sev, ResolvedDiagnosticReason
    reason) = DiagOpts
    -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)
    diag_reason_severity DiagOpts
    opts (e -> DiagnosticReason
    forall a. Diagnostic a => a -> DiagnosticReason
    diagnosticReason e
    err)

    -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
    -- Precondition: the diagnostic is, in fact, an error. That is,
    -- @diagnosticReason msg == ErrorWithoutFlag@.
    mkErrorMsgEnvelope :: Diagnostic e
                       => SrcSpan
                       -> NamePprCtx
                       -> e
                       -> MsgEnvelope e
    mkErrorMsgEnvelope :: forall e.
    Diagnostic e =>
    SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
    mkErrorMsgEnvelope SrcSpan
    locn NamePprCtx
    name_ppr_ctx e
    msg =
     Bool -> MsgEnvelope e -> MsgEnvelope e
    forall a. HasCallStack => Bool -> a -> a
    assert (e -> DiagnosticReason
    forall a. Diagnostic a => a -> DiagnosticReason
    diagnosticReason e
    msg DiagnosticReason -> DiagnosticReason -> Bool
    forall a. Eq a => a -> a -> Bool
    == DiagnosticReason
    ErrorWithoutFlag) (MsgEnvelope e -> MsgEnvelope e) -> MsgEnvelope e -> MsgEnvelope e
    forall a b. (a -> b) -> a -> b
    $ Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    forall e.
    Diagnostic e =>
    Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    mk_msg_envelope Severity
    SevError SrcSpan
    locn NamePprCtx
    name_ppr_ctx (DiagnosticReason -> ResolvedDiagnosticReason
    ResolvedDiagnosticReason DiagnosticReason
    ErrorWithoutFlag) e
    msg

    -- | Variant that doesn't care about qualified/unqualified names.
    mkPlainMsgEnvelope :: Diagnostic e
                       => DiagOpts
                       -> SrcSpan
                       -> e
                       -> MsgEnvelope e
    mkPlainMsgEnvelope :: forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
    mkPlainMsgEnvelope DiagOpts
    opts SrcSpan
    locn e
    msg =
      DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
    forall e.
    Diagnostic e =>
    DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
    mkMsgEnvelope DiagOpts
    opts SrcSpan
    locn NamePprCtx
    alwaysQualify e
    msg

    -- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
    -- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
    mkPlainErrorMsgEnvelope :: Diagnostic e
                            => SrcSpan
                            -> e
                            -> MsgEnvelope e
    mkPlainErrorMsgEnvelope :: forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
    mkPlainErrorMsgEnvelope SrcSpan
    locn e
    msg =
      Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    forall e.
    Diagnostic e =>
    Severity
    -> SrcSpan
    -> NamePprCtx
    -> ResolvedDiagnosticReason
    -> e
    -> MsgEnvelope e
    mk_msg_envelope Severity
    SevError SrcSpan
    locn NamePprCtx
    alwaysQualify (DiagnosticReason -> ResolvedDiagnosticReason
    ResolvedDiagnosticReason DiagnosticReason
    ErrorWithoutFlag) e
    msg

    -------------------------
    data Validity' a
      = IsValid      -- ^ Everything is fine
      | NotValid a   -- ^ A problem, and some indication of why
      deriving (forall a b. (a -> b) -> Validity' a -> Validity' b)
    -> (forall a b. a -> Validity' b -> Validity' a)
    -> Functor Validity'
    forall a b. a -> Validity' b -> Validity' a
    forall a b. (a -> b) -> Validity' a -> Validity' b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> Validity' a -> Validity' b
    fmap :: forall a b. (a -> b) -> Validity' a -> Validity' b
    $c<$ :: forall a b. a -> Validity' b -> Validity' a
    <$ :: forall a b. a -> Validity' b -> Validity' a
    Functor

    -- | Monomorphic version of @Validity'@ specialised for 'SDoc's.
    type Validity = Validity' SDoc

    andValid :: Validity' a -> Validity' a -> Validity' a
    andValid :: forall a. Validity' a -> Validity' a -> Validity' a
    andValid Validity' a
    IsValid Validity' a
    v = Validity' a
    v
    andValid Validity' a
    v Validity' a
    _       = Validity' a
    v

    -- | If they aren't all valid, return the first
    allValid :: [Validity' a] -> Validity' a
    allValid :: forall a. [Validity' a] -> Validity' a
    allValid []       = Validity' a
    forall a. Validity' a
    IsValid
    allValid (Validity' a
    v : [Validity' a]
    vs) = Validity' a
    v Validity' a -> Validity' a -> Validity' a
    forall a. Validity' a -> Validity' a -> Validity' a
    `andValid` [Validity' a] -> Validity' a
    forall a. [Validity' a] -> Validity' a
    allValid [Validity' a]
    vs

    getInvalids :: [Validity' a] -> [a]
    getInvalids :: forall a. [Validity' a] -> [a]
    getInvalids [Validity' a]
    vs = [a
    d | NotValid a
    d <- [Validity' a]
    vs]

    -- -----------------------------------------------------------------------------
    -- Collecting up messages for later ordering and printing.

    ----------------
    -- | Formats the input list of structured document, where each element of the list gets a bullet.
    formatBulleted :: DecoratedSDoc -> SDoc
    formatBulleted :: DecoratedSDoc -> SDoc
    formatBulleted (DecoratedSDoc -> [SDoc]
    unDecorated -> [SDoc]
    docs)
      = (SDocContext -> SDoc) -> SDoc
    sdocWithContext ((SDocContext -> SDoc) -> SDoc) -> (SDocContext -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \SDocContext
    ctx -> case SDocContext -> [SDoc]
    msgs SDocContext
    ctx of
            []    -> SDoc
    forall doc. IsOutput doc => doc
    Outputable.empty
            [SDoc
    msg] -> SDoc
    msg
            [SDoc]
    xs    -> [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ (SDoc -> SDoc) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map SDoc -> SDoc
    starred [SDoc]
    xs
        where
        msgs :: SDocContext -> [SDoc]
    msgs SDocContext
    ctx = (SDoc -> Bool) -> [SDoc] -> [SDoc]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SDocContext -> SDoc -> Bool
    Outputable.isEmpty SDocContext
    ctx) [SDoc]
    docs
        starred :: SDoc -> SDoc
    starred = (SDoc
    bulletSDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>)

    pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
    pprMessages :: forall e. Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
    pprMessages DiagnosticOpts e
    e = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> (Messages e -> [SDoc]) -> Messages e -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
    forall e.
    Diagnostic e =>
    DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
    pprMsgEnvelopeBagWithLoc DiagnosticOpts e
    e (Bag (MsgEnvelope e) -> [SDoc])
    -> (Messages e -> Bag (MsgEnvelope e)) -> Messages e -> [SDoc]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Messages e -> Bag (MsgEnvelope e)
    forall e. Messages e -> Bag (MsgEnvelope e)
    getMessages

    pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
    pprMsgEnvelopeBagWithLoc :: forall e.
    Diagnostic e =>
    DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
    pprMsgEnvelopeBagWithLoc DiagnosticOpts e
    e Bag (MsgEnvelope e)
    bag = [ DiagnosticOpts e -> MsgEnvelope e -> SDoc
    forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
    pprLocMsgEnvelope DiagnosticOpts e
    e MsgEnvelope e
    item | MsgEnvelope e
    item <- Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag Maybe DiagOpts
    forall a. Maybe a
    Nothing Bag (MsgEnvelope e)
    bag ]

    -- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really
    -- care about what the configuration is (for example, if the message is in a panic).
    pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
    pprMsgEnvelopeBagWithLocDefault :: forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
    pprMsgEnvelopeBagWithLocDefault Bag (MsgEnvelope e)
    bag = [ MsgEnvelope e -> SDoc
    forall e. Diagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelopeDefault MsgEnvelope e
    item | MsgEnvelope e
    item <- Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag Maybe DiagOpts
    forall a. Maybe a
    Nothing Bag (MsgEnvelope e)
    bag ]

    pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelopeDefault :: forall e. Diagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelopeDefault = DiagnosticOpts e -> MsgEnvelope e -> SDoc
    forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
    pprLocMsgEnvelope (forall opts.
    HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
    DiagnosticOpts opts
    defaultDiagnosticOpts @e)

    pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
    pprLocMsgEnvelope :: forall e. Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
    pprLocMsgEnvelope DiagnosticOpts e
    opts (MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
    errMsgSpan      = SrcSpan
    s
                                   , errMsgDiagnostic :: forall e. MsgEnvelope e -> e
    errMsgDiagnostic = e
    e
                                   , errMsgSeverity :: forall e. MsgEnvelope e -> Severity
    errMsgSeverity  = Severity
    sev
                                   , errMsgContext :: forall e. MsgEnvelope e -> NamePprCtx
    errMsgContext   = NamePprCtx
    name_ppr_ctx
                                   , errMsgReason :: forall e. MsgEnvelope e -> ResolvedDiagnosticReason
    errMsgReason    = ResolvedDiagnosticReason
    reason })
      = NamePprCtx -> SDoc -> SDoc
    withErrStyle NamePprCtx
    name_ppr_ctx (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
          MessageClass -> SrcSpan -> SDoc -> SDoc
    mkLocMessage
            (Severity
    -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
    MCDiagnostic Severity
    sev ResolvedDiagnosticReason
    reason (e -> Maybe DiagnosticCode
    forall a. Diagnostic a => a -> Maybe DiagnosticCode
    diagnosticCode e
    e))
            SrcSpan
    s
            (DecoratedSDoc -> SDoc
    formatBulleted (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ DiagnosticOpts e -> e -> DecoratedSDoc
    forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
    diagnosticMessage DiagnosticOpts e
    opts e
    e)

    sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag :: forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag Maybe DiagOpts
    mopts = [MsgEnvelope e] -> [MsgEnvelope e]
    maybeLimit ([MsgEnvelope e] -> [MsgEnvelope e])
    -> (Bag (MsgEnvelope e) -> [MsgEnvelope e])
    -> Bag (MsgEnvelope e)
    -> [MsgEnvelope e]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MsgEnvelope e -> MsgEnvelope e -> Ordering)
    -> [MsgEnvelope e] -> [MsgEnvelope e]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (SrcSpan -> SrcSpan -> Ordering
    cmp (SrcSpan -> SrcSpan -> Ordering)
    -> (MsgEnvelope e -> SrcSpan)
    -> MsgEnvelope e
    -> MsgEnvelope e
    -> Ordering
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` MsgEnvelope e -> SrcSpan
    forall e. MsgEnvelope e -> SrcSpan
    errMsgSpan) ([MsgEnvelope e] -> [MsgEnvelope e])
    -> (Bag (MsgEnvelope e) -> [MsgEnvelope e])
    -> Bag (MsgEnvelope e)
    -> [MsgEnvelope e]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bag (MsgEnvelope e) -> [MsgEnvelope e]
    forall a. Bag a -> [a]
    bagToList
      where
        cmp :: SrcSpan -> SrcSpan -> Ordering
    cmp
          | Just DiagOpts
    opts <- Maybe DiagOpts
    mopts
          , DiagOpts -> Bool
    diag_reverse_errors DiagOpts
    opts
          = SrcSpan -> SrcSpan -> Ordering
    SrcLoc.rightmost_smallest
          | Bool
    otherwise
          = SrcSpan -> SrcSpan -> Ordering
    SrcLoc.leftmost_smallest
        maybeLimit :: [MsgEnvelope e] -> [MsgEnvelope e]
    maybeLimit
          | Just DiagOpts
    opts <- Maybe DiagOpts
    mopts
          , Just Int
    err_limit <- DiagOpts -> Maybe Int
    diag_max_errors DiagOpts
    opts
          = Int -> [MsgEnvelope e] -> [MsgEnvelope e]
    forall a. Int -> [a] -> [a]
    take Int
    err_limit
          | Bool
    otherwise
          = [MsgEnvelope e] -> [MsgEnvelope e]
    forall a. a -> a
    id

    ghcExit :: Logger -> Int -> IO ()
    ghcExit :: Logger -> Int -> IO ()
    ghcExit Logger
    logger Int
    val
      | Int
    val Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0  = ExitCode -> IO ()
    forall a. ExitCode -> IO a
    exitWith ExitCode
    ExitSuccess
      | Bool
    otherwise = do Logger -> SDoc -> IO ()
    errorMsg Logger
    logger (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "\nCompilation had errors\n\n")
                       ExitCode -> IO ()
    forall a. ExitCode -> IO a
    exitWith (Int -> ExitCode
    ExitFailure Int
    val)

    -- -----------------------------------------------------------------------------
    -- Outputting messages from the compiler

    errorMsg :: Logger -> SDoc -> IO ()
    errorMsg :: Logger -> SDoc -> IO ()
    errorMsg Logger
    logger SDoc
    msg
       = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    errorDiagnostic SrcSpan
    noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $
         PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultErrStyle SDoc
    msg

    fatalErrorMsg :: Logger -> SDoc -> IO ()
    fatalErrorMsg :: Logger -> SDoc -> IO ()
    fatalErrorMsg Logger
    logger SDoc
    msg =
        Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    MCFatal SrcSpan
    noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultErrStyle SDoc
    msg

    compilationProgressMsg :: Logger -> SDoc -> IO ()
    compilationProgressMsg :: Logger -> SDoc -> IO ()
    compilationProgressMsg Logger
    logger SDoc
    msg = do
      let logflags :: LogFlags
    logflags = Logger -> LogFlags
    logFlags Logger
    logger
      let str :: String
    str = SDocContext -> SDoc -> String
    renderWithContext (LogFlags -> SDocContext
    log_default_user_context LogFlags
    logflags) (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "GHC progress: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    msg)
      String -> IO ()
    traceEventIO String
    str
      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Logger -> Int -> Bool
    logVerbAtLeast Logger
    logger Int
    1) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        Logger -> SDoc -> IO ()
    logOutput Logger
    logger (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle SDoc
    msg

    showPass :: Logger -> String -> IO ()
    showPass :: Logger -> String -> IO ()
    showPass Logger
    logger String
    what =
      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Logger -> Int -> Bool
    logVerbAtLeast Logger
    logger Int
    2) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        Logger -> SDoc -> IO ()
    logInfo Logger
    logger (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "***" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon)

    data PrintTimings = PrintTimings | DontPrintTimings
      deriving (PrintTimings -> PrintTimings -> Bool
    (PrintTimings -> PrintTimings -> Bool)
    -> (PrintTimings -> PrintTimings -> Bool) -> Eq PrintTimings
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: PrintTimings -> PrintTimings -> Bool
    == :: PrintTimings -> PrintTimings -> Bool
    $c/= :: PrintTimings -> PrintTimings -> Bool
    /= :: PrintTimings -> PrintTimings -> Bool
    Eq, Int -> PrintTimings -> ShowS
    [PrintTimings] -> ShowS
    PrintTimings -> String
    (Int -> PrintTimings -> ShowS)
    -> (PrintTimings -> String)
    -> ([PrintTimings] -> ShowS)
    -> Show PrintTimings
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> PrintTimings -> ShowS
    showsPrec :: Int -> PrintTimings -> ShowS
    $cshow :: PrintTimings -> String
    show :: PrintTimings -> String
    $cshowList :: [PrintTimings] -> ShowS
    showList :: [PrintTimings] -> ShowS
    Show)

    -- | Time a compilation phase.
    --
    -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
    -- and CPU time used by the phase will be reported to stderr. Consider
    -- a typical usage:
    -- @withTiming getDynFlags (text "simplify") force PrintTimings pass@.
    -- When timings are enabled the following costs are included in the
    -- produced accounting,
    --
    --  - The cost of executing @pass@ to a result @r@ in WHNF
    --  - The cost of evaluating @force r@ to WHNF (e.g. @()@)
    --
    -- The choice of the @force@ function depends upon the amount of forcing
    -- desired; the goal here is to ensure that the cost of evaluating the result
    -- is, to the greatest extent possible, included in the accounting provided by
    -- 'withTiming'. Often the pass already sufficiently forces its result during
    -- construction; in this case @const ()@ is a reasonable choice.
    -- In other cases, it is necessary to evaluate the result to normal form, in
    -- which case something like @Control.DeepSeq.rnf@ is appropriate.
    --
    -- To avoid adversely affecting compiler performance when timings are not
    -- requested, the result is only forced when timings are enabled.
    --
    -- See Note [withTiming] for more.
    withTiming :: MonadIO m
               => Logger
               -> SDoc         -- ^ The name of the phase
               -> (a -> ())    -- ^ A function to force the result
                               -- (often either @const ()@ or 'rnf')
               -> m a          -- ^ The body of the phase to be timed
               -> m a
    withTiming :: forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger SDoc
    what a -> ()
    force m a
    action =
      Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger SDoc
    what a -> ()
    force PrintTimings
    PrintTimings m a
    action

    -- | Same as 'withTiming', but doesn't print timings in the
    --   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).
    --
    --   See Note [withTiming] for more.
    withTimingSilent
      :: MonadIO m
      => Logger
      -> SDoc       -- ^ The name of the phase
      -> (a -> ())  -- ^ A function to force the result
                    -- (often either @const ()@ or 'rnf')
      -> m a        -- ^ The body of the phase to be timed
      -> m a
    withTimingSilent :: forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTimingSilent Logger
    logger SDoc
    what a -> ()
    force m a
    action =
      Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger SDoc
    what a -> ()
    force PrintTimings
    DontPrintTimings m a
    action

    -- | Worker for 'withTiming' and 'withTimingSilent'.
    withTiming' :: MonadIO m
                => Logger
                -> SDoc         -- ^ The name of the phase
                -> (a -> ())    -- ^ A function to force the result
                                -- (often either @const ()@ or 'rnf')
                -> PrintTimings -- ^ Whether to print the timings
                -> m a          -- ^ The body of the phase to be timed
                -> m a
    withTiming' :: forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger SDoc
    what a -> ()
    force_result PrintTimings
    prtimings m a
    action
      = if Logger -> Int -> Bool
    logVerbAtLeast Logger
    logger Int
    2 Bool -> Bool -> Bool
    || Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    Opt_D_dump_timings
        then do Bool -> m () -> m ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    printTimingsNotDumpToFile (m () -> m ()) -> m () -> m ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $
                  Logger -> SDoc -> IO ()
    logInfo Logger
    logger (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                    String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "***" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    colon
                let ctx :: SDocContext
    ctx = LogFlags -> SDocContext
    log_default_user_context (Logger -> LogFlags
    logFlags Logger
    logger)
                alloc0 <- IO Int64 -> m Int64
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Int64
    getAllocationCounter
                start <- liftIO getCPUTime
                eventBegins ctx what
                recordAllocs alloc0
                !r <- action
                () <- pure $ force_result r
                eventEnds ctx what
                end <- liftIO getCPUTime
                alloc1 <- liftIO getAllocationCounter
                recordAllocs alloc1
                -- recall that allocation counter counts down
                let alloc = Int64
    alloc0 Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    alloc1
                    time = Integer -> Double
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac (Integer
    end Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    - Integer
    start) Double -> Double -> Double
    forall a. Num a => a -> a -> a
    * Double
    1e-9

                when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile)
                    $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle
                        (text "!!!" <+> what <> colon <+> text "finished in"
                         <+> doublePrec 2 time
                         <+> text "milliseconds"
                         <> comma
                         <+> text "allocated"
                         <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
                         <+> text "megabytes")

                whenPrintTimings $
                    putDumpFileMaybe logger Opt_D_dump_timings "" FormatText
                        $ text $ showSDocOneLine ctx
                        $ hsep [ what <> colon
                               , text "alloc=" <> ppr alloc
                               , text "time=" <> doublePrec 3 time
                               ]
                pure r
         else m a
    action

        where whenPrintTimings :: IO () -> m ()
    whenPrintTimings =
                IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    printTimings

              printTimings :: Bool
    printTimings =
                PrintTimings
    prtimings PrintTimings -> PrintTimings -> Bool
    forall a. Eq a => a -> a -> Bool
    == PrintTimings
    PrintTimings

              -- Avoid both printing to console and dumping to a file (#20316).
              printTimingsNotDumpToFile :: Bool
    printTimingsNotDumpToFile =
                Bool
    printTimings
                Bool -> Bool -> Bool
    && Bool -> Bool
    not (LogFlags -> Bool
    log_dump_to_file (Logger -> LogFlags
    logFlags Logger
    logger))

              recordAllocs :: a -> m ()
    recordAllocs a
    alloc =
                IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    traceMarkerIO (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "GHC:allocs:" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    alloc

              eventBegins :: SDocContext -> SDoc -> m ()
    eventBegins SDocContext
    ctx SDoc
    w = do
                let doc :: String
    doc = SDocContext -> SDoc -> String
    eventBeginsDoc SDocContext
    ctx SDoc
    w
                IO () -> m ()
    whenPrintTimings (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    traceMarkerIO String
    doc
                IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    traceEventIO String
    doc

              eventEnds :: SDocContext -> SDoc -> m ()
    eventEnds SDocContext
    ctx SDoc
    w = do
                let doc :: String
    doc = SDocContext -> SDoc -> String
    eventEndsDoc SDocContext
    ctx SDoc
    w
                IO () -> m ()
    whenPrintTimings (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    traceMarkerIO String
    doc
                IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    traceEventIO String
    doc

              eventBeginsDoc :: SDocContext -> SDoc -> String
    eventBeginsDoc SDocContext
    ctx SDoc
    w = SDocContext -> SDoc -> String
    showSDocOneLine SDocContext
    ctx (SDoc -> String) -> SDoc -> String
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "GHC:started:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    w
              eventEndsDoc :: SDocContext -> SDoc -> String
    eventEndsDoc   SDocContext
    ctx SDoc
    w = SDocContext -> SDoc -> String
    showSDocOneLine SDocContext
    ctx (SDoc -> String) -> SDoc -> String
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "GHC:finished:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    w

    debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
    debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger Int
    val SDoc
    msg =
       Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (LogFlags -> Int
    log_verbosity (Logger -> LogFlags
    logFlags Logger
    logger) Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    val) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          Logger -> SDoc -> IO ()
    logInfo Logger
    logger (PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle SDoc
    msg)
    {-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities]

    putMsg :: Logger -> SDoc -> IO ()
    putMsg :: Logger -> SDoc -> IO ()
    putMsg Logger
    logger SDoc
    msg = Logger -> SDoc -> IO ()
    logInfo Logger
    logger (PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle SDoc
    msg)

    printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
    printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
    printInfoForUser Logger
    logger NamePprCtx
    name_ppr_ctx SDoc
    msg
      = Logger -> SDoc -> IO ()
    logInfo Logger
    logger (NamePprCtx -> Depth -> SDoc -> SDoc
    withUserStyle NamePprCtx
    name_ppr_ctx Depth
    AllTheWay SDoc
    msg)

    printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
    printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO ()
    printOutputForUser Logger
    logger NamePprCtx
    name_ppr_ctx SDoc
    msg
      = Logger -> SDoc -> IO ()
    logOutput Logger
    logger (NamePprCtx -> Depth -> SDoc -> SDoc
    withUserStyle NamePprCtx
    name_ppr_ctx Depth
    AllTheWay SDoc
    msg)

    logInfo :: Logger -> SDoc -> IO ()
    logInfo :: Logger -> SDoc -> IO ()
    logInfo Logger
    logger SDoc
    msg = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    MCInfo SrcSpan
    noSrcSpan SDoc
    msg

    -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
    logOutput :: Logger -> SDoc -> IO ()
    logOutput :: Logger -> SDoc -> IO ()
    logOutput Logger
    logger SDoc
    msg = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    logMsg Logger
    logger MessageClass
    MCOutput SrcSpan
    noSrcSpan SDoc
    msg

    prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a
    prettyPrintGhcErrors :: forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
    prettyPrintGhcErrors Logger
    logger = do
      let ctx :: SDocContext
    ctx = LogFlags -> SDocContext
    log_default_user_context (Logger -> LogFlags
    logFlags Logger
    logger)
      (GhcException -> m a) -> m a -> m a
    forall (m :: * -> *) e a.
    (HasCallStack, MonadCatch m, Exception e) =>
    (e -> m a) -> m a -> m a
    MC.handle ((GhcException -> m a) -> m a -> m a)
    -> (GhcException -> m a) -> m a -> m a
    forall a b. (a -> b) -> a -> b
    $ \GhcException
    e -> case GhcException
    e of
        PprPanic String
    str SDoc
    doc ->
            SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
    forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
    pprDebugAndThen SDocContext
    ctx String -> m a
    forall a. HasCallStack => String -> a
    panic (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    str) SDoc
    doc
        PprSorry String
    str SDoc
    doc ->
            SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
    forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
    pprDebugAndThen SDocContext
    ctx String -> m a
    forall a. HasCallStack => String -> a
    sorry (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    str) SDoc
    doc
        PprProgramError String
    str SDoc
    doc ->
            SDocContext -> (String -> m a) -> SDoc -> SDoc -> m a
    forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
    pprDebugAndThen SDocContext
    ctx String -> m a
    forall a. HasCallStack => String -> a
    pgmError (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    str) SDoc
    doc
        GhcException
    _ -> IO a -> m a
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO a -> m a) -> IO a -> m a
    forall a b. (a -> b) -> a -> b
    $ GhcException -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO GhcException
    e

    -- | Trace a command (when verbosity level >= 3)
    traceCmd :: Logger -> String -> String -> IO a -> IO a
    traceCmd :: forall a. Logger -> String -> String -> IO a -> IO a
    traceCmd Logger
    logger String
    phase_name String
    cmd_line IO a
    action = do
      Logger -> String -> IO ()
    showPass Logger
    logger String
    phase_name
      let
        cmd_doc :: SDoc
    cmd_doc = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    cmd_line
        handle_exn :: IOException -> IO a
    handle_exn IOException
    exn = do
          Logger -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger Int
    2 (Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '\n')
          Logger -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger Int
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Failed:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    cmd_doc SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (IOException -> String
    forall a. Show a => a -> String
    show IOException
    exn))
          GhcException -> IO a
    forall a. GhcException -> IO a
    throwGhcExceptionIO (String -> GhcException
    ProgramError (IOException -> String
    forall a. Show a => a -> String
    show IOException
    exn))
      Logger -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger Int
    3 SDoc
    cmd_doc
      Logger -> IO ()
    loggerTraceFlush Logger
    logger
       -- And run it!
      IO a
    action IO a -> (IOException -> IO a) -> IO a
    forall a. IO a -> (IOException -> IO a) -> IO a
    `catchIO` IOException -> IO a
    handle_exn

    -- * Tracing utility

    -- | Record in the eventlog when the given tool command starts
    --   and finishes, prepending the given 'String' with
    --   \"systool:\", to easily be able to collect and process
    --   all the systool events.
    --
    --   For those events to show up in the eventlog, you need
    --   to run GHC with @-v2@ or @-ddump-timings@.
    traceSystoolCommand :: Logger -> String -> IO a -> IO a
    traceSystoolCommand :: forall a. Logger -> String -> IO a -> IO a
    traceSystoolCommand Logger
    logger String
    tool = Logger -> SDoc -> (a -> ()) -> IO a -> IO a
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "systool:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    tool) (() -> a -> ()
    forall a b. a -> b -> a
    const ())

    {- Note [withTiming]
    ~~~~~~~~~~~~~~~~~~~~

    For reference:

      withTiming
        :: MonadIO
        => m DynFlags   -- how to get the DynFlags
        -> SDoc         -- label for the computation we're timing
        -> (a -> ())    -- how to evaluate the result
        -> PrintTimings -- whether to report the timings when passed
                        -- -v2 or -ddump-timings
        -> m a          -- computation we're timing
        -> m a

    withTiming lets you run an action while:

    (1) measuring the CPU time it took and reporting that on stderr
        (when PrintTimings is passed),
    (2) emitting start/stop events to GHC's event log, with the label
        given as an argument.

    Evaluation of the result
    ------------------------

    'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is
    to evaluate the result "sufficiently". A given pass might return an 'm a' for
    some monad 'm' and result type 'a', but where the 'a' is complex enough
    that evaluating it to WHNF barely scratches its surface and leaves many
    complex and time-consuming computations unevaluated. Those would only be
    forced by the next pass, and the time needed to evaluate them would be
    mis-attributed to that next pass. A more appropriate function would be
    one that deeply evaluates the result, so as to assign the time spent doing it
    to the pass we're timing.

    Note: as hinted at above, the time spent evaluating the application of the
    forcing function to the result is included in the timings reported by
    'withTiming'.

    How we use it
    -------------

    We measure the time and allocations of various passes in GHC's pipeline by just
    wrapping the whole pass with 'withTiming'. This also materializes by having
    a label for each pass in the eventlog, where each pass is executed in one go,
    during a continuous time window.

    However, from STG onwards, the pipeline uses streams to emit groups of
    STG/Cmm/etc declarations one at a time, and process them until we get to
    assembly code generation. This means that the execution of those last few passes
    is interleaved and that we cannot measure how long they take by just wrapping
    the whole thing with 'withTiming'. Instead we wrap the processing of each
    individual stream element, all along the codegen pipeline, using the appropriate
    label for the pass to which this processing belongs. That generates a lot more
    data but allows us to get fine-grained timings about all the passes and we can
    easily compute totals with tools like ghc-events-analyze (see below).

    Producing an eventlog for GHC
    -----------------------------

    You can produce an eventlog when compiling, for instance, hello.hs by simply
    running:

      If GHC was built by Hadrian:
      $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l

      If GHC was built with Make:
      $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l

    You could alternatively use -v<N> (with N >= 2) instead of -ddump-timings,
    to ask GHC to report timings (on stderr and the eventlog).

    This will write the eventlog to ./ghc.eventlog in both cases. You can then
    visualize it or look at the totals for each label by using ghc-events-analyze,
    threadscope or any other eventlog consumer. Illustrating with
    ghc-events-analyze:

      $ ghc-events-analyze --timed --timed-txt --totals \
                           --start "GHC:started:" --stop "GHC:finished:" \
                           ghc.eventlog

    This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation
    of the execution through the various labels) and ghc.totals.txt (total time
    spent in each label).

    -}