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

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

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

module ErrUtils (
        -- * 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,

        -- ** 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,
        mkDumpDoc, dumpSDoc, dumpSDocForUser,
        dumpSDocWithStyle,

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

#include "HsVersions.h"

import GhcPrelude

import Bag
import Exception
import Outputable
import Panic
import qualified PprColour as Col
import SrcLoc
import DynFlags
import FastString (unpackFS)
import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import 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.Ord
import Data.Time
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
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 IsValid       = Bool
True
isValid (NotValid {}) = Bool
False

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

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

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

orValid :: Validity -> Validity -> Validity
orValid :: Validity -> Validity -> Validity
orValid IsValid _ = Validity
IsValid
orValid _       v :: 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 (warns1 :: WarningMessages
warns1, errs1 :: WarningMessages
errs1) (warns2 :: WarningMessages
warns2, errs2 :: 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 -> String
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 -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show


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


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

pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag :: Bag MsgDoc -> MsgDoc
pprMessageBag msgs :: 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 String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn Maybe String
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 String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn ann :: Maybe String
ann severity :: Severity
severity locn :: SrcSpan
locn msg :: MsgDoc
msg
    = (DynFlags -> MsgDoc) -> MsgDoc
sdocWithDynFlags ((DynFlags -> MsgDoc) -> MsgDoc) -> (DynFlags -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
      let locn' :: MsgDoc
locn' = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ErrorSpans DynFlags
dflags
                  then SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
locn
                  else SrcLoc -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
locn)

          sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity (DynFlags -> Scheme
colScheme DynFlags
dflags)

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

          -- 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 (DynFlags -> Scheme
colScheme DynFlags
dflags))
                  (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (PprColour -> MsgDoc -> MsgDoc
coloured (Scheme -> PprColour
Col.sHeader (DynFlags -> Scheme
colScheme DynFlags
dflags)) MsgDoc
header) 4
                        MsgDoc
msg)

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

getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour :: Severity -> Scheme -> PprColour
getSeverityColour SevWarning = Scheme -> PprColour
Col.sWarning
getSeverityColour SevError   = Scheme -> PprColour
Col.sError
getSeverityColour SevFatal   = Scheme -> PprColour
Col.sFatal
getSeverityColour _          = 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 _ (UnhelpfulSpan _) = MsgDoc -> IO MsgDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgDoc
empty
getCaretDiagnostic severity :: Severity
severity (RealSrcSpan span :: RealSrcSpan
span) = do
  Maybe String -> MsgDoc
caretDiagnostic (Maybe String -> MsgDoc) -> IO (Maybe String) -> IO MsgDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Int -> IO (Maybe String)
getSrcLine (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span) Int
row

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

    getLine :: Int -> String -> IO (Maybe String)
getLine i :: Int
i fn :: String
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 <- String -> IO StringBuffer
hGetStringBuffer String
fn
      case Int -> StringBuffer -> Maybe StringBuffer
atLine Int
i StringBuffer
content of
        Just at_line :: StringBuffer
at_line -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
          case String -> [String]
lines (Char -> Char
fix (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StringBuffer -> Int -> String
lexemeToString StringBuffer
at_line (StringBuffer -> Int
len StringBuffer
at_line)) of
            srcLine :: String
srcLine : _ -> String -> Maybe String
forall a. a -> Maybe a
Just String
srcLine
            _           -> Maybe String
forall a. Maybe a
Nothing
        _ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
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 '\0' = '\xfffd'
    fix c :: Char
c    = Char
c

    row :: Int
row = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span
    rowStr :: String
rowStr = Int -> String
forall a. Show a => a -> String
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 String -> MsgDoc
caretDiagnostic Nothing = MsgDoc
empty
    caretDiagnostic (Just srcLineWithNewline :: String
srcLineWithNewline) =
      (DynFlags -> MsgDoc) -> MsgDoc
sdocWithDynFlags ((DynFlags -> MsgDoc) -> MsgDoc) -> (DynFlags -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \ dflags :: DynFlags
dflags ->
      let sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity (DynFlags -> Scheme
colScheme DynFlags
dflags)
          marginColour :: PprColour
marginColour = Scheme -> PprColour
Col.sMargin (DynFlags -> Scheme
colScheme DynFlags
dflags)
      in
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (String -> MsgDoc
text String
marginSpace) MsgDoc -> MsgDoc -> MsgDoc
<>
      String -> MsgDoc
text ("\n") MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (String -> MsgDoc
text String
marginRow) MsgDoc -> MsgDoc -> MsgDoc
<>
      String -> MsgDoc
text (" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcLinePre) MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (String -> MsgDoc
text String
srcLineSpan) MsgDoc -> MsgDoc -> MsgDoc
<>
      String -> MsgDoc
text (String
srcLinePost String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n") MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (String -> MsgDoc
text String
marginSpace) MsgDoc -> MsgDoc -> MsgDoc
<>
      PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (String -> MsgDoc
text (" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
caretLine))

      where

        -- expand tabs in a device-independent manner #13664
        expandTabs :: Int -> Int -> ShowS
expandTabs tabWidth :: Int
tabWidth i :: Int
i s :: String
s =
          case String
s of
            ""        -> ""
            '\t' : cs :: String
cs -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
effectiveWidth ' ' String -> 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) String
cs
            c :: Char
c    : cs :: String
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
+ 1) String
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 :: String
srcLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') (Int -> Int -> ShowS
expandTabs 8 0 String
srcLineWithNewline)

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

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

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

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

makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason :: WarnReason
reason err :: 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 dflags :: DynFlags
dflags sev :: Severity
sev locn :: SrcSpan
locn print_unqual :: PrintUnqualified
print_unqual doc :: ErrDoc
doc
 = ErrMsg :: SrcSpan
-> PrintUnqualified
-> ErrDoc
-> String
-> Severity
-> WarnReason
-> ErrMsg
ErrMsg { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
          , errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
print_unqual
          , errMsgDoc :: ErrDoc
errMsgDoc = ErrDoc
doc
          , errMsgShortString :: String
errMsgShortString = DynFlags -> MsgDoc -> String
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 dflags :: 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   dflags :: DynFlags
dflags locn :: SrcSpan
locn unqual :: PrintUnqualified
unqual msg :: MsgDoc
msg extra :: 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       dflags :: DynFlags
dflags locn :: SrcSpan
locn unqual :: PrintUnqualified
unqual msg :: 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  dflags :: DynFlags
dflags locn :: SrcSpan
locn        msg :: 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  dflags :: DynFlags
dflags locn :: SrcSpan
locn unqual :: PrintUnqualified
unqual msg :: MsgDoc
msg extra :: 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      dflags :: DynFlags
dflags locn :: SrcSpan
locn unqual :: PrintUnqualified
unqual msg :: 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 dflags :: DynFlags
dflags locn :: SrcSpan
locn        msg :: 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 (warns :: WarningMessages
warns, errs :: 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 _dflags :: DynFlags
_dflags (_warns :: WarningMessages
_warns, errs :: WarningMessages
errs) = Bool -> Bool
not (WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs)

printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors :: DynFlags -> WarningMessages -> IO ()
printBagOfErrors dflags :: DynFlags
dflags bag_of_errors :: WarningMessages
bag_of_errors
  = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let style :: PprStyle
style = DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle DynFlags
dflags PrintUnqualified
unqual
                in DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
reason Severity
sev SrcSpan
s PprStyle
style (DynFlags -> ErrDoc -> MsgDoc
formatErrDoc DynFlags
dflags 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 :: DynFlags -> ErrDoc -> SDoc
formatErrDoc :: DynFlags -> ErrDoc -> MsgDoc
formatErrDoc dflags :: DynFlags
dflags (ErrDoc important :: [MsgDoc]
important context :: [MsgDoc]
context supplementary :: [MsgDoc]
supplementary)
  = case [[MsgDoc]]
msgs of
        [msg :: [MsgDoc]
msg] -> [MsgDoc] -> MsgDoc
vcat [MsgDoc]
msg
        _ -> [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
. DynFlags -> MsgDoc -> Bool
Outputable.isEmpty DynFlags
dflags))
        [[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 bag :: 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 })
  = (DynFlags -> MsgDoc) -> MsgDoc
sdocWithDynFlags ((DynFlags -> MsgDoc) -> MsgDoc) -> (DynFlags -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    PprStyle -> MsgDoc -> MsgDoc
withPprStyle (DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle DynFlags
dflags PrintUnqualified
unqual) (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
    Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage Severity
sev SrcSpan
s (DynFlags -> ErrDoc -> MsgDoc
formatErrDoc DynFlags
dflags ErrDoc
doc)

sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag :: Maybe DynFlags -> WarningMessages -> [ErrMsg]
sortMsgBag dflags :: 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 ((ErrMsg -> ErrMsg -> Ordering) -> ErrMsg -> ErrMsg -> Ordering
forall a b. (a -> a -> b) -> a -> a -> b
maybeFlip ErrMsg -> ErrMsg -> Ordering
cmp) ([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 maybeFlip :: (a -> a -> b) -> (a -> a -> b)
        maybeFlip :: (a -> a -> b) -> a -> a -> b
maybeFlip
          | 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) = (a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip
          | Bool
otherwise                                   = (a -> a -> b) -> a -> a -> b
forall a. a -> a
id
        cmp :: ErrMsg -> ErrMsg -> Ordering
cmp = (ErrMsg -> SrcSpan) -> ErrMsg -> ErrMsg -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ErrMsg -> SrcSpan
errMsgSpan
        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
          Nothing        -> [a] -> [a]
forall a. a -> a
id
          Just err_limit :: Int
err_limit -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
err_limit

ghcExit :: DynFlags -> Int -> IO ()
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags :: DynFlags
dflags val :: Int
val
  | Int
val Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0  = ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
  | Bool
otherwise = do DynFlags -> MsgDoc -> IO ()
errorMsg DynFlags
dflags (String -> MsgDoc
text "\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 flag :: Bool
flag action :: 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 dflags :: DynFlags
dflags flag :: GeneralFlag
flag action :: 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 -> String -> MsgDoc -> IO ()
dumpIfSet dflags :: DynFlags
dflags flag :: Bool
flag hdr :: String
hdr doc :: MsgDoc
doc
  | Bool -> Bool
not Bool
flag   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise  = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg  DynFlags
dflags
                            WarnReason
NoReason
                            Severity
SevDump
                            SrcSpan
noSrcSpan
                            (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
                            (String -> MsgDoc -> MsgDoc
mkDumpDoc String
hdr MsgDoc
doc)

-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> MsgDoc -> IO ()
dumpIfSet_dyn dflags :: DynFlags
dflags flag :: DumpFlag
flag hdr :: String
hdr doc :: 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
$ DynFlags
-> PrintUnqualified -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
alwaysQualify DumpFlag
flag String
hdr MsgDoc
doc

-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
--
-- Unlike 'dumpIfSet_dyn',
-- has a printer argument but no header argument
dumpIfSet_dyn_printer :: PrintUnqualified
                      -> DynFlags -> DumpFlag -> SDoc -> IO ()
dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> MsgDoc -> IO ()
dumpIfSet_dyn_printer printer :: PrintUnqualified
printer dflags :: DynFlags
dflags flag :: DumpFlag
flag doc :: 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
$ DynFlags
-> PrintUnqualified -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
printer DumpFlag
flag "" MsgDoc
doc

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

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

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


dumpSDoc, dumpSDocForUser
  :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
dumpSDoc :: DynFlags
-> PrintUnqualified -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDoc dflags :: DynFlags
dflags print_unqual :: PrintUnqualified
print_unqual
  = PprStyle -> DynFlags -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
dump_style DynFlags
dflags
  where dump_style :: PprStyle
dump_style = DynFlags -> PrintUnqualified -> PprStyle
mkDumpStyle DynFlags
dflags PrintUnqualified
print_unqual

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
dumpSDocForUser :: DynFlags
-> PrintUnqualified -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDocForUser dflags :: DynFlags
dflags print_unqual :: PrintUnqualified
print_unqual
  = PprStyle -> DynFlags -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
user_style DynFlags
dflags
  where user_style :: PprStyle
user_style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dflags PrintUnqualified
print_unqual Depth
AllTheWay

-- | 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)
--
-- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
-- is used; it is not used to decide whether to dump the output
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> MsgDoc -> IO ()
dumpSDocWithStyle sty :: PprStyle
sty dflags :: DynFlags
dflags flag :: DumpFlag
flag hdr :: String
hdr doc :: MsgDoc
doc =
    DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags DumpFlag
flag Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just handle :: Handle
handle) = do
        MsgDoc
doc' <- if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
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 String -> MsgDoc
text (UTCTime -> String
forall a. Show a => a -> String
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
$ String -> MsgDoc -> MsgDoc
mkDumpDoc String
hdr MsgDoc
d
        DynFlags -> Handle -> MsgDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Handle
handle MsgDoc
doc' PprStyle
sty

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


-- | Choose where to put a dump file based on DynFlags
--
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
chooseDumpFile dflags :: DynFlags
dflags flag :: DumpFlag
flag

        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DumpToFile DynFlags
dflags Bool -> Bool -> Bool
|| DumpFlag
flag DumpFlag -> DumpFlag -> Bool
forall a. Eq a => a -> a -> Bool
== DumpFlag
Opt_D_th_dec_file
        , Just prefix :: String
prefix <- Maybe String
getPrefix
        = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ (DumpFlag -> String
beautifyDumpName DumpFlag
flag))

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

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

-- | Build a nice file name from name of a 'DumpFlag' constructor
beautifyDumpName :: DumpFlag -> String
beautifyDumpName :: DumpFlag -> String
beautifyDumpName Opt_D_th_dec_file = "th.hs"
beautifyDumpName flag :: DumpFlag
flag
 = let str :: String
str = DumpFlag -> String
forall a. Show a => a -> String
show DumpFlag
flag
       suff :: String
suff = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "Opt_D_" String
str of
              Just x :: String
x -> String
x
              Nothing -> ShowS
forall a. String -> a
panic ("Bad flag name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
       dash :: String
dash = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' then '-' else Char
c) String
suff
   in String
dash


-- -----------------------------------------------------------------------------
-- 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 dflags :: DynFlags
dflags val :: Int
val act :: 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 ()

errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags :: DynFlags
dflags msg :: MsgDoc
msg
   = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevError SrcSpan
noSrcSpan (DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags) MsgDoc
msg

warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags :: DynFlags
dflags msg :: MsgDoc
msg
   = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevWarning SrcSpan
noSrcSpan (DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags) MsgDoc
msg

fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags :: DynFlags
dflags msg :: MsgDoc
msg =
    DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevFatal SrcSpan
noSrcSpan (DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags) MsgDoc
msg

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

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

showPass :: DynFlags -> String -> IO ()
showPass :: DynFlags -> String -> IO ()
showPass dflags :: DynFlags
dflags what :: String
what
  = DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags 2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo DynFlags
dflags (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) (String -> MsgDoc
text "***" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon)

-- | 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 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.
withTiming :: MonadIO m
           => 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')
           -> m a         -- ^ The body of the phase to be timed
           -> m a
withTiming :: m DynFlags -> MsgDoc -> (a -> ()) -> m a -> m a
withTiming getDFlags :: m DynFlags
getDFlags what :: MsgDoc
what force_result :: a -> ()
force_result action :: m a
action
  = do DynFlags
dflags <- m DynFlags
getDFlags
       if DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 Bool -> Bool -> Bool
|| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_timings DynFlags
dflags
          then do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo DynFlags
dflags (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags)
                         (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "***" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
                  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDocOneLine DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "GHC:started:" MsgDoc -> MsgDoc -> MsgDoc
<+> 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
                  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceEventIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDocOneLine DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "GHC:finished:" MsgDoc -> MsgDoc -> MsgDoc
<+> 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
* 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
>= 2)
                      (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 -> PprStyle -> MsgDoc -> IO ()
logInfo DynFlags
dflags (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags)
                          (String -> MsgDoc
text "!!!" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "finished in"
                           MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> Double -> MsgDoc
doublePrec 2 Double
time
                           MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "milliseconds"
                           MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
                           MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "allocated"
                           MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> Double -> MsgDoc
doublePrec 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
/ 1024 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 1024)
                           MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "megabytes")

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

debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags :: DynFlags
dflags val :: Int
val msg :: MsgDoc
msg = DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
val (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                               DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo DynFlags
dflags (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags) MsgDoc
msg
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags :: DynFlags
dflags msg :: MsgDoc
msg = DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo DynFlags
dflags (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) MsgDoc
msg

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

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

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

logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logOutput dflags :: DynFlags
dflags sty :: PprStyle
sty msg :: MsgDoc
msg
  = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevOutput SrcSpan
noSrcSpan PprStyle
sty MsgDoc
msg

prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors :: DynFlags -> m a -> m a
prettyPrintGhcErrors dflags :: DynFlags
dflags
    = (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle ((GhcException -> m a) -> m a -> m a)
-> (GhcException -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \e :: GhcException
e -> case GhcException
e of
                      PprPanic str :: String
str doc :: MsgDoc
doc ->
                          DynFlags -> (String -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (String -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags String -> m a
forall a. String -> a
panic (String -> MsgDoc
text String
str) MsgDoc
doc
                      PprSorry str :: String
str doc :: MsgDoc
doc ->
                          DynFlags -> (String -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (String -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags String -> m a
forall a. String -> a
sorry (String -> MsgDoc
text String
str) MsgDoc
doc
                      PprProgramError str :: String
str doc :: MsgDoc
doc ->
                          DynFlags -> (String -> m a) -> MsgDoc -> MsgDoc -> m a
forall a. DynFlags -> (String -> a) -> MsgDoc -> MsgDoc -> a
pprDebugAndThen DynFlags
dflags String -> m a
forall a. String -> a
pgmError (String -> MsgDoc
text String
str) MsgDoc
doc
                      _ ->
                          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 dflags :: DynFlags
dflags ErrMsg{errMsgReason :: ErrMsg -> WarnReason
errMsgReason = Reason wflag :: 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 dflags :: DynFlags
dflags _
  = 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 :: DynFlags -> String -> String -> IO a -> IO a
traceCmd dflags :: DynFlags
dflags phase_name :: String
phase_name cmd_line :: String
cmd_line action :: IO a
action
 = do   { let verb :: Int
verb = DynFlags -> Int
verbosity DynFlags
dflags
        ; DynFlags -> String -> IO ()
showPass DynFlags
dflags String
phase_name
        ; DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (String -> MsgDoc
text String
cmd_line)
        ; case DynFlags -> FlushErr
flushErr DynFlags
dflags of
              FlushErr io :: 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 _verb :: p
_verb exn :: a
exn = do { DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (Char -> MsgDoc
char '\n')
                              ; DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 2
                                (String -> MsgDoc
text "Failed:"
                                 MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
cmd_line
                                 MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (a -> String
forall a. Show a => a -> String
show a
exn))
                              ; GhcException -> IO b
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (a -> String
forall a. Show a => a -> String
show a
exn))}