Commit 4befb415 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Ben Gamari
Browse files

Mention which -Werror promoted a warning to an error

Previously -Werror or -Werror=flag printed warnings as usual and then
printed
these two lines:

    <no location info>: error:
    Failing due to -Werror.

This is not ideal: first, it's not clear which flag made one of the
warnings an
error. Second, warning messages are not modified in any way, so there's
no way
to know which warnings caused this error.

With this patch we (1) promote warning messages to error messages if a
relevant
-Werror is enabled (2) mention which -Werror is used during this
promotion.

Previously:

    [1 of 1] Compiling Main             ( test.hs, test.o )

    test.hs:9:10: warning: [-Wincomplete-patterns]
        Pattern match(es) are non-exhaustive
        In a case alternative: Patterns not matched: (C2 _)
      |
    9 | sInt s = case s of
      |          ^^^^^^^^^...

    test.hs:12:14: warning: [-Wmissing-fields]
        • Fields of ‘Rec’ not initialised: f2
        • In the first argument of ‘print’, namely ‘Rec {f1 =
1}’
          In the expression: print Rec {f1 = 1}
          In an equation for ‘main’: main = print Rec {f1 = 1}
       |
    12 | main = print Rec{ f1 = 1 }
       |              ^^^^^^^^^^^^^

    <no location info>: error:
    Failing due to -Werror.

Now:

    [1 of 1] Compiling Main             ( test.hs, test.o )

    test.hs:9:10: error: [-Wincomplete-patterns,
-Werror=incomplete-patterns]
        Pattern match(es) are non-exhaustive
        In a case alternative: Patterns not matched: (C2 _)
      |
    9 | sInt s = case s of
      |          ^^^^^^^^^...

    test.hs:12:14: error: [-Wmissing-fields, -Werror=missing-fields]
        • Fields of ‘Rec’ not initialised: f2
        • In the first argument of ‘print’, namely ‘Rec {f1 =
1}’
          In the expression: print Rec {f1 = 1}
          In an equation for ‘main’: main = print Rec {f1 = 1}
       |
    12 | main = print Rec{ f1 = 1 }
       |              ^^^^^^^^^^^^^

