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

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

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}

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

        -- * Messages
        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
        WarnMsg, MsgDoc,
        Messages, ErrorMessages, WarningMessages,
        unionMessages,
        errMsgSpan, errMsgContext,
        errorsFound, isEmptyMessages,
        isWarnMsgFatal,
        warningsToMessages,

        -- ** Formatting
        pprMessageBag, pprErrMsgBagWithLoc,
        pprLocErrMsg, printBagOfErrors,
        formatErrDoc,

        -- ** Construction
        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
        mkPlainWarnMsg,
        mkLongWarnMsg,

        -- * Utilities
        doIfSet, doIfSet_dyn,
        getCaretDiagnostic,

        -- * Dump files
        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
        dumpOptionsFromFlag, DumpOptions (..),
        DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,
        TraceAction, traceAction, defaultTraceAction,
        touchDumpFile,

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

#include "HsVersions.h"

import GHC.Prelude

import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json

import System.Directory
import System.Exit      ( ExitCode(..), exitWith )
import System.FilePath  ( takeDirectory, (</>) )
import Data.List
import qualified Data.Set as Set
import Data.IORef
import Data.Maybe       ( fromMaybe )
import Data.Function
import Data.Time
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch as MC (handle)
import System.IO
import System.IO.Error  ( catchIOError )
import GHC.Conc         ( getAllocationCounter )
import System.CPUTime

-------------------------
type MsgDoc  = SDoc

-------------------------
data Validity
  = IsValid            -- ^ Everything is fine
  | NotValid MsgDoc    -- ^ 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] -> [MsgDoc]
getInvalids :: [Validity] -> [MsgDoc]
getInvalids [Validity]
vs = [MsgDoc
d | NotValid MsgDoc
d <- [Validity]
vs]

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

-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg

unionMessages :: Messages -> Messages -> Messages
unionMessages :: Messages -> Messages -> Messages
unionMessages (WarningMessages
warns1, WarningMessages
errs1) (WarningMessages
warns2, WarningMessages
errs2) =
  (WarningMessages
warns1 WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
warns2, WarningMessages
errs1 WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
errs2)

data ErrMsg = ErrMsg {
        ErrMsg -> SrcSpan
errMsgSpan        :: SrcSpan,
        ErrMsg -> PrintUnqualified
errMsgContext     :: PrintUnqualified,
        ErrMsg -> ErrDoc
errMsgDoc         :: ErrDoc,
        -- | This has the same text as errDocImportant . errMsgDoc.
        ErrMsg -> FilePath
errMsgShortString :: String,
        ErrMsg -> Severity
errMsgSeverity    :: Severity,
        ErrMsg -> WarnReason
errMsgReason      :: WarnReason
        }
        -- The SrcSpan is used for sorting errors into line-number order


-- | Categorise error msgs by their importance.  This is so each section can
-- be rendered visually distinct.  See Note [Error report] for where these come
-- from.
data ErrDoc = ErrDoc {
        -- | Primary error msg.
        ErrDoc -> [MsgDoc]
errDocImportant     :: [MsgDoc],
        -- | Context e.g. \"In the second argument of ...\".
        ErrDoc -> [MsgDoc]
errDocContext       :: [MsgDoc],
        -- | Supplementary information, e.g. \"Relevant bindings include ...\".
        ErrDoc -> [MsgDoc]
errDocSupplementary :: [MsgDoc]
        }

errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc

type WarnMsg = ErrMsg

data Severity
  = SevOutput
  | SevFatal
  | SevInteractive

  | SevDump
    -- ^ Log message intended for compiler developers
    -- No file\/line\/column stuff

  | SevInfo
    -- ^ Log messages intended for end users.
    -- No file\/line\/column stuff.

  | SevWarning
  | SevError
    -- ^ SevWarning and SevError are used for warnings and errors
    --   o The message has a file\/line\/column heading,
    --     plus "warning:" or "error:",
    --     added by mkLocMessags
    --   o Output is intended for end users
  deriving Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> FilePath
(Int -> Severity -> ShowS)
-> (Severity -> FilePath) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> FilePath
$cshow :: Severity -> FilePath
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show


instance ToJson Severity where
  json :: Severity -> JsonDoc
json Severity
s = FilePath -> JsonDoc
JSString (Severity -> FilePath
forall a. Show a => a -> FilePath
show Severity
s)


instance Show ErrMsg where
    show :: ErrMsg -> FilePath
show ErrMsg
em = ErrMsg -> FilePath
errMsgShortString ErrMsg
em

pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag :: Bag MsgDoc -> MsgDoc
pprMessageBag Bag MsgDoc
msgs = [MsgDoc] -> MsgDoc
vcat (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
blankLine (Bag MsgDoc -> [MsgDoc]
forall a. Bag a -> [a]
bagToList Bag MsgDoc
msgs))

-- | Make an unannotated error message with location info.
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage = Maybe FilePath -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn Maybe FilePath
forall a. Maybe a
Nothing

-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> MsgDoc                             -- ^ message
  -> MsgDoc
  -- Always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
mkLocMessageAnn :: Maybe FilePath -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn Maybe FilePath
ann Severity
severity SrcSpan
locn MsgDoc
msg
    = (SDocContext -> Scheme) -> (Scheme -> MsgDoc) -> MsgDoc
