summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/main/DynFlags.hs79
-rw-r--r--compiler/main/ErrUtils.hs19
-rw-r--r--compiler/main/HscTypes.hs24
-rw-r--r--compiler/rename/RnNames.hs3
-rw-r--r--compiler/typecheck/Inst.hs6
-rw-r--r--compiler/typecheck/TcRnExports.hs16
-rw-r--r--compiler/typecheck/TcRnMonad.hs19
-rw-r--r--compiler/typecheck/TcSigs.hs2
8 files changed, 101 insertions, 67 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
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 3c1473402c..6dc9f1d0d2 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -266,8 +266,7 @@ rnImportDecl this_mod
-- the non-boot module depends on the compilation order, which
-- is not deterministic. The hs-boot test can show this up.
dflags <- getDynFlags
- warnIf NoReason
- (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
+ warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErr (text "safe import can't be used as Safe Haskell isn't on!"
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index a565959c9a..20c3d5cbb9 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -676,9 +676,9 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
; oflag <- getOverlapFlag overlap_mode
; let inst = mkLocalInstance dfun oflag tvs' clas tys'
- ; warnIf (Reason Opt_WarnOrphans)
- (isOrphan (is_orphan inst))
- (instOrphWarn inst)
+ ; warnIfFlag Opt_WarnOrphans
+ (isOrphan (is_orphan inst))
+ (instOrphWarn inst)
; return inst }
instOrphWarn :: ClsInst -> SDoc
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 3965675b77..ec099582a1 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -220,8 +220,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
| let earlier_mods = [ mod
| (L _ (IEModuleContents (L _ mod))) <- ie_names ]
, mod `elem` earlier_mods -- Duplicate export of M
- = do { warnIf (Reason Opt_WarnDuplicateExports) True
- (dupModuleExport mod) ;
+ = do { warnIfFlag Opt_WarnDuplicateExports True
+ (dupModuleExport mod) ;
return acc }
| otherwise
@@ -234,9 +234,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
}
; checkErr exportValid (moduleNotImported mod)
- ; warnIf (Reason Opt_WarnDodgyExports)
- (exportValid && null gre_prs)
- (nullModuleExport mod)
+ ; warnIfFlag Opt_WarnDodgyExports
+ (exportValid && null gre_prs)
+ (nullModuleExport mod)
; traceRn "efa" (ppr mod $$ ppr all_gres)
; addUsedGREs all_gres
@@ -594,9 +594,9 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie'
| name == name' -- Duplicate export
-- But we don't want to warn if the same thing is exported
-- by two different module exports. See ticket #4478.
- -> do { warnIf (Reason Opt_WarnDuplicateExports)
- (not (dupExport_ok name ie ie'))
- (dupExportWarn name_occ ie ie')
+ -> do { warnIfFlag Opt_WarnDuplicateExports
+ (not (dupExport_ok name ie ie'))
+ (dupExportWarn name_occ ie ie')
; return occs }
| otherwise -- Same occ name but different names: an error
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 812ed0a266..a6a995de1a 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -82,7 +82,7 @@ module TcRnMonad(
failWithTc, failWithTcM,
checkTc, checkTcM,
failIfTc, failIfTcM,
- warnIf, warnTc, warnTcM,
+ warnIfFlag, warnIf, warnTc, warnTcM,
addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
@@ -1231,15 +1231,18 @@ failIfTcM True err = failWithTcM err
-- Warnings have no 'M' variant, nor failure
--- | Display a warning if a condition is met.
+-- | Display a warning if a condition is met,
-- and the warning is enabled
-warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
-warnIf reason is_bad msg
- = do { warn_on <- case reason of
- NoReason -> return True
- Reason warn_flag -> woptM warn_flag
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+ = do { warn_on <- woptM warn_flag
; when (warn_on && is_bad) $
- addWarn reason msg }
+ addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+ = when is_bad (addWarn NoReason msg)
-- | Display a warning if a condition is met.
warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index 803761b903..c898fd96bd 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -695,7 +695,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
-- However we want to use fun_name in the error message, since that is
-- what the user wrote (Trac #8537)
= addErrCtxt (spec_ctxt prag) $
- do { warnIf NoReason (not (isOverloadedTy poly_ty || isInlinePragma inl))
+ do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
(text "SPECIALISE pragma for non-overloaded function"
<+> quotes (ppr fun_name))
-- Note [SPECIALISE pragmas]
View Lorry Controller Status