Implement fine-grained `-Werror=...` facility

This patch add new options `-Werror=...`, `-Wwarn=...` and
`-Wno-error=...` (synonym for `-Wwarn=...`).

Semantics:

  - `-Werror` marks all warnings as fatal, including those that don't
    have a warning flag, and CPP warnings.
  - `-Werror=...` enables a warning and marks it as fatal
  - `-Wwarn=...` marks a warning as non-fatal, but doesn't disable it

Test Plan: validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: mpickering, svenpanne, RyanGlScott, thomie

Differential Revision: https://phabricator.haskell.org/D2706

GHC Trac Issues: #11219

3 files changed, 48 insertions, 5 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 126b4575f6..98d27d2aa9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -30,6 +30,7 @@ module DynFlags (
         dopt, dopt_set, dopt_unset,
         gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',
         wopt, wopt_set, wopt_unset,
+        wopt_fatal,
         xopt, xopt_set, xopt_unset,
         lang_set,
         useUnicodeSyntax,
@@ -807,6 +808,7 @@ data DynFlags = DynFlags {
   dumpFlags             :: IntSet,
   generalFlags          :: IntSet,
   warningFlags          :: IntSet,
+  fatalWarningFlags     :: IntSet,
   -- Don't change this without updating extensionFlags:
   language              :: Maybe Language,
   -- | Safe Haskell mode
@@ -1563,6 +1565,7 @@ defaultDynFlags mySettings =
         dumpFlags = IntSet.empty,
         generalFlags = IntSet.fromList (map fromEnum (defaultFlags mySettings)),
         warningFlags = IntSet.fromList (map fromEnum standardWarnings),
+        fatalWarningFlags = IntSet.empty,
         ghciScripts = [],
         language = Nothing,
         safeHaskell = Sf_None,
@@ -1846,6 +1849,22 @@ wopt_set dfs f = dfs{ warningFlags = IntSet.insert (fromEnum f) (warningFlags df
 wopt_unset :: DynFlags -> WarningFlag -> DynFlags
 wopt_unset dfs f = dfs{ warningFlags = IntSet.delete (fromEnum f) (warningFlags dfs) }
 
+-- | Test whether a 'WarningFlag' is set as fatal
+wopt_fatal :: WarningFlag -> DynFlags -> Bool
+wopt_fatal f dflags = fromEnum f `IntSet.member` fatalWarningFlags dflags
+
+-- | Mark a 'WarningFlag' as fatal (do not set the flag)
+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags
+wopt_set_fatal dfs f
+    = dfs { fatalWarningFlags =
+              IntSet.insert (fromEnum f) (fatalWarningFlags dfs) }
+
+-- | Mark a 'WarningFlag' as not fatal
+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
+wopt_unset_fatal dfs f
+    = dfs { fatalWarningFlags =
+              IntSet.delete (fromEnum f) (fatalWarningFlags dfs) }
+
 -- | Test whether a 'LangExt.Extension' is set
 xopt :: LangExt.Extension -> DynFlags -> Bool
 xopt f dflags = fromEnum f `IntSet.member` extensionFlags dflags
@@ -2851,8 +2870,14 @@ dynamic_flags_deps = [
 
      ------ Warning opts -------------------------------------------------
   , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))
-  , make_ord_flag defFlag "Werror"  (NoArg (setGeneralFlag     Opt_WarnIsError))
-  , make_ord_flag defFlag "Wwarn"   (NoArg (unSetGeneralFlag   Opt_WarnIsError))
+  , make_ord_flag defFlag "Werror"
+               (NoArg (do { setGeneralFlag Opt_WarnIsError
+                          ; mapM_ setFatalWarningFlag minusWeverythingOpts   }))
+  , make_ord_flag defFlag "Wwarn"
+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError
+                          ; mapM_ unSetFatalWarningFlag minusWeverythingOpts }))
+                          -- Opt_WarnIsError is still needed to pass -Werror
+                          -- to CPP; see runCpp in SysTools
   , make_dep_flag defFlag "Wnot"    (NoArg (upd (\d ->
                                               d {warningFlags = IntSet.empty})))
                                              "Use -w or -Wno-everything instead"
@@ -3055,6 +3080,14 @@ dynamic_flags_deps = [
  ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps
  ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps
  ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps
+ ++ map (mkFlag turnOn  "Werror="   (\flag -> do {
+                                       ; setWarningFlag flag
+                                       ; setFatalWarningFlag flag }))
+                                                        wWarningFlagsDeps
+ ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )
+                                                        wWarningFlagsDeps
+ ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )
+                                                        wWarningFlagsDeps
  ++ map (mkFlag turnOn  "fwarn-"    setWarningFlag   . hideFlag)
     wWarningFlagsDeps
  ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag)
@@ -4245,6 +4278,10 @@ setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()
 setWarningFlag   f = upd (\dfs -> wopt_set dfs f)
 unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)
 
+setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()
+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)
+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)
+
 --------------------------
 setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()
 setExtensionFlag f = upd (setExtensionFlag' f)
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 41150a6383..db593509c9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -20,6 +20,7 @@ module ErrUtils (
         unionMessages,
         errMsgSpan, errMsgContext,
         errorsFound, isEmptyMessages,
+        isWarnMsgFatal,
 
         -- ** Formatting
         pprMessageBag, pprErrMsgBagWithLoc,
@@ -553,3 +554,9 @@ prettyPrintGhcErrors dflags
                           pprDebugAndThen dflags pgmError (text str) doc
                       _ ->
                           liftIO $ throwIO e
+
+-- | Checks if given 'WarnMsg' is a fatal warning.
+isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
+isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
+  = wopt_fatal wflag dflags
+isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index cd1878ffe9..b3a332edeb 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -318,9 +318,8 @@ instance Exception GhcApiError
 -- -Werror is enabled, or print them out otherwise.
 printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
 printOrThrowWarnings dflags warns
-  | gopt Opt_WarnIsError dflags
-  = when (not (isEmptyBag warns)) $ do
-      throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
+  | anyBag (isWarnMsgFatal dflags) warns
+  = throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
   | otherwise
   = printBagOfErrors dflags warns