Refactor warning flag parsing to add missing flags

This adds `-Werror=<group>` and `-fwarn-<group>` flags for warning
groups as well as individual warnings. Previously these were defined
on an ad hoc basis so for example we had `-Werror=compat` but not
`-Werror=unused-binds`, whereas we had `-fwarn-unused-binds` but not
`-fwarn-compat`. Fixes #22182.

6 files changed, 126 insertions, 92 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 634718ae7e..6e6f71cb0e 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -7,6 +7,9 @@ module GHC.Driver.Flags
    , optimisationFlags
 
    -- * Warnings
+   , WarningGroup(..)
+   , warningGroupName
+   , warningGroupFlags
    , WarningFlag(..)
    , warnFlagNames
    , warningGroups
@@ -747,19 +750,40 @@ warnFlagNames wflag = case wflag of
 --
 --  docs/users_guide/using-warnings.rst
 
+
+-- | A group of warning flags that can be enabled or disabled collectively,
+-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group.
+data WarningGroup = W_compat
+                  | W_unused_binds
+                  | W_default
+                  | W_extra
+                  | W_all
+                  | W_everything
+  deriving (Bounded, Enum, Eq)
+
+warningGroupName :: WarningGroup -> String
+warningGroupName W_compat            = "compat"
+warningGroupName W_unused_binds      = "unused-binds"
+warningGroupName W_default           = "default"
+warningGroupName W_extra             = "extra"
+warningGroupName W_all               = "all"
+warningGroupName W_everything        = "everything"
+
+warningGroupFlags :: WarningGroup -> [WarningFlag]
+warningGroupFlags W_compat            = minusWcompatOpts
+warningGroupFlags W_unused_binds      = unusedBindsFlags
+warningGroupFlags W_default           = standardWarnings
+warningGroupFlags W_extra             = minusWOpts
+warningGroupFlags W_all               = minusWallOpts
+warningGroupFlags W_everything        = minusWeverythingOpts
+
+
 -- | Warning groups.
 --
 -- As all warnings are in the Weverything set, it is ignored when
 -- displaying to the user which group a warning is in.
-warningGroups :: [(String, [WarningFlag])]
-warningGroups =
-    [ ("compat",       minusWcompatOpts)
-    , ("unused-binds", unusedBindsFlags)
-    , ("default",      standardWarnings)
-    , ("extra",        minusWOpts)
-    , ("all",          minusWallOpts)
-    , ("everything",   minusWeverythingOpts)
-    ]
+warningGroups :: [WarningGroup]
+warningGroups = [minBound..maxBound]
 
 -- | Warning group hierarchies, where there is an explicit inclusion
 -- relation.
@@ -772,23 +796,21 @@ warningGroups =
 -- hierarchies with no inherent relation to be defined.
 --
 -- The special-case Weverything group is not included.
-warningHierarchies :: [[String]]
+warningHierarchies :: [[WarningGroup]]
 warningHierarchies = hierarchies ++ map (:[]) rest
   where
-    hierarchies = [["default", "extra", "all"]]
-    rest = filter (`notElem` "everything" : concat hierarchies) $
-           map fst warningGroups
+    hierarchies = [[W_default, W_extra, W_all]]
+    rest = filter (`notElem` W_everything : concat hierarchies) warningGroups
 
 -- | Find the smallest group in every hierarchy which a warning
 -- belongs to, excluding Weverything.
-smallestWarningGroups :: WarningFlag -> [String]
+smallestWarningGroups :: WarningFlag -> [WarningGroup]
 smallestWarningGroups flag = mapMaybe go warningHierarchies where
     -- Because each hierarchy is arranged from smallest to largest,
     -- the first group we find in a hierarchy which contains the flag
     -- is the smallest.
     go (group:rest) = fromMaybe (go rest) $ do
-        flags <- lookup group warningGroups
-        guard (flag `elem` flags)
+        guard (flag `elem` warningGroupFlags group)
         pure (Just group)
     go [] = Nothing
 
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 57d89a15b1..8a37a9d197 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2652,50 +2652,6 @@ dynamic_flags_deps = [
   , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->
                                                          d { avx512pf = True }))
 
