{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Utils.Error (
Validity(..), andValid, allValid, isValid, getInvalids, orValid,
Severity(..),
ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
WarnMsg, MsgDoc,
Messages, ErrorMessages, WarningMessages,
unionMessages,
errMsgSpan, errMsgContext,
errorsFound, isEmptyMessages,
isWarnMsgFatal,
warningsToMessages,
pprMessageBag, pprErrMsgBagWithLoc,
pprLocErrMsg, printBagOfErrors,
formatErrDoc,
emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
mkLongWarnMsg,
doIfSet, doIfSet_dyn,
getCaretDiagnostic,
dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
dumpOptionsFromFlag, DumpOptions (..),
DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,
TraceAction, traceAction, defaultTraceAction,
touchDumpFile,
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg, warningMsg,
fatalErrorMsg, fatalErrorMsg'',
compilationProgressMsg,
showPass,
withTiming, withTimingSilent, withTimingD, withTimingSilentD,
debugTraceMsg,
ghcExit,
prettyPrintGhcErrors,
traceCmd
) where
#include "GhclibHsVersions.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
| NotValid MsgDoc
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
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
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,
ErrMsg -> String
errMsgShortString :: String,
ErrMsg -> Severity
errMsgSeverity :: Severity,
ErrMsg -> WarnReason
errMsgReason :: WarnReason
}
data ErrDoc = ErrDoc {
ErrDoc -> [MsgDoc]
errDocImportant :: [MsgDoc],
ErrDoc -> [MsgDoc]
errDocContext :: [MsgDoc],
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
| SevInfo
| SevWarning
| SevError
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 Severity
s = String -> JsonDoc
JSString (Severity -> String
forall a. Show a => a -> String
show Severity
s)
instance Show ErrMsg where
show :: ErrMsg -> String
show ErrMsg
em = ErrMsg -> String
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))
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
mkLocMessageAnn
:: Maybe String
-> Severity
-> SrcSpan
-> MsgDoc
-> MsgDoc
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn Maybe String
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
optAnn :: MsgDoc
optAnn = case Maybe String
ann of
Maybe String
Nothing -> String -> MsgDoc
text String
""
Just String
i -> String -> MsgDoc
text String
" [" MsgDoc -> MsgDoc -> MsgDoc
<> PprColour -> MsgDoc -> MsgDoc
coloured PprColour
sevColour (String -> MsgDoc
text String
i) MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
"]"
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 -> String -> MsgDoc
text String
"warning:"
Severity
SevError -> String -> MsgDoc
text String
"error:"
Severity
SevFatal -> String -> MsgDoc
text String
"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 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 FastString
fn 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` \IOError
_ ->
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 Int
i String
fn = do
StringBuffer
content <- String -> IO StringBuffer
hGetStringBuffer String
fn
case Int -> StringBuffer -> Maybe StringBuffer
atLine Int
i StringBuffer
content of
Just 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
String
srcLine : [String]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
srcLine
[String]
_ -> Maybe String
forall a. Maybe a
Nothing
Maybe StringBuffer
_ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
fix :: Char -> Char
fix Char
'\0' = Char
'\xfffd'
fix 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 Maybe String
Nothing = MsgDoc
empty
caretDiagnostic (Just String
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 (String -> MsgDoc
text String
marginSpace) MsgDoc -> MsgDoc -> MsgDoc
<>
String -> MsgDoc
text (String
"\n") MsgDoc -> MsgDoc -> MsgDoc
<>
PprColour -> MsgDoc -> MsgDoc
coloured PprColour
marginColour (String -> MsgDoc
text String
marginRow) MsgDoc -> MsgDoc -> MsgDoc
<>
String -> MsgDoc
text (String
" " 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]
++ String
"\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
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
caretLine))
where
expandTabs :: Int -> Int -> ShowS
expandTabs Int
tabWidth Int
i String
s =
case String
s of
String
"" -> String
""
Char
'\t' : String
cs -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
effectiveWidth Char
' ' 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
Char
c : 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
+ Int
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
/= Char
'\n') (Int -> Int -> ShowS
expandTabs Int
8 Int
0 String
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 = 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
- 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 = 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 Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |"
marginRow :: String
marginRow = String
rowStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |"
(String
srcLinePre, String
srcLineRest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
start String
srcLine
(String
srcLineSpan, String
srcLinePost) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
width String
srcLineRest
caretEllipsis :: String
caretEllipsis | Bool
multiline = String
"..."
| Bool
otherwise = String
""
caretLine :: String
caretLine = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
start Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
'^' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 }
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
-> 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 DynFlags
dflags = DynFlags
-> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg DynFlags
dflags Severity
SevError
mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
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 (String -> MsgDoc
text String
"\nCompilation had errors\n\n")
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
val)
doIfSet :: Bool -> IO () -> IO ()
doIfSet :: Bool -> IO () -> IO ()
doIfSet Bool
flag IO ()
action | Bool
flag = IO ()
action
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO ()
doIfSet_dyn DynFlags
dflags GeneralFlag
flag IO ()
action | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags = IO ()
action
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet :: DynFlags -> Bool -> String -> MsgDoc -> IO ()
dumpIfSet DynFlags
dflags Bool
flag String
hdr MsgDoc
doc
| Bool -> Bool
not Bool
flag = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = DynFlags -> String -> MsgDoc -> IO ()
doDump DynFlags
dflags String
hdr MsgDoc
doc
{-# INLINE dumpIfSet #-}
doDump :: DynFlags -> String -> SDoc -> IO ()
doDump :: DynFlags -> String -> MsgDoc -> IO ()
doDump DynFlags
dflags String
hdr MsgDoc
doc =
DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags
WarnReason
NoReason
Severity
SevDump
SrcSpan
noSrcSpan
(PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultDumpStyle
(String -> MsgDoc -> MsgDoc
mkDumpDoc String
hdr MsgDoc
doc))
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn = PrintUnqualified
-> DynFlags -> DumpFlag -> String -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn_printer PrintUnqualified
alwaysQualify
{-# INLINE dumpIfSet_dyn #-}
dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String
-> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn_printer :: PrintUnqualified
-> DynFlags -> DumpFlag -> String -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn_printer PrintUnqualified
printer DynFlags
dflags DumpFlag
flag String
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) String
hdr DumpFormat
fmt MsgDoc
doc
{-# INLINE dumpIfSet_dyn_printer #-}
mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc :: String -> MsgDoc -> MsgDoc
mkDumpDoc String
hdr 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 Int
20 Char
'=')
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 ()))
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 String
mFile = DynFlags -> DumpOptions -> Maybe String
chooseDumpFile DynFlags
dflags DumpOptions
dumpOpt
case Maybe String
mFile of
Just 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 -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8
Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
Maybe String
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags DumpOptions
dumpOpt String
hdr MsgDoc
doc =
DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DynFlags
dflags DumpOptions
dumpOpt Maybe Handle -> IO ()
writeDump
where
writeDump :: Maybe Handle -> IO ()
writeDump (Just 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 -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Handle
handle (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
sty MsgDoc
doc')
writeDump Maybe Handle
Nothing = do
let (MsgDoc
doc', 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 -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
severity SrcSpan
noSrcSpan (PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
sty MsgDoc
doc')
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe String
chooseDumpFile DynFlags
dflags DumpOptions
dumpOpt
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DumpToFile DynFlags
dflags Bool -> Bool -> Bool
|| DumpOptions -> Bool
dumpForcedToFile DumpOptions
dumpOpt
, Just 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]
++ DumpOptions -> String
dumpSuffix DumpOptions
dumpOpt)
| Bool
otherwise
= Maybe String
forall a. Maybe a
Nothing
where getPrefix :: Maybe String
getPrefix
| Just String
prefix <- DynFlags -> Maybe String
dumpPrefixForce DynFlags
dflags
= String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
| Just String
prefix <- DynFlags -> Maybe String
dumpPrefix DynFlags
dflags
= String -> Maybe String
forall a. a -> Maybe a
Just String
prefix
| Bool
otherwise
= Maybe String
forall a. Maybe a
Nothing
setDir :: ShowS
setDir String
f = case DynFlags -> Maybe String
dumpDir DynFlags
dflags of
Just String
d -> String
d String -> ShowS
</> String
f
Maybe String
Nothing -> String
f
data DumpOptions = DumpOptions
{ DumpOptions -> Bool
dumpForcedToFile :: Bool
, DumpOptions -> String
dumpSuffix :: String
}
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag DumpFlag
Opt_D_th_dec_file =
DumpOptions :: Bool -> String -> DumpOptions
DumpOptions
{ dumpForcedToFile :: Bool
dumpForcedToFile = Bool
True
, dumpSuffix :: String
dumpSuffix = String
"th.hs"
}
dumpOptionsFromFlag DumpFlag
flag =
DumpOptions :: Bool -> String -> DumpOptions
DumpOptions
{ dumpForcedToFile :: Bool
dumpForcedToFile = Bool
False
, dumpSuffix :: String
dumpSuffix = String
suffix
}
where
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 String
"Opt_D_" String
str of
Just String
x -> String
x
Maybe String
Nothing -> ShowS
forall a. String -> a
panic (String
"Bad flag name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
suffix :: String
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) String
suff
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 #-}
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'' :: (String -> IO ()) -> String -> IO ()
fatalErrorMsg'' String -> IO ()
fm String
msg = String -> IO ()
fm String
msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg DynFlags
dflags String
msg = do
String -> IO ()
traceEventIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC progress: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 (String -> MsgDoc
text String
msg)
showPass :: DynFlags -> String -> IO ()
showPass :: DynFlags -> String -> IO ()
showPass DynFlags
dflags String
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 (String -> MsgDoc
text String
"***" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
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 -> String
(Int -> PrintTimings -> ShowS)
-> (PrintTimings -> String)
-> ([PrintTimings] -> ShowS)
-> Show PrintTimings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrintTimings] -> ShowS
$cshowList :: [PrintTimings] -> ShowS
show :: PrintTimings -> String
$cshow :: PrintTimings -> String
showsPrec :: Int -> PrintTimings -> ShowS
$cshowsPrec :: Int -> PrintTimings -> ShowS
Show)
withTiming :: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> m a
-> m a
withTiming :: 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
withTimingD :: (MonadIO m, HasDynFlags m)
=> SDoc
-> (a -> ())
-> m a
-> m a
withTimingD :: 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
withTimingSilent
:: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilent :: 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
withTimingSilentD
:: (MonadIO m, HasDynFlags m)
=> SDoc
-> (a -> ())
-> m a
-> m a
withTimingSilentD :: 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
withTiming' :: MonadIO m
=> DynFlags
-> SDoc
-> (a -> ())
-> PrintTimings
-> m a
-> m a
withTiming' :: 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
$
String -> MsgDoc
text String
"***" 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
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
(String -> MsgDoc
text String
"!!!" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"finished in"
MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> Double -> MsgDoc
doublePrec Int
2 Double
time
MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"milliseconds"
MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"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
<+> String -> MsgDoc
text String
"megabytes")
IO () -> m ()
whenPrintTimings (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> DumpFlag -> String -> DumpFormat -> MsgDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_timings String
"" DumpFormat
FormatText
(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
$ SDocContext -> MsgDoc -> String
showSDocOneLine SDocContext
ctx
(MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
hsep [ MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
, String -> MsgDoc
text String
"alloc=" MsgDoc -> MsgDoc -> MsgDoc
<> Int64 -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int64
alloc
, String -> MsgDoc
text String
"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
$ String -> IO ()
traceMarkerIO (SDocContext -> MsgDoc -> String
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
$ String -> IO ()
traceEventIO (SDocContext -> MsgDoc -> String
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
$ String -> IO ()
traceMarkerIO (SDocContext -> MsgDoc -> String
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
$ String -> IO ()
traceEventIO (SDocContext -> MsgDoc -> String
eventEndsDoc SDocContext
ctx MsgDoc
w)
eventBeginsDoc :: SDocContext -> MsgDoc -> String
eventBeginsDoc SDocContext
ctx MsgDoc
w = SDocContext -> MsgDoc -> String
showSDocOneLine SDocContext
ctx (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"GHC:started:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
w
eventEndsDoc :: SDocContext -> MsgDoc -> String
eventEndsDoc SDocContext
ctx MsgDoc
w = SDocContext -> MsgDoc -> String
showSDocOneLine SDocContext
ctx (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"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 #-}
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
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 :: DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
dflags
= (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle ((GhcException -> m a) -> m a -> m a)
-> (GhcException -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \GhcException
e -> case GhcException
e of
PprPanic String
str 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 String
str 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 String
str 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
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
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
traceCmd :: DynFlags -> String -> String -> IO a -> IO a
traceCmd DynFlags
dflags String
phase_name String
cmd_line 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 Int
3 (String -> MsgDoc
text String
cmd_line)
; case DynFlags -> FlushErr
flushErr DynFlags
dflags of
FlushErr IO ()
io -> IO ()
io
; 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
(String -> MsgDoc
text String
"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))}
data DumpFormat
= FormatHaskell
| FormatCore
| FormatSTG
| FormatByteCode
| FormatCMM
| FormatASM
| FormatC
| FormatLLVM
| FormatText
deriving (Int -> DumpFormat -> ShowS
[DumpFormat] -> ShowS
DumpFormat -> String
(Int -> DumpFormat -> ShowS)
-> (DumpFormat -> String)
-> ([DumpFormat] -> ShowS)
-> Show DumpFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DumpFormat] -> ShowS
$cshowList :: [DumpFormat] -> ShowS
show :: DumpFormat -> String
$cshow :: DumpFormat -> String
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
defaultDumpAction :: DumpAction
defaultDumpAction :: DumpAction
defaultDumpAction DynFlags
dflags PprStyle
sty DumpOptions
dumpOpt String
title DumpFormat
_fmt MsgDoc
doc = do
PprStyle -> DynFlags -> DumpOptions -> String -> MsgDoc -> IO ()
dumpSDocWithStyle PprStyle
sty DynFlags
dflags DumpOptions
dumpOpt String
title MsgDoc
doc
defaultTraceAction :: TraceAction
defaultTraceAction :: DynFlags -> String -> MsgDoc -> a -> a
defaultTraceAction DynFlags
dflags String
title MsgDoc
doc = DynFlags -> String -> MsgDoc -> a -> a
forall a. DynFlags -> String -> MsgDoc -> a -> a
pprTraceWithFlags DynFlags
dflags String
title MsgDoc
doc
dumpAction :: DumpAction
dumpAction :: DumpAction
dumpAction DynFlags
dflags = DynFlags -> DumpAction
dump_action DynFlags
dflags DynFlags
dflags
traceAction :: TraceAction
traceAction :: DynFlags -> String -> MsgDoc -> a -> a
traceAction DynFlags
dflags = DynFlags -> DynFlags -> String -> MsgDoc -> a -> a
DynFlags -> forall a. DynFlags -> String -> MsgDoc -> a -> a
trace_action DynFlags
dflags DynFlags
dflags