    {-# LANGUAGE BangPatterns    #-}
    {-# LANGUAGE CPP             #-}
    {-# LANGUAGE RankNTypes      #-}
    {-# LANGUAGE ViewPatterns    #-}

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

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

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

            -- * Messages
            WarnMsg,
            MsgEnvelope(..),
            SDoc,
            DecoratedSDoc(unDecorated),
            Messages, ErrorMessages, WarningMessages,
            unionMessages,
            errorsFound, isEmptyMessages,

            -- ** Formatting
            pprMessageBag, pprMsgEnvelopeBagWithLoc,
            pprLocMsgEnvelope,
            formatBulleted,

            -- ** Construction
            emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
            mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,
            mkPlainWarnMsg,
            mkLongWarnMsg,

            -- * Utilities
            doIfSet, doIfSet_dyn,
            getCaretDiagnostic,

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

            sortMsgBag
        ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Driver.Ppr

    import GHC.Data.Bag
    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 System.Exit      ( ExitCode(..), exitWith )
    import Data.List        ( sortBy )
    import Data.Maybe       ( fromMaybe )
    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

    -------------------------
    data Validity
      = IsValid            -- ^ Everything is fine
      | NotValid SDoc    -- ^ A problem, and some indication of why

    isValid :: Validity -> Bool
    isValid :: Validity -> Bool
    isValid Validity
    IsValid       = Bool
    True
    isValid (NotValid {}) = Bool
    False

    andValid :: Validity -> Validity -> Validity
    andValid :: Validity -> Validity -> Validity
    andValid Validity
    IsValid Validity
    v = Validity
    v
    andValid Validity
    v Validity
    _       = Validity
    v

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

    getInvalids :: [Validity] -> [SDoc]
    getInvalids :: [Validity] -> [SDoc]
    getInvalids [Validity]
    vs = [SDoc
    d | NotValid SDoc
    d <- [Validity]
    vs]

    orValid :: Validity -> Validity -> Validity
    orValid :: Validity -> Validity -> Validity
    orValid Validity
    IsValid Validity
    _ = Validity
    IsValid
    orValid Validity
    _       Validity
    v = Validity
    v

    -- -----------------------------------------------------------------------------
    -- 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 :: SDocContext -> DecoratedSDoc -> SDoc
    formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
    formatBulleted SDocContext
    ctx (DecoratedSDoc -> [SDoc]
    unDecorated -> [SDoc]
    docs)
      = case [SDoc]
    msgs of
            []    -> SDoc
    Outputable.empty
            [SDoc
    msg] -> SDoc
    msg
            [SDoc]
    _     -> [SDoc] -> SDoc
    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]
    msgs
        where
        msgs :: [SDoc]
    msgs    = (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
    <+>)

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

    pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelope :: forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelope (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 -> PrintUnqualified
    errMsgContext   = PrintUnqualified
    unqual })
      = (SDocContext -> SDoc) -> SDoc
    sdocWithContext ((SDocContext -> SDoc) -> SDoc) -> (SDocContext -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \SDocContext
    ctx ->
        PrintUnqualified -> SDoc -> SDoc
    withErrStyle PrintUnqualified
    unqual (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Severity -> SrcSpan -> SDoc -> SDoc
    mkLocMessage Severity
    sev SrcSpan
    s (SDocContext -> DecoratedSDoc -> SDoc
    formatBulleted SDocContext
    ctx (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ e -> DecoratedSDoc
    forall a. RenderableDiagnostic a => a -> DecoratedSDoc
    renderDiagnostic e
    e)

    sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag :: forall e. Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
    sortMsgBag Maybe DynFlags
    dflags = [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
              | Bool -> Maybe Bool -> Bool
    forall a. a -> Maybe a -> a
    fromMaybe Bool
    False ((DynFlags -> Bool) -> Maybe DynFlags -> Maybe Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap DynFlags -> Bool
    reverseErrors Maybe DynFlags
    dflags) = SrcSpan -> SrcSpan -> Ordering
    SrcLoc.rightmost_smallest
              | Bool
    otherwise                                   = SrcSpan -> SrcSpan -> Ordering
    SrcLoc.leftmost_smallest
            maybeLimit :: [MsgEnvelope e] -> [MsgEnvelope e]
    maybeLimit = case Maybe (Maybe Int) -> Maybe Int
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join ((DynFlags -> Maybe Int) -> Maybe DynFlags -> Maybe (Maybe Int)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap DynFlags -> Maybe Int
    maxErrors Maybe DynFlags
    dflags) of
              Maybe Int
    Nothing        -> [MsgEnvelope e] -> [MsgEnvelope e]
    forall a. a -> a
    id
              Just Int
    err_limit -> Int -> [MsgEnvelope e] -> [MsgEnvelope e]
    forall a. Int -> [a] -> [a]
    take Int
    err_limit

    ghcExit :: Logger -> DynFlags -> Int -> IO ()
    ghcExit :: Logger -> DynFlags -> Int -> IO ()
    ghcExit Logger
    logger DynFlags
    dflags 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 -> DynFlags -> SDoc -> IO ()
    errorMsg Logger
    logger DynFlags
    dflags (String -> SDoc
    text String
    "\nCompilation had errors\n\n")
                       ExitCode -> IO ()
    forall a. ExitCode -> IO a
    exitWith (Int -> ExitCode
    ExitFailure Int
    val)

    doIfSet :: Bool -> IO () -> IO ()
    doIfSet :: Bool -> IO () -> IO ()
    doIfSet Bool
    flag IO ()
    action | Bool
    flag      = IO ()
    action
                        | Bool
    otherwise = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
    doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO ()
    doIfSet_dyn DynFlags
    dflags GeneralFlag
    flag IO ()
    action | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    flag DynFlags
    dflags = IO ()
    action
                                   | Bool
    otherwise        = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

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

    -- We want all messages to go through one place, so that we can
    -- redirect them if necessary.  For example, when GHC is used as a
    -- library we might want to catch all messages that GHC tries to
    -- output and do something else with them.

    ifVerbose :: DynFlags -> Int -> IO () -> IO ()
    ifVerbose :: DynFlags -> Int -> IO () -> IO ()
    ifVerbose DynFlags
    dflags Int
    val IO ()
    act
      | DynFlags -> Int
    verbosity DynFlags
    dflags Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    val = IO ()
    act
      | Bool
    otherwise               = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    {-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities]

    errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
    errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
    errorMsg Logger
    logger DynFlags
    dflags SDoc
    msg
       = Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevError SrcSpan
    noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultErrStyle SDoc
    msg

    warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
    warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
    warningMsg Logger
    logger DynFlags
    dflags SDoc
    msg
       = Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevWarning SrcSpan
    noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultErrStyle SDoc
    msg

    fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
    fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
    fatalErrorMsg Logger
    logger DynFlags
    dflags SDoc
    msg =
        Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevFatal SrcSpan
    noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultErrStyle SDoc
    msg

    fatalErrorMsg'' :: FatalMessager -> String -> IO ()
    fatalErrorMsg'' :: FatalMessager -> FatalMessager
    fatalErrorMsg'' FatalMessager
    fm String
    msg = FatalMessager
    fm String
    msg

    compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()
    compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()
    compilationProgressMsg Logger
    logger DynFlags
    dflags SDoc
    msg = do
        let str :: String
    str = DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags SDoc
    msg
        FatalMessager
    traceEventIO FatalMessager -> FatalMessager
    forall a b. (a -> b) -> a -> b
    $ String
    "GHC progress: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str
        DynFlags -> Int -> IO () -> IO ()
    ifVerbose DynFlags
    dflags Int
    1 (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            Logger -> DynFlags -> SDoc -> IO ()
    logOutput Logger
    logger DynFlags
    dflags (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle SDoc
    msg

    showPass :: Logger -> DynFlags -> String -> IO ()
    showPass :: Logger -> DynFlags -> FatalMessager
    showPass Logger
    logger DynFlags
    dflags String
    what
      = DynFlags -> Int -> IO () -> IO ()
    ifVerbose DynFlags
    dflags Int
    2 (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle (String -> SDoc
    text String
    "***" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    what SDoc -> SDoc -> SDoc
    <> SDoc
    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
    /= :: PrintTimings -> PrintTimings -> Bool
    $c/= :: PrintTimings -> PrintTimings -> Bool
    == :: PrintTimings -> PrintTimings -> Bool
    $c== :: PrintTimings -> PrintTimings -> Bool
    Eq, Int -> PrintTimings -> String -> String
    [PrintTimings] -> String -> String
    PrintTimings -> String
    (Int -> PrintTimings -> String -> String)
    -> (PrintTimings -> String)
    -> ([PrintTimings] -> String -> String)
    -> Show PrintTimings
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    showList :: [PrintTimings] -> String -> String
    $cshowList :: [PrintTimings] -> String -> String
    show :: PrintTimings -> String
    $cshow :: PrintTimings -> String
    showsPrec :: Int -> PrintTimings -> String -> String
    $cshowsPrec :: Int -> PrintTimings -> String -> String
    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
               -> DynFlags     -- ^ DynFlags
               -> 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 -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger DynFlags
    dflags SDoc
    what a -> ()
    force m a
    action =
      Logger
    -> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger
    -> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger DynFlags
    dflags 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
      -> DynFlags   -- ^ DynFlags
      -> 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 -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTimingSilent Logger
    logger DynFlags
    dflags SDoc
    what a -> ()
    force m a
    action =
      Logger
    -> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger
    -> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger DynFlags
    dflags SDoc
    what a -> ()
    force PrintTimings
    DontPrintTimings m a
    action

    -- | Worker for 'withTiming' and 'withTimingSilent'.
    withTiming' :: MonadIO m
                => Logger
                -> DynFlags   -- ^ 'DynFlags'
                -> 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
    -> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
    withTiming' Logger
    logger DynFlags
    dflags SDoc
    what a -> ()
    force_result PrintTimings
    prtimings m a
    action
      = if DynFlags -> Int
    verbosity DynFlags
    dflags Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    2 Bool -> Bool -> Bool
    || DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_timings DynFlags
    dflags
        then do IO () -> m ()
    whenPrintTimings (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $
                  Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (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
    text String
    "***" SDoc -> SDoc -> SDoc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    <> SDoc
    colon
                let ctx :: SDocContext
    ctx = DynFlags -> SDocContext
    initDefaultSDocContext DynFlags
    dflags
                Int64
    alloc0 <- IO Int64 -> m Int64
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Int64
    getAllocationCounter
                Integer
    start <- IO Integer -> m Integer
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Integer
    getCPUTime
                SDocContext -> SDoc -> m ()
    eventBegins SDocContext
    ctx SDoc
    what
                Int64 -> m ()
    forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
    recordAllocs Int64
    alloc0
                !a
    r <- m a
    action
                () <- () -> m ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (() -> m ()) -> () -> m ()
    forall a b. (a -> b) -> a -> b
    $ a -> ()
    force_result a
    r
                SDocContext -> SDoc -> m ()
    eventEnds SDocContext
    ctx SDoc
    what
                Integer
    end <- IO Integer -> m Integer
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Integer
    getCPUTime
                Int64
    alloc1 <- IO Int64 -> m Int64
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Int64
    getAllocationCounter
                Int64 -> m ()
    forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
    recordAllocs Int64
    alloc1
                -- recall that allocation counter counts down
                let alloc :: Int64
    alloc = Int64
    alloc0 Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    alloc1
                    time :: Double
    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

                Bool -> m () -> m ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (DynFlags -> Int
    verbosity DynFlags
    dflags Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    2 Bool -> Bool -> Bool
    && PrintTimings
    prtimings PrintTimings -> PrintTimings -> Bool
    forall a. Eq a => a -> a -> Bool
    == PrintTimings
    PrintTimings)
                    (m () -> m ()) -> m () -> m ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle
                        (String -> SDoc
    text String
    "!!!" SDoc -> SDoc -> SDoc
    <+> SDoc
    what SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "finished in"
                         SDoc -> SDoc -> SDoc
    <+> Int -> Double -> SDoc
    doublePrec Int
    2 Double
    time
                         SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "milliseconds"
                         SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                         SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "allocated"
                         SDoc -> SDoc -> SDoc
    <+> Int -> Double -> SDoc
    doublePrec Int
    3 (Int64 -> Double
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac Int64
    alloc Double -> Double -> Double
    forall a. Fractional a => a -> a -> a
    / Double
    1024 Double -> Double -> Double
    forall a. Fractional a => a -> a -> a
    / Double
    1024)
                         SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "megabytes")

                IO () -> m ()
    whenPrintTimings (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $
                    Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_timings String
    "" DumpFormat
    FormatText
                        (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDocContext -> SDoc -> String
    showSDocOneLine SDocContext
    ctx
                        (SDoc -> String) -> SDoc -> String
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    hsep [ SDoc
    what SDoc -> SDoc -> SDoc
    <> SDoc
    colon
                               , String -> SDoc
    text String
    "alloc=" SDoc -> SDoc -> SDoc
    <> Int64 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int64
    alloc
                               , String -> SDoc
    text String
    "time=" SDoc -> SDoc -> SDoc
    <> Int -> Double -> SDoc
    doublePrec Int
    3 Double
    time
                               ]
                a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    r
         else m a
    action

        where whenPrintTimings :: IO () -> m ()
    whenPrintTimings = IO () -> m ()
    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 (PrintTimings
    prtimings PrintTimings -> PrintTimings -> Bool
    forall a. Eq a => a -> a -> Bool
    == PrintTimings
    PrintTimings)

              recordAllocs :: a -> m ()
    recordAllocs a
    alloc =
                IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ FatalMessager
    traceMarkerIO FatalMessager -> FatalMessager
    forall a b. (a -> b) -> a -> b
    $ String
    "GHC:allocs:" String -> String -> String
    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
    $ FatalMessager
    traceMarkerIO String
    doc
                IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ FatalMessager
    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
    $ FatalMessager
    traceMarkerIO String
    doc
                IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ FatalMessager
    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
    text String
    "GHC:started:" SDoc -> SDoc -> SDoc
    <+> 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
    text String
    "GHC:finished:" SDoc -> SDoc -> SDoc
    <+> SDoc
    w

    debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    val SDoc
    msg =
       DynFlags -> Int -> IO () -> IO ()
    ifVerbose DynFlags
    dflags Int
    val (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle SDoc
    msg)
    {-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities]

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

    printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
    printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
    printInfoForUser Logger
    logger DynFlags
    dflags PrintUnqualified
    print_unqual SDoc
    msg
      = Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (PrintUnqualified -> Depth -> SDoc -> SDoc
    withUserStyle PrintUnqualified
    print_unqual Depth
    AllTheWay SDoc
    msg)

    printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
    printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
    printOutputForUser Logger
    logger DynFlags
    dflags PrintUnqualified
    print_unqual SDoc
    msg
      = Logger -> DynFlags -> SDoc -> IO ()
    logOutput Logger
    logger DynFlags
    dflags (PrintUnqualified -> Depth -> SDoc -> SDoc
    withUserStyle PrintUnqualified
    print_unqual Depth
    AllTheWay SDoc
    msg)

    logInfo :: Logger -> DynFlags -> SDoc -> IO ()
    logInfo :: Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags SDoc
    msg
      = Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevInfo SrcSpan
    noSrcSpan SDoc
    msg

    -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
    logOutput :: Logger -> DynFlags -> SDoc -> IO ()
    logOutput :: Logger -> DynFlags -> SDoc -> IO ()
    logOutput Logger
    logger DynFlags
    dflags SDoc
    msg
      = Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevOutput SrcSpan
    noSrcSpan SDoc
    msg

    prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
    prettyPrintGhcErrors :: forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
    prettyPrintGhcErrors DynFlags
    dflags
        = (GhcException -> m a) -> m a -> m a
    forall (m :: * -> *) e a.
    (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. String -> a
    panic (String -> SDoc
    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. String -> a
    sorry (String -> SDoc
    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. String -> a
    pgmError (String -> SDoc
    text String
    str) SDoc
    doc
                          GhcException
    _ ->
                              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. Exception e => e -> IO a
    throwIO GhcException
    e
          where
             ctx :: SDocContext
    ctx = DynFlags -> PprStyle -> SDocContext
    initSDocContext DynFlags
    dflags PprStyle
    defaultUserStyle

    traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a
    -- trace the command (at two levels of verbosity)
    traceCmd :: forall a. Logger -> DynFlags -> String -> String -> IO a -> IO a
    traceCmd Logger
    logger DynFlags
    dflags String
    phase_name String
    cmd_line IO a
    action
     = do   { let verb :: Int
    verb = DynFlags -> Int
    verbosity DynFlags
    dflags
            ; Logger -> DynFlags -> FatalMessager
    showPass Logger
    logger DynFlags
    dflags String
    phase_name
            ; Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    3 (String -> SDoc
    text String
    cmd_line)
            ; case DynFlags -> FlushErr
    flushErr DynFlags
    dflags of
                  FlushErr IO ()
    io -> IO ()
    io

               -- And run it!
            ; IO a
    action IO a -> (IOException -> IO a) -> IO a
    forall a. IO a -> (IOException -> IO a) -> IO a
    `catchIO` Int -> IOException -> IO a
    handle_exn Int
    verb
            }
      where
        handle_exn :: Int -> IOException -> IO a
    handle_exn Int
    _verb IOException
    exn = do { Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    2 (Char -> SDoc
    char Char
    '\n')
                                  ; Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    2
                                    (String -> SDoc
    text String
    "Failed:"
                                     SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    cmd_line
                                     SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    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))}

    {- 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
    -----------------------------

    To actually produce the eventlog, you need an eventlog-capable GHC build:

      With Hadrian:
      $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog"

      With Make:
      $ make -j GhcStage2HcOpts+=-eventlog

    You can then produce an eventlog when compiling say hello.hs by simply
    doing:

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

    -}