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

14 files changed, 108 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
 
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index c9216b9307..fdda600773 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -92,16 +92,33 @@ The following flags are simple ways to select standard "packages" of warnings:
     Turns off all warnings, including the standard ones and those that
     :ghc-flag:`-Wall` doesn't enable.
 
+These options control which warnings are considered fatal and cause compilation
+to abort.
+
 .. ghc-flag:: -Werror
 
     Makes any warning into a fatal error. Useful so that you don't miss
     warnings when doing batch compilation.
 
+.. ghc-flag:: -Werror=<wflag>
+
+    :implies: ``-W<wflag>``
+
+    Makes a specific warning into a fatal error. The warning will be enabled if
+    it hasn't been enabled yet.
+
 .. ghc-flag:: -Wwarn
 
     Warnings are treated only as warnings, not as errors. This is the
     default, but can be useful to negate a :ghc-flag:`-Werror` flag.
 
+.. ghc-flag:: -Wwarn=<wflag>
+
+    Causes a specific warning to be treated as normal warning, not fatal error.
+
+    Note that it doesn't fully negate the effects of ``-Werror=<wflag>`` - the
+    warning will still be enabled.
+
 When a warning is emitted, the specific warning flag which controls
 it is shown.
 
diff --git a/testsuite/tests/warnings/should_compile/Werror01.hs b/testsuite/tests/warnings/should_compile/Werror01.hs
new file mode 100644
index 0000000000..f4cb54c7d1
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/Werror01.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -Wmissing-signatures -Werror=incomplete-patterns #-}
+module Werror01 where
+
+-- this should generate missing-signatures, but not incomplete-patterns
+foo () = ()
diff --git a/testsuite/tests/warnings/should_compile/Werror01.stderr b/testsuite/tests/warnings/should_compile/Werror01.stderr
new file mode 100644
index 0000000000..91fcc8449f
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/Werror01.stderr
@@ -0,0 +1,2 @@
+Werror01.hs:5:1: warning: [-Wmissing-signatures (in -Wall)]
+    Top-level binding with no type signature: foo :: () -> ()
diff --git a/testsuite/tests/warnings/should_compile/Werror02.hs b/testsuite/tests/warnings/should_compile/Werror02.hs
new file mode 100644
index 0000000000..71458669a3
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/Werror02.hs
@@ -0,0 +1,5 @@
+{-# OPTIONS_GHC -Wmissing-signatures -Werror -Wwarn=missing-signatures #-}
+module Werror02 where
+
+-- this should generate missing-signatures warning
+foo () = ()
diff --git a/testsuite/tests/warnings/should_compile/Werror02.stderr b/testsuite/tests/warnings/should_compile/Werror02.stderr
new file mode 100644
index 0000000000..c33037caae
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/Werror02.stderr
@@ -0,0 +1,2 @@
+Werror02.hs:5:1: warning: [-Wmissing-signatures (in -Wall)]
+    Top-level binding with no type signature: foo :: () -> ()
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index ed128faaaa..bb347b065a 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -21,3 +21,6 @@ test('DeprU',
 		'DeprM.o',  'DeprU.o',
 		'DeprM.hi', 'DeprU.hi']),
 	multimod_compile, ['DeprU', '-Wall'])
+
+test('Werror01', normal, compile, [''])
+test('Werror02', normal, compile, [''])
diff --git a/testsuite/tests/warnings/should_compile/sel_werror.hs b/testsuite/tests/warnings/should_compile/sel_werror.hs
new file mode 100644
index 0000000000..65702539ad
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/sel_werror.hs
@@ -0,0 +1,3 @@
+{-# OPTIONS_GHC -Wwarn-missing-signatues -Werror=incomplete-patterns #-}
+
+foo () = ()
diff --git a/testsuite/tests/warnings/should_fail/WerrorFail.hs b/testsuite/tests/warnings/should_fail/WerrorFail.hs
new file mode 100644
index 0000000000..c8ffefeb12
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WerrorFail.hs
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -Wmissing-signatures -Werror=incomplete-patterns #-}
+module WerrorFail where
+
+-- this should generate incomplete-patterns warning
+foo :: Maybe a -> ()
+foo Nothing = ()
diff --git a/testsuite/tests/warnings/should_fail/WerrorFail.stderr b/testsuite/tests/warnings/should_fail/WerrorFail.stderr
new file mode 100644
index 0000000000..90c6c2db3a
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WerrorFail.stderr
@@ -0,0 +1,6 @@
+WerrorFail.hs:6:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘foo’: Patterns not matched: (Just _)
+
+<no location info>: 
+Failing due to -Werror.
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
new file mode 100644
index 0000000000..3522bb275f
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -0,0 +1 @@
+test('WerrorFail', normal, compile_fail, [''])
diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs
index eadb60016e..0f00b51ff4 100644
--- a/utils/mkUserGuidePart/Options/Warnings.hs
+++ b/utils/mkUserGuidePart/Options/Warnings.hs
@@ -31,11 +31,21 @@ warningsOptions =
          , flagType = DynamicFlag
          , flagReverse = "-Wwarn"
          }
+  , flag { flagName = "-Werror=<wflag>"
+         , flagDescription = "make a specific warning fatal"
+         , flagType = DynamicFlag
+         , flagReverse = "-Wwarn=<wflag>"
+         }
   , flag { flagName = "-Wwarn"
          , flagDescription = "make warnings non-fatal"
          , flagType = DynamicFlag
          , flagReverse = "-Werror"
          }
+  , flag { flagName = "-Wwarn=<wflag>"
+         , flagDescription = "make a specific warning non-fatal"
+         , flagType = DynamicFlag
+         , flagReverse = "-Werror=<wflag>"
+         }
   , flag { flagName = "-Wunrecognised-warning-flags"
          , flagDescription =
            "throw a warning when an unreconised ``-W...`` flag is "++