-     ------ Warning opts -------------------------------------------------
-  , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))
-  , 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 = EnumSet.empty})))
-                                             "Use -w or -Wno-everything instead"
-  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->
-                                              d {warningFlags = EnumSet.empty})))
-
-     -- New-style uniform warning sets
-     --
-     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything
-  , make_ord_flag defFlag "Weverything"    (NoArg (mapM_
-                                           setWarningFlag minusWeverythingOpts))
-  , make_ord_flag defFlag "Wno-everything"
-                           (NoArg (upd (\d -> d {warningFlags = EnumSet.empty})))
-
-  , make_ord_flag defFlag "Wall"           (NoArg (mapM_
-                                                  setWarningFlag minusWallOpts))
-  , make_ord_flag defFlag "Wno-all"        (NoArg (mapM_
-                                                unSetWarningFlag minusWallOpts))
-
-  , make_ord_flag defFlag "Wextra"         (NoArg (mapM_
-                                                     setWarningFlag minusWOpts))
-  , make_ord_flag defFlag "Wno-extra"      (NoArg (mapM_
-                                                   unSetWarningFlag minusWOpts))
-
-  , make_ord_flag defFlag "Wdefault"       (NoArg (mapM_
-                                               setWarningFlag standardWarnings))
-  , make_ord_flag defFlag "Wno-default"    (NoArg (mapM_
-                                             unSetWarningFlag standardWarnings))
-
-  , make_ord_flag defFlag "Wcompat"        (NoArg (mapM_
-                                               setWarningFlag minusWcompatOpts))
-  , make_ord_flag defFlag "Wno-compat"     (NoArg (mapM_
-                                             unSetWarningFlag minusWcompatOpts))
-
         ------ Plugin flags ------------------------------------------------
   , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)
   , make_ord_flag defGhcFlag "fplugin-trustworthy"
@@ -2911,11 +2867,6 @@ dynamic_flags_deps = [
       (NoArg enableGlasgowExts) "Use individual extensions instead"
   , make_dep_flag defFlag "fno-glasgow-exts"
       (NoArg disableGlasgowExts) "Use individual extensions instead"
-  , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds)
-  , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds)
-  , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds)
-  , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg
-                                                            disableUnusedBinds)
 
         ------ Safe Haskell flags -------------------------------------------
   , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)
@@ -2938,26 +2889,34 @@ dynamic_flags_deps = [
  ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps
  ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps
  ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps
- ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps
- ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps
- ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     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)
-    wWarningFlagsDeps
- ++ [ (NotDeprecated, unrecognisedWarning "W"),
-      (Deprecated,    unrecognisedWarning "fwarn-"),
-      (Deprecated,    unrecognisedWarning "fno-warn-") ]
- ++ [ make_ord_flag defFlag "Werror=compat"
-        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))
-    , make_ord_flag defFlag "Wno-error=compat"
-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))
-    , make_ord_flag defFlag "Wwarn=compat"
-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]
+ ++
+
+        ------ Warning flags -------------------------------------------------
+  [ make_ord_flag defFlag "W"       (NoArg (setWarningGroup W_extra))
+  , make_ord_flag defFlag "Werror"
+               (NoArg (do { setGeneralFlag Opt_WarnIsError
+                          ; setFatalWarningGroup W_everything }))
+  , make_ord_flag defFlag "Wwarn"
+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError
+                          ; unSetFatalWarningGroup W_everything }))
+                          -- Opt_WarnIsError is still needed to pass -Werror
+                          -- to CPP; see runCpp in SysTools
+  , make_dep_flag defFlag "Wnot"    (NoArg (unSetWarningGroup W_everything))
+                                             "Use -w or -Wno-everything instead"
+  , make_ord_flag defFlag "w"       (NoArg (unSetWarningGroup W_everything))
+  ]
+
+     -- New-style uniform warning sets
+     --
+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything
+ ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps
+ ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps
+
+ ++ [ (NotDeprecated, unrecognisedWarning "W")
+    , (Deprecated,    unrecognisedWarning "fwarn-")
+    , (Deprecated,    unrecognisedWarning "fno-warn-") ]
+
+     ------ Language flags -------------------------------------------------
  ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps
  ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps
  ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps
