[Git][ghc/ghc][wip/amg/warning-refactoring] Refactor warning flag parsing to add missing flags
Adam Gundry (@adamgundry)
gitlab at gitlab.haskell.org
Wed Jan 11 07:45:29 UTC 2023
Adam Gundry pushed to branch wip/amg/warning-refactoring at Glasgow Haskell Compiler / GHC
Commits:
66c7c3aa by Adam Gundry at 2023-01-11T07:41:38+00:00
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 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Error.hs
- + testsuite/tests/warnings/should_fail/WarningGroups.hs
- + testsuite/tests/warnings/should_fail/WarningGroups.stderr
- testsuite/tests/warnings/should_fail/all.T
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -7,6 +7,9 @@ module GHC.Driver.Flags
, optimisationFlags
-- * Warnings
+ , WarningGroup(..)
+ , warningGroupName
+ , warningGroupFlags
, WarningFlag(..)
, warnFlagNames
, warningGroups
@@ -745,19 +748,37 @@ warnFlagNames wflag = case wflag of
--
-- docs/users_guide/using-warnings.rst
+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.
@@ -770,23 +791,22 @@ 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)
+ [minBound..maxBound]
-- | 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
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2651,50 +2651,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"
@@ -2910,11 +2866,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)
@@ -2937,26 +2888,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
@@ -2964,6 +2923,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)
@@ -3326,6 +3303,11 @@ wWarningFlagsDeps = mconcat [
warnSpec Opt_WarnTypeEqualityRequiresOperators
]
+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 = [
@@ -4039,12 +4021,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
@@ -4237,6 +4213,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)
=====================================
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:
=====================================
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 ()
=====================================
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’
=====================================
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,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66c7c3aa14a2d63806e0f2e1e76fbb390b0a0895
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66c7c3aa14a2d63806e0f2e1e76fbb390b0a0895
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230111/ea61f9c7/attachment-0001.html>
More information about the ghc-commits
mailing list