forall a. (SDocContext -> a) -> (a -> MsgDoc) -> MsgDoc
sdocOption SDocContext -> Scheme
sdocColScheme ((Scheme -> MsgDoc) -> MsgDoc) -> (Scheme -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let locn' :: MsgDoc
locn' = (SDocContext -> Bool) -> (Bool -> MsgDoc) -> MsgDoc
forall a. (SDocContext -> a) -> (a -> MsgDoc) -> MsgDoc
sdocOption SDocContext -> Bool
sdocErrorSpans ((Bool -> MsgDoc) -> MsgDoc) -> (Bool -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \case
                     Bool
True  -> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
locn
                     Bool
False -> SrcLoc -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
locn)

          sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme

          -- Add optional information
          optAnn :: MsgDoc
optAnn = case Maybe FilePath
ann of
            Maybe FilePath
Nothing -> FilePath -> MsgDoc
text FilePath
""
            Just FilePath
i  -> FilePath -> MsgDoc
text FilePath
" [" MsgDoc -> MsgDoc -> MsgDoc
<> PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (FilePath -> MsgDoc
text FilePath
i) MsgDoc -> MsgDoc -> MsgDoc
<> FilePath -> MsgDoc
text FilePath
"]"

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header :: MsgDoc
header = MsgDoc
locn' MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+>
                   PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour MsgDoc
sevText MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
optAnn

      in PprColour -> MsgDoc -> MsgDoc
coloured (Scheme -> PprColour
Col.sMessage Scheme
col_scheme)
                  (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (PprColour -> MsgDoc -> MsgDoc
coloured (Scheme -> PprColour
Col.sHeader Scheme
col_scheme) MsgDoc
header) Int
4
                        MsgDoc
msg)

  where
    sevText :: MsgDoc
sevText =
      case Severity
severity of
        Severity
SevWarning -> FilePath -> MsgDoc
text FilePath
"warning:"
        Severity
SevError   -> FilePath -> MsgDoc
text FilePath
"error:"
        Severity
SevFatal   -> FilePath -> MsgDoc
text FilePath
"fatal:"
        Severity
_          -> MsgDoc
empty

getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour :: Severity -> Scheme -> PprColour
getSeverityColour Severity
SevWarning = Scheme -> PprColour
Col.sWarning
getSeverityColour Severity
SevError   = Scheme -> PprColour
Col.sError
getSeverityColour Severity
SevFatal   = Scheme -> PprColour
Col.sFatal
getSeverityColour Severity
_          = PprColour -> Scheme -> PprColour
forall a b. a -> b -> a
const PprColour
forall a. Monoid a => a
mempty

getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic Severity
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = MsgDoc -> IO MsgDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgDoc
empty
getCaretDiagnostic Severity
severity (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) = do
  Maybe FilePath -> MsgDoc
caretDiagnostic (Maybe FilePath -> MsgDoc) -> IO (Maybe FilePath) -> IO MsgDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Int -> IO (Maybe FilePath)
getSrcLine (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span) Int
row

  where
    getSrcLine :: FastString -> Int -> IO (Maybe FilePath)
getSrcLine FastString
fn Int
i =
      Int -> FilePath -> IO (Maybe FilePath)
getLine Int
i (FastString -> FilePath
unpackFS FastString
fn)
        IO (Maybe FilePath)
-> (IOError -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ ->
          Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing

    getLine :: Int -> FilePath -> IO (Maybe FilePath)
getLine Int
i FilePath
fn = do
      -- StringBuffer has advantages over readFile:
      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
      -- (b) always UTF-8, rather than some system-dependent encoding
      --     (Haskell source code must be UTF-8 anyway)
      StringBuffer
content <- FilePath -> IO StringBuffer
hGetStringBuffer FilePath
fn
      case Int -> StringBuffer -> Maybe StringBuffer
atLine Int
i StringBuffer
content of
        Just StringBuffer
at_line -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
          case FilePath -> [FilePath]
lines (Char -> Char
fix (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StringBuffer -> Int -> FilePath
lexemeToString StringBuffer
at_line (StringBuffer -> Int
len StringBuffer
at_line)) of
            FilePath
srcLine : [FilePath]
_ -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
srcLine
            [FilePath]
_           -> Maybe FilePath
forall a. Maybe a
Nothing
        Maybe StringBuffer
_ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing

    -- allow user to visibly see that their code is incorrectly encoded
    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
    fix :: Char -> Char
fix Char
'\0' = Char
'\xfffd'
    fix Char
c    = Char
c

    row :: Int
row = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span
    rowStr :: FilePath
rowStr = Int -> FilePath
forall a. Show a => a -> FilePath
show Int
row
    multiline :: Bool
multiline = Int
row Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span

    caretDiagnostic :: Maybe FilePath -> MsgDoc
caretDiagnostic Maybe FilePath
Nothing = MsgDoc
empty
    caretDiagnostic (Just FilePath
srcLineWithNewline) =
      (SDocContext -> Scheme) -> (Scheme -> MsgDoc) -> MsgDoc
forall a. (SDocContext -> a) -> (a -> MsgDoc) -> MsgDoc
sdocOption SDocContext -> Scheme
sdocColScheme((Scheme -> MsgDoc) -> MsgDoc) -> (Scheme -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme
          marginColour :: PprColour
marginColour = Scheme -> PprColour
Col.sMargin Scheme
col_scheme
      in
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (FilePath -> MsgDoc
text FilePath
marginSpace) MsgDoc -> MsgDoc -> MsgDoc
<>
      FilePath -> MsgDoc
text (FilePath
"\n") MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (FilePath -> MsgDoc
text FilePath
marginRow) MsgDoc -> MsgDoc -> MsgDoc
<>
      FilePath -> MsgDoc
text (FilePath
" " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
srcLinePre) MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (FilePath -> MsgDoc
text FilePath
srcLineSpan) MsgDoc -> MsgDoc -> MsgDoc
<>
      FilePath -> MsgDoc
text (FilePath
srcLinePost FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n") MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (FilePath -> MsgDoc
text FilePath
marginSpace) MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (FilePath -> MsgDoc
text (FilePath
" " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
caretLine))

      where

        -- expand tabs in a device-independent manner #13664
        expandTabs :: Int -> Int -> ShowS
expandTabs Int
tabWidth Int
i FilePath
s =
          case FilePath
s of
            FilePath
""        -> FilePath
""
            Char
'\t' : FilePath
cs -> Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
effectiveWidth Char
' ' FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
                         Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
effectiveWidth) FilePath
cs
            Char
c    : FilePath
cs -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FilePath
cs
          where effectiveWidth :: Int
effectiveWidth = Int
tabWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabWidth

        srcLine :: FilePath
srcLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (Int -> Int -> ShowS
expandTabs Int
8 Int
0 FilePath
srcLineWithNewline)

        start :: Int
start = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        end :: Int
end | Bool
multiline = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
srcLine
            | Bool
otherwise = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)

        marginWidth :: Int
marginWidth = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
rowStr
        marginSpace :: FilePath
marginSpace = Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
marginWidth Char
' ' FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" |"
        marginRow :: FilePath
marginRow   = FilePath
rowStr FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" |"

        (FilePath
srcLinePre,  FilePath
srcLineRest) = Int -> FilePath -> (FilePath, FilePath)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
start FilePath
srcLine
        (FilePath
srcLineSpan, FilePath
srcLinePost) = Int -> FilePath -> (FilePath, FilePath)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
width FilePath
srcLineRest

        caretEllipsis :: FilePath
caretEllipsis | Bool
multiline = FilePath
"..."
                      | Bool
otherwise = FilePath
""
        caretLine :: FilePath
caretLine = Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
start Char
' ' FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
width Char
'^' FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
caretEllipsis

makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning WarnReason
reason ErrMsg
err = ErrMsg
err
    { errMsgSeverity :: Severity
errMsgSeverity = Severity
SevWarning
    , errMsgReason :: WarnReason
errMsgReason = WarnReason
reason }

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

mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg :: DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
sev SrcSpan
locn PrintUnqualified
print_unqual ErrDoc
doc
 = ErrMsg :: SrcSpan
-> PrintUnqualified
-> ErrDoc
-> FilePath
-> Severity
-> WarnReason
-> ErrMsg
ErrMsg { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
          , errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
print_unqual
          , errMsgDoc :: ErrDoc
errMsgDoc = ErrDoc
doc
          , errMsgShortString :: FilePath
errMsgShortString = DynFlags -> MsgDoc -> FilePath
showSDoc DynFlags
dflags ([MsgDoc] -> MsgDoc
vcat (ErrDoc -> [MsgDoc]
errDocImportant ErrDoc
doc))
          , errMsgSeverity :: Severity
errMsgSeverity = Severity
sev
          , errMsgReason :: WarnReason
errMsgReason = WarnReason
NoReason }

mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc DynFlags
dflags = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevError

mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
-- ^ A long (multi-line) error message
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
-- ^ A short (one-line) error message
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
-- ^ Variant that doesn't care about qualified/unqualified names

mkLongErrMsg :: DynFlags
-> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
mkLongErrMsg   DynFlags
dflags SrcSpan
locn PrintUnqualified
unqual MsgDoc
msg MsgDoc
extra = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [MsgDoc
extra])
mkErrMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
mkErrMsg       DynFlags
dflags SrcSpan
locn PrintUnqualified
unqual MsgDoc
msg       = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [])
mkPlainErrMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkPlainErrMsg  DynFlags
dflags SrcSpan
locn        MsgDoc
msg       = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevError   SrcSpan
locn PrintUnqualified
alwaysQualify ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [])
mkLongWarnMsg :: DynFlags
-> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
mkLongWarnMsg  DynFlags
dflags SrcSpan
locn PrintUnqualified
unqual MsgDoc
msg MsgDoc
extra = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [MsgDoc
extra])
mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
mkWarnMsg      DynFlags
dflags SrcSpan
locn PrintUnqualified
unqual MsgDoc
msg       = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [])
mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags SrcSpan
locn        MsgDoc
msg       = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevWarning SrcSpan
locn PrintUnqualified
alwaysQualify ([MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
ErrDoc [MsgDoc
msg] [] [])

----------------
emptyMessages :: Messages
emptyMessages :: Messages
emptyMessages = (WarningMessages
forall a. Bag a
emptyBag, WarningMessages
forall a. Bag a
emptyBag)

isEmptyMessages :: Messages -> Bool
isEmptyMessages :: Messages -> Bool
isEmptyMessages (WarningMessages
warns, WarningMessages
errs) = WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
warns Bool -> Bool -> Bool
&& WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs

errorsFound :: DynFlags -> Messages -> Bool
errorsFound :: DynFlags -> Messages -> Bool
errorsFound DynFlags
_dflags (WarningMessages
_warns, WarningMessages
errs) = Bool -> Bool
not (WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs)

warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages DynFlags
dflags =
  (ErrMsg -> Either ErrMsg ErrMsg) -> WarningMessages -> Messages
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
partitionBagWith ((ErrMsg -> Either ErrMsg ErrMsg) -> WarningMessages -> Messages)
-> (ErrMsg -> Either ErrMsg ErrMsg) -> WarningMessages -> Messages
forall a b. (a -> b) -> a -> b
$ \ErrMsg
warn ->
    case DynFlags -> ErrMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags ErrMsg
warn of
      Maybe (Maybe WarningFlag)
Nothing -> ErrMsg -> Either ErrMsg ErrMsg
forall a b. a -> Either a b
Left ErrMsg
warn
      Just Maybe WarningFlag
err_reason ->
        ErrMsg -> Either ErrMsg ErrMsg
forall a b. b -> Either a b
Right ErrMsg
warn{ errMsgSeverity :: Severity
errMsgSeverity = Severity
SevError
                  , errMsgReason :: WarnReason
errMsgReason = Maybe WarningFlag -> WarnReason
ErrReason Maybe WarningFlag
err_reason }

printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors :: DynFlags -> WarningMessages -> IO ()
printBagOfErrors DynFlags
dflags WarningMessages
bag_of_errors
  = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let style :: PprStyle
style = PrintUnqualified -> PprStyle
mkErrStyle PrintUnqualified
unqual
                    ctx :: SDocContext
ctx   = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
style
                in DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
reason Severity
sev SrcSpan
s (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
style (SDocContext -> ErrDoc -> MsgDoc
formatErrDoc SDocContext
ctx ErrDoc
doc)
              | ErrMsg { errMsgSpan :: ErrMsg -> SrcSpan
errMsgSpan      = SrcSpan
s,
                         errMsgDoc :: ErrMsg -> ErrDoc
errMsgDoc       = ErrDoc
doc,
                         errMsgSeverity :: ErrMsg -> Severity
errMsgSeverity  = Severity
sev,
                         errMsgReason :: ErrMsg -> WarnReason
errMsgReason    = WarnReason
reason,
                         errMsgContext :: ErrMsg -> PrintUnqualified
errMsgContext   = PrintUnqualified
unqual } <- Maybe DynFlags -> WarningMessages -> [ErrMsg]
sortMsgBag (DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
dflags)
                                                                  WarningMessages
bag_of_errors ]

formatErrDoc :: SDocContext -> ErrDoc -> SDoc
formatErrDoc :: SDocContext -> ErrDoc -> MsgDoc
formatErrDoc SDocContext
ctx (ErrDoc [MsgDoc]
important [MsgDoc]
context [MsgDoc]
supplementary)
  = case [[MsgDoc]]
msgs of
        [[MsgDoc]
msg] -> [MsgDoc] -> MsgDoc
vcat [MsgDoc]
msg
        [[MsgDoc]]
_ -> [MsgDoc] -> MsgDoc
vcat ([MsgDoc] -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall a b. (a -> b) -> a -> b
$ ([MsgDoc] -> MsgDoc) -> [[MsgDoc]] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map [MsgDoc] -> MsgDoc
starred [[MsgDoc]]
msgs
    where
    msgs :: [[MsgDoc]]
msgs = ([MsgDoc] -> Bool) -> [[MsgDoc]] -> [[MsgDoc]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([MsgDoc] -> Bool) -> [MsgDoc] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[MsgDoc]] -> [[MsgDoc]]) -> [[MsgDoc]] -> [[MsgDoc]]
forall a b. (a -> b) -> a -> b
$ ([MsgDoc] -> [MsgDoc]) -> [[MsgDoc]] -> [[MsgDoc]]
forall a b. (a -> b) -> [a] -> [b]
map ((MsgDoc -> Bool) -> [MsgDoc] -> [MsgDoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (MsgDoc -> Bool) -> MsgDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> MsgDoc -> Bool
Outputable.isEmpty SDocContext
ctx))
        [[MsgDoc]
important, [MsgDoc]
context, [MsgDoc]
supplementary]
    starred :: [MsgDoc] -> MsgDoc
starred = (MsgDoc
bulletMsgDoc -> MsgDoc -> MsgDoc
<+>) (MsgDoc -> MsgDoc) -> ([MsgDoc] -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgDoc] -> MsgDoc
vcat

pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc :: WarningMessages -> [MsgDoc]
pprErrMsgBagWithLoc WarningMessages
bag = [ ErrMsg -> MsgDoc
pprLocErrMsg ErrMsg
item | ErrMsg
item <- Maybe DynFlags -> WarningMessages -> [ErrMsg]
sortMsgBag Maybe DynFlags
forall a. Maybe a
Nothing WarningMessages
bag ]

pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg :: ErrMsg -> MsgDoc
pprLocErrMsg (ErrMsg { errMsgSpan :: ErrMsg -> SrcSpan
errMsgSpan      = SrcSpan
s
                     , errMsgDoc :: ErrMsg -> ErrDoc
errMsgDoc       = ErrDoc
doc
                     , errMsgSeverity :: ErrMsg -> Severity
errMsgSeverity  = Severity
sev
                     , errMsgContext :: ErrMsg -> PrintUnqualified
errMsgContext   = PrintUnqualified
unqual })
  = (SDocContext -> MsgDoc) -> MsgDoc
sdocWithContext ((SDocContext -> MsgDoc) -> MsgDoc)
-> (SDocContext -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx ->
    PrintUnqualified -> MsgDoc -> MsgDoc
withErrStyle PrintUnqualified
unqual (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage Severity
sev SrcSpan
s (SDocContext -> ErrDoc -> MsgDoc
formatErrDoc SDocContext
ctx ErrDoc
doc)

sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag :: Maybe DynFlags -> WarningMessages -> [ErrMsg]
sortMsgBag Maybe DynFlags
dflags = [ErrMsg] -> [ErrMsg]
forall {a}. [a] -> [a]
maybeLimit ([ErrMsg] -> [ErrMsg])
-> (WarningMessages -> [ErrMsg]) -> WarningMessages -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrMsg -> ErrMsg -> Ordering) -> [ErrMsg] -> [ErrMsg]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
cmp (SrcSpan -> SrcSpan -> Ordering)
-> (ErrMsg -> SrcSpan) -> ErrMsg -> ErrMsg -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ErrMsg -> SrcSpan
errMsgSpan) ([ErrMsg] -> [ErrMsg])
-> (WarningMessages -> [ErrMsg]) -> WarningMessages -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> [ErrMsg]
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 :: [a] -> [a]
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        -> [a] -> [a]
forall a. a -> a
id
          Just Int
err_limit -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
err_limit

ghcExit :: DynFlags -> Int -> IO ()
ghcExit :: DynFlags -> Int -> IO ()
ghcExit 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 DynFlags -> MsgDoc -> IO ()
errorMsg DynFlags
dflags (FilePath -> MsgDoc
text FilePath
"\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 ()

-- -----------------------------------------------------------------------------
-- Dumping

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

-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated
-- despite the fact that 'dumpIfSet' has an @INLINE@.
doDump :: DynFlags -> String -> SDoc -> IO ()
doDump :: DynFlags -> FilePath -> MsgDoc -> IO ()
doDump DynFlags
dflags FilePath
hdr MsgDoc
doc =
  DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags
            WarnReason
NoReason
            Severity
SevDump
            SrcSpan
noSrcSpan
            (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultDumpStyle
              (FilePath -> MsgDoc -> MsgDoc
mkDumpDoc FilePath
hdr MsgDoc
doc))

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

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

mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc :: FilePath -> MsgDoc -> MsgDoc
mkDumpDoc FilePath
hdr MsgDoc
doc
   = [MsgDoc] -> MsgDoc
vcat [MsgDoc
blankLine,
           MsgDoc
line MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
hdr MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
line,
           MsgDoc
doc,
           MsgDoc
blankLine]
     where
        line :: MsgDoc
line = FilePath -> MsgDoc
text (Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
20 Char
'=')


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

-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
-- file, otherwise 'Nothing'.
withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags DumpOptions
dumpOpt Maybe Handle -> IO ()
action = do
    let mFile :: Maybe FilePath
mFile = DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile DynFlags
dflags DumpOptions
dumpOpt
    case Maybe FilePath
mFile of
      Just FilePath
fileName -> do
        let gdref :: IORef (Set FilePath)
gdref = DynFlags -> IORef (Set FilePath)
generatedDumps DynFlags
dflags
        Set FilePath
gd <- IORef (Set FilePath) -> IO (Set FilePath)
forall a. IORef a -> IO a
readIORef IORef (Set FilePath)
gdref
        let append :: Bool
append = FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
fileName Set FilePath
gd
            mode :: IOMode
mode = if Bool
append then IOMode
AppendMode else IOMode
WriteMode
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
append (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IORef (Set FilePath) -> Set FilePath -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set FilePath)
gdref (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
fileName Set FilePath
gd)
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
fileName)
        FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fileName IOMode
mode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8

            Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
      Maybe FilePath
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing


-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
--
-- When @hdr@ is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> FilePath -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags DumpOptions
dumpOpt FilePath
hdr MsgDoc
doc =
    DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags DumpOptions
dumpOpt Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
        MsgDoc
doc' <- if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr
                then MsgDoc -> IO MsgDoc
forall (m :: * -> *) a. Monad m => a -> m a
return MsgDoc
doc
                else do UTCTime
t <- IO UTCTime
getCurrentTime
                        let timeStamp :: MsgDoc
timeStamp = if (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTimestamps DynFlags
dflags)
                                          then MsgDoc
empty
                                          else FilePath -> MsgDoc
text (UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
t)
                        let d :: MsgDoc
d = MsgDoc
timeStamp
                                MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
blankLine
                                MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
doc
                        MsgDoc -> IO MsgDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgDoc -> IO MsgDoc) -> MsgDoc -> IO MsgDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> MsgDoc -> MsgDoc
mkDumpDoc FilePath
hdr MsgDoc
d
        DynFlags -> Handle -> MsgDoc -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Handle
handle (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
sty MsgDoc
doc')

    -- write the dump to stdout
    writeDump Maybe Handle
Nothing = do
        let (MsgDoc
doc', Severity
severity)
              | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr  = (MsgDoc
doc, Severity
SevOutput)
              | Bool
otherwise = (FilePath -> MsgDoc -> MsgDoc
mkDumpDoc FilePath
hdr MsgDoc
doc, Severity
SevDump)
        DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
severity SrcSpan
noSrcSpan (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
sty MsgDoc
doc')


-- | Choose where to put a dump file based on DynFlags
--
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile DynFlags
dflags DumpOptions
dumpOpt

        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DumpToFile DynFlags
dflags Bool -> Bool -> Bool
|| DumpOptions -> Bool
dumpForcedToFile DumpOptions
dumpOpt
        , Just FilePath
prefix <- Maybe FilePath
getPrefix
        = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ DumpOptions -> FilePath
dumpSuffix DumpOptions
dumpOpt)

        | Bool
otherwise
        = Maybe FilePath
forall a. Maybe a
Nothing

        where getPrefix :: Maybe FilePath
getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just FilePath
prefix <- DynFlags -> Maybe FilePath
dumpPrefixForce DynFlags
dflags
                  = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prefix
                 -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
               | Just FilePath
prefix <- DynFlags -> Maybe FilePath
dumpPrefix DynFlags
dflags
                  = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prefix
                 -- we haven't got a place to put a dump file.
               | Bool
otherwise
                  = Maybe FilePath
forall a. Maybe a
Nothing
              setDir :: ShowS
setDir FilePath
f = case DynFlags -> Maybe FilePath
dumpDir DynFlags
dflags of
                         Just FilePath
d  -> FilePath
d FilePath -> ShowS
</> FilePath
f
                         Maybe FilePath
Nothing ->       FilePath
f

-- | Dump options
--
-- Dumps are printed on stdout by default except when the `dumpForcedToFile`
-- field is set to True.
--
-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are
-- written into a file whose suffix is given in the `dumpSuffix` field.
--
data DumpOptions = DumpOptions
   { DumpOptions -> Bool
dumpForcedToFile :: Bool   -- ^ Must be dumped into a file, even if
                                --   -ddump-to-file isn't set
   , DumpOptions -> FilePath
dumpSuffix       :: String -- ^ Filename suffix used when dumped into
                                --   a file
   }

-- | Create dump options from a 'DumpFlag'
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag DumpFlag
Opt_D_th_dec_file =
   DumpOptions :: Bool -> FilePath -> DumpOptions
DumpOptions                        -- -dth-dec-file dumps expansions of TH
      { dumpForcedToFile :: Bool
dumpForcedToFile = Bool
True       -- splices into MODULE.th.hs even when
      , dumpSuffix :: FilePath
dumpSuffix       = FilePath
"th.hs"    -- -ddump-to-file isn't set
      }
dumpOptionsFromFlag DumpFlag
flag =
   DumpOptions :: Bool -> FilePath -> DumpOptions
DumpOptions
      { dumpForcedToFile :: Bool
dumpForcedToFile = Bool
False
      , dumpSuffix :: FilePath
dumpSuffix       = FilePath
suffix -- build a suffix from the flag name
      }                           -- e.g. -ddump-asm => ".dump-asm"
   where
      str :: FilePath
str  = DumpFlag -> FilePath
forall a. Show a => a -> FilePath
show DumpFlag
flag
      suff :: FilePath
suff = case FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"Opt_D_" FilePath
str of
             Just FilePath
x  -> FilePath
x
             Maybe FilePath
Nothing -> ShowS
forall a. FilePath -> a
panic (FilePath
"Bad flag name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
str)
      suffix :: FilePath
suffix = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c) FilePath
suff