@@ -2965,6 +2924,24 @@ dynamic_flags_deps = [
  ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps
  ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps
 
+-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@,
+-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@).  We
+-- define these uniformly for individual warning flags and groups of warnings.
+warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning
+                -> (warn_flag -> DynP ()) -- ^ Unset the warning
+                -> (warn_flag -> DynP ()) -- ^ Make the warning an error
+                -> (warn_flag -> DynP ()) -- ^ Clear the error status
+                -> [(Deprecation, FlagSpec warn_flag)]
+                -> [(Deprecation, Flag (CmdLineP DynFlags))]
+warningControls set unset set_werror unset_fatal xs =
+    map (mkFlag turnOn  "W"          set             ) xs
+ ++ map (mkFlag turnOff "Wno-"       unset           ) xs
+ ++ map (mkFlag turnOn  "Werror="    set_werror      ) xs
+ ++ map (mkFlag turnOn  "Wwarn="     unset_fatal     ) xs
+ ++ map (mkFlag turnOn  "Wno-error=" unset_fatal     ) xs
+ ++ map (mkFlag turnOn  "fwarn-"     set   . hideFlag) xs
+ ++ map (mkFlag turnOff "fno-warn-"  unset . hideFlag) xs
+
 -- | This is where we handle unrecognised warning flags. We only issue a warning
 -- if -Wunrecognised-warning-flags is set. See #11429 for context.
 unrecognisedWarning :: String -> Flag (CmdLineP DynFlags)
@@ -3328,6 +3305,11 @@ wWarningFlagsDeps = mconcat [
   warnSpec    Opt_WarnTermVariableCapture
  ]
 
+warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
+warningGroupsDeps = map mk warningGroups
+  where
+    mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes)
+
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]
 negatableFlagsDeps = [
@@ -4045,12 +4027,6 @@ optLevelFlags -- see Note [Documenting optimisation flags]
     ]
 
 
-enableUnusedBinds :: DynP ()
-enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags
-
-disableUnusedBinds :: DynP ()
-disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags
-
 -- | Things you get with `-dlint`.
 enableDLint :: DynP ()
 enableDLint = do
@@ -4243,6 +4219,28 @@ unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps
    --     imply further flags.
 
 --------------------------
+setWarningGroup :: WarningGroup -> DynP ()
+setWarningGroup g =
+    mapM_ setWarningFlag (warningGroupFlags g)
+
+unSetWarningGroup :: WarningGroup -> DynP ()
+unSetWarningGroup g =
+    mapM_ unSetWarningFlag (warningGroupFlags g)
+
+setWErrorWarningGroup :: WarningGroup -> DynP ()
+setWErrorWarningGroup g =
+  do { setWarningGroup g
+     ; setFatalWarningGroup g }
+
+setFatalWarningGroup :: WarningGroup -> DynP ()
+setFatalWarningGroup g =
+    mapM_ setFatalWarningFlag (warningGroupFlags g)
+
+unSetFatalWarningGroup :: WarningGroup -> DynP ()
+unSetFatalWarningGroup g =
+    mapM_ unSetFatalWarningFlag (warningGroupFlags g)
+
+
 setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()
 setWarningFlag   f = upd (\dfs -> wopt_set dfs f)
 unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 695072e632..bc5e473dd8 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -527,7 +527,7 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
               | show_warn_groups =
                     case smallestWarningGroups flag of
                         [] -> empty
-                        groups -> text $ "(in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
+                        groups -> text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
               | otherwise = empty
 
           -- Add prefixes, like    Foo.hs:34: warning:
diff --git a/testsuite/tests/warnings/should_fail/WarningGroups.hs b/testsuite/tests/warnings/should_fail/WarningGroups.hs
new file mode 100644
index 0000000000..9581895ff7
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningGroups.hs
@@ -0,0 +1,4 @@
+{-# OPTIONS_GHC -Wwarn=everything -fwarn-all -fno-warn-compat -Werror=unused-binds #-}
+module WarningGroups () where
+
+unused = let useless = () in ()
diff --git a/testsuite/tests/warnings/should_fail/WarningGroups.stderr b/testsuite/tests/warnings/should_fail/WarningGroups.stderr
new file mode 100644
index 0000000000..8e9cedb07e
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningGroups.stderr
@@ -0,0 +1,9 @@
+
+WarningGroups.hs:4:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)]
+    Top-level binding with no type signature: unused :: ()
+
+WarningGroups.hs:4:1: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), Werror=unused-top-binds]
+    Defined but not used: ‘unused’
+
+WarningGroups.hs:4:14: error: [-Wunused-local-binds (in -Wextra, -Wunused-binds), Werror=unused-local-binds]
+    Defined but not used: ‘useless’
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
index 6eaf7af6fd..f016212ed9 100644
--- a/testsuite/tests/warnings/should_fail/all.T
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -10,6 +10,7 @@ def normalise_whitespace_carefully(s):
 
 test('WerrorFail', normal, compile_fail, [''])
 test('WerrorFail2', normal, compile_fail, [''])
+test('WarningGroups', normal, compile_fail, [''])
 test('CaretDiagnostics1',
      [normalise_whitespace_fun(normalise_whitespace_carefully)],
      compile_fail,