summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs79
-rw-r--r--compiler/main/ErrUtils.hs19
-rw-r--r--compiler/main/HscTypes.hs24
3 files changed, 77 insertions, 45 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dac3136579..2be121e133 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -585,7 +585,12 @@ data GeneralFlag
-- | Used when outputting warnings: if a reason is given, it is
-- displayed. If a warning isn't controlled by a flag, this is made
-- explicit at the point of use.
-data WarnReason = NoReason | Reason !WarningFlag
+data WarnReason
+ = NoReason
+ -- | Warning was enabled with the flag
+ | Reason !WarningFlag
+ -- | Warning was made an error because of -Werror or -Werror=WarningFlag
+ | ErrReason !(Maybe WarningFlag)
deriving Show
instance Outputable WarnReason where
@@ -594,6 +599,8 @@ instance Outputable WarnReason where
instance ToJson WarnReason where
json NoReason = JSNull
json (Reason wf) = JSString (show wf)
+ json (ErrReason Nothing) = JSString "Opt_WarnIsError"
+ json (ErrReason (Just wf)) = JSString (show wf)
data WarningFlag =
-- See Note [Updating flag description in the User's Guide]
@@ -1827,34 +1834,48 @@ defaultLogAction dflags reason severity srcSpan style msg
SevInteractive -> putStrSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
- _ -> do -- otherwise (i.e. SevError or SevWarning)
- hPutChar stderr '\n'
- caretDiagnostic <-
- if gopt Opt_DiagnosticsShowCaret dflags
- then getCaretDiagnostic severity srcSpan
- else pure empty
- printErrs (message $+$ caretDiagnostic)
- (setStyleColoured True style)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
- where printOut = defaultLogActionHPrintDoc dflags stdout
- printErrs = defaultLogActionHPrintDoc dflags stderr
- putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
- -- Pretty print the warning flag, if any (#10752)
- message = mkLocMessageAnn flagMsg severity srcSpan msg
- flagMsg = case reason of
- NoReason -> Nothing
- Reason flag -> (\spec -> "-W" ++ flagSpecName spec ++ flagGrp flag) <$>
- flagSpecOf flag
-
- flagGrp flag
- | gopt Opt_ShowWarnGroups dflags =
- case smallestGroups flag of
- [] -> ""
- groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
- | otherwise = ""
+ SevWarning -> printWarns
+ SevError -> printWarns
+ where
+ printOut = defaultLogActionHPrintDoc dflags stdout
+ printErrs = defaultLogActionHPrintDoc dflags stderr
+ putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
+ -- Pretty print the warning flag, if any (#10752)
+ message = mkLocMessageAnn flagMsg severity srcSpan msg
+
+ printWarns = do
+ hPutChar stderr '\n'
+ caretDiagnostic <-
+ if gopt Opt_DiagnosticsShowCaret dflags
+ then getCaretDiagnostic severity srcSpan
+ else pure empty
+ printErrs (message $+$ caretDiagnostic)
+ (setStyleColoured True style)
+ -- careful (#2302): printErrs prints in UTF-8,
+ -- whereas converting to string first and using
+ -- hPutStr would just emit the low 8 bits of
+ -- each unicode char.
+
+ flagMsg =
+ case reason of
+ NoReason -> Nothing
+ Reason wflag -> do
+ spec <- flagSpecOf wflag
+ return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)
+ ErrReason Nothing ->
+ return "-Werror"
+ ErrReason (Just wflag) -> do
+ spec <- flagSpecOf wflag
+ return $
+ "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++
+ ", -Werror=" ++ flagSpecName spec
+
+ warnFlagGrp flag
+ | gopt Opt_ShowWarnGroups dflags =
+ case smallestGroups flag of
+ [] -> ""
+ groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
+ | otherwise = ""
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index c0127b2a27..5883fe14da 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -14,7 +14,7 @@ module ErrUtils (
Severity(..),
-- * Messages
- ErrMsg, errMsgDoc,
+ ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
WarnMsg, MsgDoc,
Messages, ErrorMessages, WarningMessages,
@@ -32,7 +32,7 @@ module ErrUtils (
emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
- warnIsErrorMsg, mkLongWarnMsg,
+ mkLongWarnMsg,
-- * Utilities
doIfSet, doIfSet_dyn,
@@ -349,10 +349,6 @@ emptyMessages = (emptyBag, emptyBag)
isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
-warnIsErrorMsg :: DynFlags -> ErrMsg
-warnIsErrorMsg dflags
- = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
-
errorsFound :: DynFlags -> Messages -> Bool
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
@@ -670,10 +666,15 @@ prettyPrintGhcErrors dflags
liftIO $ throwIO e
-- | Checks if given 'WarnMsg' is a fatal warning.
-isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
+isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
- = wopt_fatal wflag dflags
-isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
+ = if wopt_fatal wflag dflags
+ then Just (Just wflag)
+ else Nothing
+isWarnMsgFatal dflags _
+ = if gopt Opt_WarnIsError dflags
+ then Just Nothing
+ else Nothing
traceCmd :: DynFlags -> String -> String -> IO a -> IO a
-- trace the command (at two levels of verbosity)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 9f1da3fcdd..f7a8140583 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -179,7 +179,7 @@ import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule
import TysWiredIn
import Packages hiding ( Version(..) )
import CmdLineParser
-import DynFlags hiding ( WarnReason(..) )
+import DynFlags
import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString )
import BasicTypes
import IfaceSyn
@@ -322,11 +322,21 @@ instance Exception GhcApiError
-- | Given a bag of warnings, turn them into an exception if
-- -Werror is enabled, or print them out otherwise.
printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings dflags warns
- | anyBag (isWarnMsgFatal dflags) warns
- = throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
- | otherwise
- = printBagOfErrors dflags warns
+printOrThrowWarnings dflags warns = do
+ let (make_error, warns') =
+ mapAccumBagL
+ (\make_err warn ->
+ case isWarnMsgFatal dflags warn of
+ Nothing ->
+ (make_err, warn)
+ Just err_reason ->
+ (True, warn{ errMsgSeverity = SevError
+ , errMsgReason = ErrReason err_reason
+ }))
+ False warns
+ if make_error
+ then throwIO (mkSrcErr warns')
+ else printBagOfErrors dflags warns
handleFlagWarnings :: DynFlags -> [Warn] -> IO ()
handleFlagWarnings dflags warns = do
@@ -340,7 +350,7 @@ handleFlagWarnings dflags warns = do
printOrThrowWarnings dflags bag
-- Given a warn reason, check to see if it's associated -W opt is enabled
-shouldPrintWarning :: DynFlags -> WarnReason -> Bool
+shouldPrintWarning :: DynFlags -> CmdLineParser.WarnReason -> Bool
shouldPrintWarning dflags ReasonDeprecatedFlag
= wopt Opt_WarnDeprecatedFlags dflags
shouldPrintWarning dflags ReasonUnrecognisedFlag
View Lorry Controller Status