-- -----------------------------------------------------------------------------
-- 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 :: DynFlags -> MsgDoc -> IO ()
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg DynFlags
dflags MsgDoc
msg
   = DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevError SrcSpan
noSrcSpan (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultErrStyle MsgDoc
msg

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

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

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

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg :: DynFlags -> FilePath -> IO ()
compilationProgressMsg DynFlags
dflags FilePath
msg = do
    FilePath -> IO ()
traceEventIO (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"GHC progress: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
msg
    DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        DynFlags -> MsgDoc -> IO ()
logOutput DynFlags
dflags (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle (FilePath -> MsgDoc
text FilePath
msg)

showPass :: DynFlags -> String -> IO ()
showPass :: DynFlags -> FilePath -> IO ()
showPass DynFlags
dflags FilePath
what
  = DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DynFlags -> MsgDoc -> IO ()
logInfo DynFlags
dflags (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle (FilePath -> MsgDoc
text FilePath
"***" MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
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 -> ShowS
[PrintTimings] -> ShowS
PrintTimings -> FilePath
(Int -> PrintTimings -> ShowS)
-> (PrintTimings -> FilePath)
-> ([PrintTimings] -> ShowS)
-> Show PrintTimings
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PrintTimings] -> ShowS
$cshowList :: [PrintTimings] -> ShowS
show :: PrintTimings -> FilePath
$cshow :: PrintTimings -> FilePath
showsPrec :: Int -> PrintTimings -> ShowS
$cshowsPrec :: Int -> 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
           => 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 =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags MsgDoc
what a -> ()
force m a
action =
  DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' DynFlags
dflags MsgDoc
what a -> ()
force PrintTimings
PrintTimings m a
action

-- | Like withTiming but get DynFlags from the Monad.
withTimingD :: (MonadIO m, HasDynFlags m)
           => 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
withTimingD :: forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
MsgDoc -> (a -> ()) -> m a -> m a
withTimingD MsgDoc
what a -> ()
force m a
action = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' DynFlags
dflags MsgDoc
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
  => 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 =>
DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTimingSilent DynFlags
dflags MsgDoc
what a -> ()
force m a
action =
  DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' DynFlags
dflags MsgDoc
what a -> ()
force PrintTimings
DontPrintTimings m a
action

-- | Same as 'withTiming', but doesn't print timings in the
--   console (when given @-vN@, @N >= 2@ or @-ddump-timings@)
--   and gets the DynFlags from the given Monad.
--
--   See Note [withTiming] for more.
withTimingSilentD
  :: (MonadIO m, HasDynFlags m)
  => 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
withTimingSilentD :: forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
MsgDoc -> (a -> ()) -> m a -> m a
withTimingSilentD MsgDoc
what a -> ()
force m a
action = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' DynFlags
dflags MsgDoc
what a -> ()
force PrintTimings
DontPrintTimings m a
action

-- | Worker for 'withTiming' and 'withTimingSilent'.
withTiming' :: MonadIO m
            => DynFlags   -- ^ A means of getting a 'DynFlags' (often
                            -- 'getDynFlags' will work here)
            -> 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 =>
DynFlags -> MsgDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' DynFlags
dflags MsgDoc
what a -> ()
force_result PrintTimings
prtimings m a
action
  = do 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
$
                    DynFlags -> MsgDoc -> IO ()
logInfo DynFlags
dflags (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
                      FilePath -> MsgDoc
text FilePath
"***" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
                  let ctx :: SDocContext
ctx = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
                  SDocContext -> MsgDoc -> m ()
eventBegins SDocContext
ctx MsgDoc
what
                  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
                  !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 -> MsgDoc -> m ()
eventEnds SDocContext
ctx MsgDoc
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
                  -- 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
$ DynFlags -> MsgDoc -> IO ()
logInfo DynFlags
dflags (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle
                          (FilePath -> MsgDoc
text FilePath
"!!!" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
"finished in"
                           MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> Double -> MsgDoc
doublePrec Int
2 Double
time
                           MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
"milliseconds"
                           MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
                           MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
"allocated"
                           MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> Double -> MsgDoc
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)
                           MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
"megabytes")

                  IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                      DynFlags -> DumpFlag -> FilePath -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_timings FilePath
"" DumpFormat
FormatText
                          (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MsgDoc
text (FilePath -> MsgDoc) -> FilePath -> MsgDoc
forall a b. (a -> b) -> a -> b
$ SDocContext -> MsgDoc -> FilePath
showSDocOneLine SDocContext
ctx
                          (MsgDoc -> FilePath) -> MsgDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
hsep [ MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
                                 , FilePath -> MsgDoc
text FilePath
"alloc=" MsgDoc -> MsgDoc -> MsgDoc
<> Int64 -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int64
alloc
                                 , FilePath -> MsgDoc
text FilePath
"time=" MsgDoc -> MsgDoc -> MsgDoc
<> Int -> Double -> MsgDoc
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)
          eventBegins :: SDocContext -> MsgDoc -> m ()
eventBegins SDocContext
ctx MsgDoc
w = do
            IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
traceMarkerIO (SDocContext -> MsgDoc -> FilePath
eventBeginsDoc SDocContext
ctx MsgDoc
w)
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
traceEventIO (SDocContext -> MsgDoc -> FilePath
eventBeginsDoc SDocContext
ctx MsgDoc
w)
          eventEnds :: SDocContext -> MsgDoc -> m ()
eventEnds SDocContext
ctx MsgDoc
w = do
            IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
traceMarkerIO (SDocContext -> MsgDoc -> FilePath
eventEndsDoc SDocContext
ctx MsgDoc
w)
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
traceEventIO (SDocContext -> MsgDoc -> FilePath
eventEndsDoc SDocContext
ctx MsgDoc
w)

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

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

putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg DynFlags
dflags MsgDoc
msg = DynFlags -> MsgDoc -> IO ()
logInfo DynFlags
dflags (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle MsgDoc
msg)

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

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

logInfo :: DynFlags -> MsgDoc -> IO ()
logInfo :: DynFlags -> MsgDoc -> IO ()
logInfo DynFlags
dflags MsgDoc
msg
  = DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan MsgDoc
msg

-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput :: DynFlags -> MsgDoc -> IO ()
logOutput :: DynFlags -> MsgDoc -> IO ()
logOutput DynFlags
dflags MsgDoc
msg
  = DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevOutput SrcSpan
noSrcSpan MsgDoc
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 FilePath
str MsgDoc
doc ->
                          DynFlags -> (FilePath -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (FilePath -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags FilePath -> m a
forall a. FilePath -> a
panic (FilePath -> MsgDoc
text FilePath
str) MsgDoc
doc
                      PprSorry FilePath
str MsgDoc
doc ->
                          DynFlags -> (FilePath -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (FilePath -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags FilePath -> m a
forall a. FilePath -> a
sorry (FilePath -> MsgDoc
text FilePath
str) MsgDoc
doc
                      PprProgramError FilePath
str MsgDoc
doc ->
                          DynFlags -> (FilePath -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (FilePath -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags FilePath -> m a
forall a. FilePath -> a
pgmError (FilePath -> MsgDoc
text FilePath
str) MsgDoc
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

-- | Checks if given 'WarnMsg' is a fatal warning.
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal :: DynFlags -> ErrMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags ErrMsg{errMsgReason :: ErrMsg -> WarnReason
errMsgReason = Reason WarningFlag
wflag}
  = if WarningFlag -> DynFlags -> Bool
wopt_fatal WarningFlag
wflag DynFlags
dflags
      then Maybe WarningFlag -> Maybe (Maybe WarningFlag)
forall a. a -> Maybe a
Just (WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
wflag)
      else Maybe (Maybe WarningFlag)
forall a. Maybe a
Nothing
isWarnMsgFatal DynFlags
dflags ErrMsg
_
  = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WarnIsError DynFlags
dflags
      then Maybe WarningFlag -> Maybe (Maybe WarningFlag)
forall a. a -> Maybe a
Just Maybe WarningFlag
forall a. Maybe a
Nothing
      else Maybe (Maybe WarningFlag)
forall a. Maybe a
Nothing

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

           -- And run it!
        ; IO a
action IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` Int -> IOError -> IO a
forall {a} {p} {b}. Show a => p -> a -> IO b
handle_exn Int
verb
        }
  where
    handle_exn :: p -> a -> IO b
handle_exn p
_verb a
exn = do { DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (Char -> MsgDoc
char Char
'\n')
                              ; DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2
                                (FilePath -> MsgDoc
text FilePath
"Failed:"
                                 MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text FilePath
cmd_line
                                 MsgDoc -> MsgDoc -> MsgDoc
<+> FilePath -> MsgDoc
text (a -> FilePath
forall a. Show a => a -> FilePath
show a
exn))
                              ; GhcException -> IO b
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (a -> FilePath
forall a. Show a => a -> FilePath
show a
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).

-}


-- | Format of a dump
--
-- Dump formats are loosely defined: dumps may contain various additional
-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
-- (e.g. for syntax highlighters).
data DumpFormat
   = FormatHaskell   -- ^ Haskell
   | FormatCore      -- ^ Core
   | FormatSTG       -- ^ STG
   | FormatByteCode  -- ^ ByteCode
   | FormatCMM       -- ^ Cmm
   | FormatASM       -- ^ Assembly code
   | FormatC         -- ^ C code/header
   | FormatLLVM      -- ^ LLVM bytecode
   | FormatText      -- ^ Unstructured dump
   deriving (Int -> DumpFormat -> ShowS
[DumpFormat] -> ShowS
DumpFormat -> FilePath
(Int -> DumpFormat -> ShowS)
-> (DumpFormat -> FilePath)
-> ([DumpFormat] -> ShowS)
-> Show DumpFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DumpFormat] -> ShowS
$cshowList :: [DumpFormat] -> ShowS
show :: DumpFormat -> FilePath
$cshow :: DumpFormat -> FilePath
showsPrec :: Int -> DumpFormat -> ShowS
$cshowsPrec :: Int -> DumpFormat -> ShowS
Show,DumpFormat -> DumpFormat -> Bool
(DumpFormat -> DumpFormat -> Bool)
-> (DumpFormat -> DumpFormat -> Bool) -> Eq DumpFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DumpFormat -> DumpFormat -> Bool
$c/= :: DumpFormat -> DumpFormat -> Bool
== :: DumpFormat -> DumpFormat -> Bool
$c== :: DumpFormat -> DumpFormat -> Bool
Eq)

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

type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a

-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpAction
defaultDumpAction :: DumpAction
defaultDumpAction DynFlags
dflags PprStyle
sty DumpOptions
dumpOpt FilePath
title DumpFormat
_fmt MsgDoc
doc = do
   PprStyle -> DynFlags -> DumpOptions -> FilePath -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags DumpOptions
dumpOpt FilePath
title MsgDoc
doc

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

-- | Helper for `dump_action`
dumpAction :: DumpAction
dumpAction :: DumpAction
dumpAction DynFlags
dflags = DynFlags -> DumpAction
dump_action DynFlags
dflags DynFlags
dflags

-- | Helper for `trace_action`
traceAction :: TraceAction
traceAction :: TraceAction
traceAction DynFlags
dflags = DynFlags -> TraceAction
trace_action DynFlags
dflags DynFlags
dflags