Commit d0a63ef8 authored by Adam Gundry's avatar Adam Gundry Committed by Marge Bot
Browse files

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.
parent b4c14c4b
......@@ -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
......
......@@ -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)
......
......@@ -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:
......
{-# OPTIONS_GHC -Wwarn=everything -fwarn-all -fno-warn-compat -Werror=unused-binds #-}
module WarningGroups () where
unused = let useless = () in ()
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’
......@@ -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,
......
Supports Markdown
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