{-# 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).

-}