Test Plan: - Update old tests, add new tests if there aren't any
relevant tests

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3709
parent 3a163aab
......@@ -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 ()
......
......@@ -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)
......
......@@ -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
......
......@@ -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!"
......
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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]
......
<no location info>: error:
Failing due to -Werror.
on the commandline: warning: unrecognised warning flag: -Wfoobar
on the commandline: error: [-Werror]
unrecognised warning flag: -Wfoobar
werror.hs:6:1: warning: [-Wmissing-signatures (in -Wall)]
werror.hs:6:1: error: [-Wmissing-signatures (in -Wall), -Werror=missing-signatures]
Top-level binding with no type signature: main :: IO ()
werror.hs:7:13: warning: [-Wname-shadowing (in -Wall)]
werror.hs:7:13: error: [-Wname-shadowing (in -Wall), -Werror=name-shadowing]
This binding for ‘main’ shadows the existing binding
defined at werror.hs:6:1
werror.hs:7:13: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)]
werror.hs:7:13: error: [-Wunused-local-binds (in -Wextra, -Wunused-binds), -Werror=unused-local-binds]
Defined but not used: ‘main’
werror.hs:8:1: warning: [-Wtabs (in -Wdefault)]
werror.hs:8:1: error: [-Wtabs (in -Wdefault), -Werror=tabs]
Tab character found here.
Please use spaces instead.
werror.hs:10:1: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)]
werror.hs:10:1: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror=unused-top-binds]
Defined but not used: ‘f’
werror.hs:10:1: warning: [-Wmissing-signatures (in -Wall)]
werror.hs:10:1: error: [-Wmissing-signatures (in -Wall), -Werror=missing-signatures]
Top-level binding with no type signature: f :: [a1] -> [a2]
werror.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)]
werror.hs:10:1: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns]
Pattern match(es) are non-exhaustive
In an equation for ‘f’: Patterns not matched: (_:_)
werror.hs:11:1: warning: [-Woverlapping-patterns (in -Wdefault)]
werror.hs:11:1: error: [-Woverlapping-patterns (in -Wdefault), -Werror=overlapping-patterns]
Pattern match is redundant
In an equation for ‘f’: f [] = ...
<no location info>: error:
Failing due to -Werror.
overloadedrecfldsfail05.hs:7:16: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)]
overloadedrecfldsfail05.hs:7:16: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror=unused-top-binds]
Defined but not used: ‘foo’
<no location info>: error:
Failing due to -Werror.
......@@ -10,22 +10,19 @@ OverloadedRecFldsFail06_A.hs:9:59: warning: [-Wunused-top-binds (in -Wextra, -Wu
Defined but not used: ‘used_locally’
[2 of 2] Compiling Main ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o )
overloadedrecfldsfail06.hs:7:1: warning: [-Wunused-imports (in -Wextra)]
overloadedrecfldsfail06.hs:7:1: error: [-Wunused-imports (in -Wextra), -Werror=unused-imports]
The import of ‘Unused(unused), V(x), U(y), MkV, Unused’
from module ‘OverloadedRecFldsFail06_A’ is redundant
overloadedrecfldsfail06.hs:8:1: warning: [-Wunused-imports (in -Wextra)]
overloadedrecfldsfail06.hs:8:1: error: [-Wunused-imports (in -Wextra), -Werror=unused-imports]
The qualified import of ‘OverloadedRecFldsFail06_A’ is redundant
except perhaps to import instances from ‘OverloadedRecFldsFail06_A’
To import instances alone, use: import OverloadedRecFldsFail06_A()
overloadedrecfldsfail06.hs:9:1: warning: [-Wunused-imports (in -Wextra)]
overloadedrecfldsfail06.hs:9:1: error: [-Wunused-imports (in -Wextra), -Werror=unused-imports]
The qualified import of ‘V(y)’
from module ‘OverloadedRecFldsFail06_A’ is redundant
overloadedrecfldsfail06.hs:10:1: warning: [-Wunused-imports (in -Wextra)]
overloadedrecfldsfail06.hs:10:1: error: [-Wunused-imports (in -Wextra), -Werror=unused-imports]
The qualified import of ‘U(x), U’
from module ‘OverloadedRecFldsFail06_A’ is redundant
<no location info>: error:
Failing due to -Werror.
[1 of 2] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o )
[2 of 2] Compiling Main ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o )
overloadedrecfldsfail11.hs:5:15: warning: [-Wdeprecations (in -Wdefault)]
overloadedrecfldsfail11.hs:5:15: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations]
In the use of ‘foo’ (imported from OverloadedRecFldsFail11_A):
"Warning on a record field"
<no location info>: error:
Failing due to -Werror.
[1 of 2] Compiling OverloadedRecFldsFail12_A ( OverloadedRecFldsFail12_A.hs, OverloadedRecFldsFail12_A.o )
[2 of 2] Compiling Main ( overloadedrecfldsfail12.hs, overloadedrecfldsfail12.o )
overloadedrecfldsfail12.hs:10:11: warning: [-Wdeprecations (in -Wdefault)]
overloadedrecfldsfail12.hs:10:11: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations]
In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A):
"Deprecated foo"
overloadedrecfldsfail12.hs:10:20: warning: [-Wdeprecations (in -Wdefault)]
overloadedrecfldsfail12.hs:10:20: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations]
In the use of ‘bar’ (imported from OverloadedRecFldsFail12_A):
"Deprecated bar"
overloadedrecfldsfail12.hs:13:5: warning: [-Wdeprecations (in -Wdefault)]
overloadedrecfldsfail12.hs:13:5: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations]
In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A):
"Deprecated foo"
<no location info>: error:
Failing due to -Werror.
UnliftedPSBind.hs:12:9: warning: [-Wunbanged-strict-patterns (in -Wextra)]
UnliftedPSBind.hs:12:9: error: [-Wunbanged-strict-patterns (in -Wextra), -Werror=unbanged-strict-patterns]
Pattern bindings containing unlifted types should use
an outermost bang pattern:
P x = P 4#
<no location info>: error:
Failing due to -Werror.
unboxed-bind.hs:11:11: warning: [-Wunbanged-strict-patterns (in -Wextra)]
unboxed-bind.hs:11:11: error: [-Wunbanged-strict-patterns (in -Wextra), -Werror=unbanged-strict-patterns]
Pattern bindings containing unlifted types should use
an outermost bang pattern:
P arg = x
<no location info>: error:
Failing due to -Werror.
T5892a.hs:12:8: warning: [-Wmissing-fields (in -Wdefault)]
T5892a.hs:12:8: error: [-Wmissing-fields (in -Wdefault), -Werror=missing-fields]
• Fields of ‘Node’ not initialised: subForest
• In the expression: Node {..}
In the expression: let rootLabel = [] in Node {..}
In an equation for ‘foo’:
foo (Node {..}) = let rootLabel = ... in Node {..}
<no location info>: error:
Failing due to -Werror.
SafeFlags18.hs:1:16:
Warning: -fpackage-trust ignored; must be specified with a Safe Haskell flag
<no location info>:
Failing due to -Werror.
SafeFlags18.hs:1:16: error: [-Werror]
-fpackage-trust ignored; must be specified with a Safe Haskell flag
SafeFlags23.hs:1:16: warning: [-Wunsafe]
SafeFlags23.hs:1:16: error: [-Wunsafe, -Werror=unsafe]
‘SafeFlags22’ has been inferred as unsafe!
Reason:
SafeFlags23.hs:7:1: error:
System.IO.Unsafe: Can't be safely imported!
The module itself isn't safe.
<no location info>: error:
Failing due to -Werror.
SafeFlags26.hs:1:16: warning: [-Wsafe]
SafeFlags26.hs:1:16: error: [-Wsafe, -Werror=safe]
‘SafeFlags26’ has been inferred as safe!
<no location info>: error:
Failing due to -Werror.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment