summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAdam Gundry <adam@well-typed.com>2023-01-10 21:03:48 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-03-24 02:36:09 -0400
commitf932c5890ec358aa0cbba547eb6982168e13da37 (patch)
tree62c27ed44eb43b7ed8f55af7ea0325cbcb3cfe14 /compiler
parente1c8c41d62854553d889403d8ee52d120c26bc66 (diff)
downloadhaskell-f932c5890ec358aa0cbba547eb6982168e13da37.tar.gz
Allow WARNING pragmas to be controlled with custom categories
Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Driver/Config/Diagnostic.hs2
-rw-r--r--compiler/GHC/Driver/Flags.hs29
-rw-r--r--compiler/GHC/Driver/Session.hs116
-rw-r--r--compiler/GHC/Hs/Decls.hs8
-rw-r--r--compiler/GHC/Parser.y18
-rw-r--r--compiler/GHC/Parser/HaddockLex.x10
-rw-r--r--compiler/GHC/Rename/Env.hs4
-rw-r--r--compiler/GHC/Rename/Module.hs7
-rw-r--r--compiler/GHC/Rename/Names.hs4
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs15
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs20
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs2
-rw-r--r--compiler/GHC/Types/Error.hs24
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
-rw-r--r--compiler/GHC/Unit/Module/Warnings.hs159
-rw-r--r--compiler/GHC/Utils/Error.hs28
16 files changed, 387 insertions, 60 deletions
diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs
index 3a590abc9f..f4b709301b 100644
--- a/compiler/GHC/Driver/Config/Diagnostic.hs
+++ b/compiler/GHC/Driver/Config/Diagnostic.hs
@@ -30,6 +30,8 @@ initDiagOpts :: DynFlags -> DiagOpts
initDiagOpts dflags = DiagOpts
{ diag_warning_flags = warningFlags dflags
, diag_fatal_warning_flags = fatalWarningFlags dflags
+ , diag_custom_warning_categories = customWarningCategories dflags
+ , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags
, diag_warn_is_error = gopt Opt_WarnIsError dflags
, diag_reverse_errors = reverseErrors dflags
, diag_max_errors = maxErrors dflags
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 756d75f630..df49034d13 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -10,11 +10,14 @@ module GHC.Driver.Flags
, WarningGroup(..)
, warningGroupName
, warningGroupFlags
+ , warningGroupIncludesExtendedWarnings
, WarningFlag(..)
, warnFlagNames
, warningGroups
, warningHierarchies
, smallestWarningGroups
+ , smallestWarningGroupsForCategory
+
, standardWarnings
, minusWOpts
, minusWallOpts
@@ -563,7 +566,6 @@ data WarningFlag =
| Opt_WarnUnusedRecordWildcards
| Opt_WarnRedundantBangPatterns
| Opt_WarnRedundantRecordWildcards
- | Opt_WarnWarningsDeprecations
| Opt_WarnDeprecatedFlags
| Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8
| Opt_WarnSemigroup -- since 8.0
@@ -649,7 +651,6 @@ warnFlagNames wflag = case wflag of
Opt_WarnUnbangedStrictPatterns -> "unbanged-strict-patterns" :| []
Opt_WarnDeferredTypeErrors -> "deferred-type-errors" :| []
Opt_WarnDeferredOutOfScopeVariables -> "deferred-out-of-scope-variables" :| []
- Opt_WarnWarningsDeprecations -> "deprecations" :| ["warnings-deprecations"]
Opt_WarnDeprecatedFlags -> "deprecated-flags" :| []
Opt_WarnDerivingDefaults -> "deriving-defaults" :| []
Opt_WarnDerivingTypeable -> "deriving-typeable" :| []
@@ -757,6 +758,7 @@ warnFlagNames wflag = case wflag of
-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group.
data WarningGroup = W_compat
| W_unused_binds
+ | W_extended_warnings
| W_default
| W_extra
| W_all
@@ -766,6 +768,7 @@ data WarningGroup = W_compat
warningGroupName :: WarningGroup -> String
warningGroupName W_compat = "compat"
warningGroupName W_unused_binds = "unused-binds"
+warningGroupName W_extended_warnings = "extended-warnings"
warningGroupName W_default = "default"
warningGroupName W_extra = "extra"
warningGroupName W_all = "all"
@@ -774,11 +777,26 @@ warningGroupName W_everything = "everything"
warningGroupFlags :: WarningGroup -> [WarningFlag]
warningGroupFlags W_compat = minusWcompatOpts
warningGroupFlags W_unused_binds = unusedBindsFlags
+warningGroupFlags W_extended_warnings = []
warningGroupFlags W_default = standardWarnings
warningGroupFlags W_extra = minusWOpts
warningGroupFlags W_all = minusWallOpts
warningGroupFlags W_everything = minusWeverythingOpts
+-- | Does this warning group contain (all) extended warning categories? See
+-- Note [Warning categories] in GHC.Unit.Module.Warnings.
+--
+-- The 'W_extended_warnings' group contains extended warnings but no
+-- 'WarningFlag's, but extended warnings are also treated as part of 'W_default'
+-- and every warning group that includes it.
+warningGroupIncludesExtendedWarnings :: WarningGroup -> Bool
+warningGroupIncludesExtendedWarnings W_compat = False
+warningGroupIncludesExtendedWarnings W_unused_binds = False
+warningGroupIncludesExtendedWarnings W_extended_warnings = True
+warningGroupIncludesExtendedWarnings W_default = True
+warningGroupIncludesExtendedWarnings W_extra = True
+warningGroupIncludesExtendedWarnings W_all = True
+warningGroupIncludesExtendedWarnings W_everything = True
-- | Warning groups.
--
@@ -816,11 +834,16 @@ smallestWarningGroups flag = mapMaybe go warningHierarchies where
pure (Just group)
go [] = Nothing
+-- | The smallest group in every hierarchy to which a custom warning
+-- category belongs is currently always @-Wextended-warnings@.
+-- See Note [Warning categories] in "GHC.Unit.Module.Warnings".
+smallestWarningGroupsForCategory :: [WarningGroup]
+smallestWarningGroupsForCategory = [W_extended_warnings]
+
-- | Warnings enabled unless specified otherwise
standardWarnings :: [WarningFlag]
standardWarnings -- see Note [Documenting warning flags]
= [ Opt_WarnOverlappingPatterns,
- Opt_WarnWarningsDeprecations,
Opt_WarnDeprecatedFlags,
Opt_WarnDeferredTypeErrors,
Opt_WarnTypedHoles,
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 20fcc3f6fe..46290d4ade 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -33,6 +33,11 @@ module GHC.Driver.Session (
gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',
wopt, wopt_set, wopt_unset,
wopt_fatal, wopt_set_fatal, wopt_unset_fatal,
+ wopt_set_all_custom, wopt_unset_all_custom,
+ wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,
+ wopt_set_custom, wopt_unset_custom,
+ wopt_set_fatal_custom, wopt_unset_fatal_custom,
+ wopt_any_custom,
xopt, xopt_set, xopt_unset,
xopt_set_unlessExplSpec,
xopt_DuplicateRecordFields,
@@ -227,6 +232,7 @@ import GHC.UniqueSubdir (uniqueSubdir)
import GHC.Unit.Types
import GHC.Unit.Parser
import GHC.Unit.Module
+import GHC.Unit.Module.Warnings
import GHC.Builtin.Names ( mAIN_NAME )
import GHC.Driver.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Flags
@@ -640,6 +646,8 @@ data DynFlags = DynFlags {
generalFlags :: EnumSet GeneralFlag,
warningFlags :: EnumSet WarningFlag,
fatalWarningFlags :: EnumSet WarningFlag,
+ customWarningCategories :: WarningCategorySet, -- See Note [Warning categories]
+ fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings
-- Don't change this without updating extensionFlags:
language :: Maybe Language,
-- | Safe Haskell mode
@@ -1242,6 +1250,8 @@ defaultDynFlags mySettings =
generalFlags = EnumSet.fromList (defaultFlags mySettings),
warningFlags = EnumSet.fromList standardWarnings,
fatalWarningFlags = EnumSet.empty,
+ customWarningCategories = completeWarningCategorySet,
+ fatalCustomWarningCategories = emptyWarningCategorySet,
ghciScripts = [],
language = Nothing,
safeHaskell = Sf_None,
@@ -1505,6 +1515,50 @@ wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
wopt_unset_fatal dfs f
= dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }
+
+-- | Enable all custom warning categories.
+wopt_set_all_custom :: DynFlags -> DynFlags
+wopt_set_all_custom dfs
+ = dfs{ customWarningCategories = completeWarningCategorySet }
+
+-- | Disable all custom warning categories.
+wopt_unset_all_custom :: DynFlags -> DynFlags
+wopt_unset_all_custom dfs
+ = dfs{ customWarningCategories = emptyWarningCategorySet }
+
+-- | Mark all custom warning categories as fatal (do not set the flags).
+wopt_set_all_fatal_custom :: DynFlags -> DynFlags
+wopt_set_all_fatal_custom dfs
+ = dfs { fatalCustomWarningCategories = completeWarningCategorySet }
+
+-- | Mark all custom warning categories as non-fatal.
+wopt_unset_all_fatal_custom :: DynFlags -> DynFlags
+wopt_unset_all_fatal_custom dfs
+ = dfs { fatalCustomWarningCategories = emptyWarningCategorySet }
+
+-- | Set a custom 'WarningCategory'
+wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags
+wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) }
+
+-- | Unset a custom 'WarningCategory'
+wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags
+wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) }
+
+-- | Mark a custom 'WarningCategory' as fatal (do not set the flag)
+wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags
+wopt_set_fatal_custom dfs f
+ = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) }
+
+-- | Mark a custom 'WarningCategory' as not fatal
+wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags
+wopt_unset_fatal_custom dfs f
+ = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) }
+
+-- | Are there any custom warning categories enabled?
+wopt_any_custom :: DynFlags -> Bool
+wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs))
+
+
-- | Test whether a 'LangExt.Extension' is set
xopt :: LangExt.Extension -> DynFlags -> Bool
xopt f dflags = f `EnumSet.member` extensionFlags dflags
@@ -2929,10 +2983,18 @@ dynamic_flags_deps = [
-- 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-") ]
+ ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag
+ [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)]
+ -- See Note [Warning categories] in GHC.Unit.Module.Warnings.
+
+ ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-" unSetCustomWarningFlag)
+ , (NotDeprecated, customOrUnrecognisedWarning "Werror=" setCustomWErrorFlag)
+ , (NotDeprecated, customOrUnrecognisedWarning "Wwarn=" unSetCustomFatalWarningFlag)
+ , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag)
+ , (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag)
+ , (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag)
+ , (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag)
+ ]
------ Language flags -------------------------------------------------
++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps
@@ -2960,13 +3022,21 @@ warningControls set unset set_werror 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)
-unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)
+-- | This is where we handle unrecognised warning flags. If the flag is valid as
+-- an extended warning category, we call the supplied action. Otherwise, issue a
+-- warning if -Wunrecognised-warning-flags is set. See #11429 for context.
+-- See Note [Warning categories] in GHC.Unit.Module.Warnings.
+customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags)
+customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action)
where
action :: String -> EwM (CmdLineP DynFlags) ()
- action flag = do
+ action flag
+ | validWarningCategory cat = custom cat
+ | otherwise = unrecognised flag
+ where
+ cat = mkWarningCategory (mkFastString flag)
+
+ unrecognised flag = do
f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState
when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $
"unrecognised warning flag: -" ++ prefix ++ flag
@@ -3217,7 +3287,6 @@ wWarningFlagsDeps = mconcat [
warnSpec Opt_WarnUnbangedStrictPatterns,
warnSpec Opt_WarnDeferredTypeErrors,
warnSpec Opt_WarnDeferredOutOfScopeVariables,
- warnSpec Opt_WarnWarningsDeprecations,
warnSpec Opt_WarnDeprecatedFlags,
warnSpec Opt_WarnDerivingDefaults,
warnSpec Opt_WarnDerivingTypeable,
@@ -4238,12 +4307,14 @@ unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps
--------------------------
setWarningGroup :: WarningGroup -> DynP ()
-setWarningGroup g =
+setWarningGroup g = do
mapM_ setWarningFlag (warningGroupFlags g)
+ when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom
unSetWarningGroup :: WarningGroup -> DynP ()
-unSetWarningGroup g =
+unSetWarningGroup g = do
mapM_ unSetWarningFlag (warningGroupFlags g)
+ when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom
setWErrorWarningGroup :: WarningGroup -> DynP ()
setWErrorWarningGroup g =
@@ -4251,12 +4322,14 @@ setWErrorWarningGroup g =
; setFatalWarningGroup g }
setFatalWarningGroup :: WarningGroup -> DynP ()
-setFatalWarningGroup g =
+setFatalWarningGroup g = do
mapM_ setFatalWarningFlag (warningGroupFlags g)
+ when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom
unSetFatalWarningGroup :: WarningGroup -> DynP ()
-unSetFatalWarningGroup g =
+unSetFatalWarningGroup g = do
mapM_ unSetFatalWarningFlag (warningGroupFlags g)
+ when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom
setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()
@@ -4272,6 +4345,21 @@ setWErrorFlag flag =
do { setWarningFlag flag
; setFatalWarningFlag flag }
+
+setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP ()
+setCustomWarningFlag f = upd (\dfs -> wopt_set_custom dfs f)
+unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f)
+
+setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP ()
+setCustomFatalWarningFlag f = upd (\dfs -> wopt_set_fatal_custom dfs f)
+unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f)
+
+setCustomWErrorFlag :: WarningCategory -> DynP ()
+setCustomWErrorFlag flag =
+ do { setCustomWarningFlag flag
+ ; setCustomFatalWarningFlag flag }
+
+
--------------------------
setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()
setExtensionFlag f = upd (setExtensionFlag' f)
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 8e48036673..fa62c6a49c 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -126,6 +126,7 @@ import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour))
import GHC.Types.ForeignCall
+import GHC.Unit.Module.Warnings (WarningTxt(..))
import GHC.Data.Bag
import GHC.Data.Maybe
@@ -1229,8 +1230,13 @@ instance OutputableBndrId p
instance OutputableBndrId p
=> Outputable (WarnDecl (GhcPass p)) where
ppr (Warning _ thing txt)
- = hsep ( punctuate comma (map ppr thing))
+ = ppr_category
+ <+> hsep (punctuate comma (map ppr thing))
<+> ppr txt
+ where
+ ppr_category = case txt of
+ WarningTxt (Just cat) _ _ -> text "[" <> ppr (unLoc cat) <> text "]"
+ _ -> empty
{-
************************************************************************
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index ac9976815f..bbbc12df56 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -920,9 +920,9 @@ maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }
: '{-# DEPRECATED' strings '#-}'
{% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
(AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
- | '{-# WARNING' strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}
+ | '{-# WARNING' warning_category strings '#-}'
+ {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
+ (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
| {- empty -} { Nothing }
body :: { (AnnList
@@ -1941,6 +1941,10 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
+warning_category :: { Maybe (Located WarningCategory) }
+ : 'in' STRING { Just (sL1 $2 (mkWarningCategory (getSTRING $2))) }
+ | {- empty -} { Nothing }
+
warnings :: { OrdList (LWarnDecl GhcPs) }
: warnings ';' warning {% if isNilOL $1
then return ($1 `appOL` $3)
@@ -1959,10 +1963,10 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
- : namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $1 $>
- (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
- (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }
+ : warning_category namelist strings
+ {% fmap unitOL $ acsA (\cs -> sLL $2 $>
+ (Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
+ (WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
: deprecations ';' deprecation
diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x
index 682ede39a4..52e67894b5 100644
--- a/compiler/GHC/Parser/HaddockLex.x
+++ b/compiler/GHC/Parser/HaddockLex.x
@@ -16,7 +16,6 @@ import GHC.Types.SourceText
import GHC.Data.StringBuffer
import qualified GHC.Data.Strict as Strict
import GHC.Types.Name.Reader
-import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Encoding
import GHC.Hs.Extension
@@ -180,14 +179,7 @@ validateIdentWith identParser mloc str0 =
dopts
[]
False False False False
- dopts = DiagOpts
- { diag_warning_flags = EnumSet.empty
- , diag_fatal_warning_flags = EnumSet.empty
- , diag_warn_is_error = False
- , diag_reverse_errors = False
- , diag_max_errors = Nothing
- , diag_ppr_ctx = defaultSDocContext
- }
+ dopts = emptyDiagOpts
buffer = stringBufferFromByteString str0
realSrcLc = case mloc of
RealSrcSpan loc _ -> realSrcSpanStart loc
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 830e1a0dcc..a4e1ef0a77 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -77,7 +77,7 @@ import GHC.Types.Hint
import GHC.Types.Error
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Warnings ( WarningTxt )
+import GHC.Unit.Module.Warnings ( WarningTxt(..) )
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon
@@ -1597,7 +1597,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss })
| Just imp_spec <- headMaybe iss
= do { dflags <- getDynFlags
; this_mod <- getModule
- ; when (wopt Opt_WarnWarningsDeprecations dflags &&
+ ; when (wopt_any_custom dflags &&
not (nameIsLocalOrFrom this_mod name)) $
-- See Note [Handling of deprecations]
do { iface <- loadInterfaceForName doc name
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 516966044c..7b2b418d87 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -295,9 +295,12 @@ rnSrcWarnDecls bndr_set decls'
$ concatMap (\(L _ (Warning _ ns _)) -> ns) decls
rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
-rnWarningTxt (WarningTxt st wst) = do
+rnWarningTxt (WarningTxt mb_cat st wst) = do
+ forM_ mb_cat $ \(L loc cat) ->
+ unless (validWarningCategory cat) $
+ addErrAt loc (TcRnInvalidWarningCategory cat)
wst' <- traverse (traverse rnHsDoc) wst
- pure (WarningTxt st wst')
+ pure (WarningTxt mb_cat st wst')
rnWarningTxt (DeprecatedTxt st wst) = do
wst' <- traverse (traverse rnHsDoc) wst
pure (DeprecatedTxt st wst')
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 65bb2c92d2..25b1c6e8af 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -431,7 +431,7 @@ rnImportDecl this_mod
case mi_warns iface of
WarnAll txt -> do
let msg = mkTcRnUnknownMessage $
- mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
+ mkPlainDiagnostic (WarningWithCategory (warningTxtCategory txt))
noHints
(moduleWarn imp_mod_name txt)
addDiagnostic msg
@@ -2213,7 +2213,7 @@ missingImportListWarn mod
= text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list"
moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc
-moduleWarn mod (WarningTxt _ txt)
+moduleWarn mod (WarningTxt _ _ txt)
= sep [ text "Module" <+> quotes (ppr mod) <> colon,
nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ]
moduleWarn mod (DeprecatedTxt _ txt)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 519c03991f..8b4896c5cc 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -78,7 +78,7 @@ import GHC.Types.Fixity (defaultFixity)
import GHC.Unit.State (pprWithUnitState, UnitState)
import GHC.Unit.Module
-import GHC.Unit.Module.Warnings ( pprWarningTxtForMsg )
+import GHC.Unit.Module.Warnings ( warningTxtCategory, pprWarningTxtForMsg )
import GHC.Data.Bag
import GHC.Data.FastString
@@ -178,6 +178,11 @@ instance Diagnostic TcRnMessage where
sep [text "This binding for" <+> quotes (ppr occ)
<+> text "shadows the existing binding" <> plural shadowed_locs,
nest 2 (vcat shadowed_locs)]
+ TcRnInvalidWarningCategory cat
+ -> mkSimpleDecorated $
+ vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid",
+ text "(user-defined category names must begin with" <+> quotes (text "x-"),
+ text "and contain only letters, numbers, apostrophes and dashes)" ]
TcRnDuplicateWarningDecls d rdr_name
-> mkSimpleDecorated $
vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
@@ -1544,6 +1549,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnShadowedName{}
-> WarningWithFlag Opt_WarnNameShadowing
+ TcRnInvalidWarningCategory{}
+ -> ErrorWithoutFlag
TcRnDuplicateWarningDecls{}
-> ErrorWithoutFlag
TcRnSimplifierTooManyIterations{}
@@ -1825,8 +1832,8 @@ instance Diagnostic TcRnMessage where
-> WarningWithoutFlag
TcRnSpecialiseNotVisible{}
-> WarningWithoutFlag
- TcRnPragmaWarning{}
- -> WarningWithFlag Opt_WarnWarningsDeprecations
+ TcRnPragmaWarning{pragma_warning_msg}
+ -> WarningWithCategory (warningTxtCategory pragma_warning_msg)
TcRnIllegalHsigDefaultMethods{}
-> ErrorWithoutFlag
TcRnHsigFixityMismatch{}
@@ -2036,6 +2043,8 @@ instance Diagnostic TcRnMessage where
-> [SuggestAddToHSigExportList name Nothing]
TcRnShadowedName{}
-> noHints
+ TcRnInvalidWarningCategory{}
+ -> noHints
TcRnDuplicateWarningDecls{}
-> noHints
TcRnSimplifierTooManyIterations{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 8c3505221d..6b8d570c05 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -146,7 +146,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.List.NonEmpty as NE
import Data.Typeable (Typeable)
-import GHC.Unit.Module.Warnings (WarningTxt)
+import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt)
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Generics ( Generic )
@@ -411,6 +411,22 @@ data TcRnMessage where
-}
TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage
+ {-| TcRnInvalidWarningCategory is an error that occurs when a warning is declared
+ with a category name that is not the special category "deprecations", and
+ either does not begin with the prefix "x-" indicating a user-defined
+ category, or contains characters not valid in category names. See Note
+ [Warning categories] in GHC.Unit.Module.Warnings
+
+ Examples(s):
+ module M {-# WARNING in "invalid" "Oops" #-} where
+
+ {-# WARNING in "x- spaces not allowed" foo "Oops" #-}
+
+ Test cases: warnings/should_fail/WarningCategoryInvalid
+ -}
+ TcRnInvalidWarningCategory :: !WarningCategory -> TcRnMessage
+
+
{-| TcRnDuplicateWarningDecls is an error that occurs whenever
a warning is declared twice.
@@ -422,7 +438,7 @@ data TcRnMessage where
-}
TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage
- {-| TcRnDuplicateWarningDecls is an error that occurs whenever
+ {-| TcRnSimplifierTooManyIterations is an error that occurs whenever
the constraint solver in the simplifier hits the iterations' limit.
Examples(s):
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index d42ee046b5..dbe9fd828c 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -164,7 +164,7 @@ rnExports :: Bool -- False => no 'module M(..) where' header at all
rnExports explicit_mod exports
= checkNoErrs $ -- Fail if anything in rnExports finds
-- an error fails, to avoid error cascade
- unsetWOptM Opt_WarnWarningsDeprecations $
+ updTopFlags wopt_unset_all_custom $
-- Do not report deprecations arising from the export
-- list, to avoid bleating about re-exporting a deprecated
-- thing (especially via 'module Foo' export item)
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index bc5e473dd8..0eccf085bb 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -91,6 +91,7 @@ import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import GHC.Utils.Panic
+import GHC.Unit.Module.Warnings (WarningCategory)
import Data.Bifunctor
import Data.Foldable ( fold )
@@ -330,6 +331,8 @@ data DiagnosticReason
-- ^ Born as a warning.
| WarningWithFlag !WarningFlag
-- ^ Warning was enabled with the flag.
+ | WarningWithCategory !WarningCategory
+ -- ^ Warning was enabled with a custom category.
| ErrorWithoutFlag
-- ^ Born as an error.
deriving (Eq, Show)
@@ -338,6 +341,7 @@ instance Outputable DiagnosticReason where
ppr = \case
WarningWithoutFlag -> text "WarningWithoutFlag"
WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf)
+ WarningWithCategory cat -> text "WarningWithCategory" <+> ppr cat
ErrorWithoutFlag -> text "ErrorWithoutFlag"
-- | An envelope for GHC's facts about a running program, parameterised over the
@@ -510,24 +514,30 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
flag_msg SevError WarningWithoutFlag = Just (col "-Werror")
flag_msg SevError (WarningWithFlag wflag) =
let name = NE.head (warnFlagNames wflag) in
- Just $ col ("-W" ++ name) <+> warn_flag_grp wflag
+ Just $ col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag)
<> comma
<+> col ("Werror=" ++ name)
+ flag_msg SevError (WarningWithCategory cat) =
+ Just $ coloured msg_colour (text "-W" <> ppr cat)
+ <+> warn_flag_grp smallestWarningGroupsForCategory
+ <> comma
+ <+> coloured msg_colour (text "-Werror=" <> ppr cat)
flag_msg SevError ErrorWithoutFlag = Nothing
flag_msg SevWarning WarningWithoutFlag = Nothing
flag_msg SevWarning (WarningWithFlag wflag) =
let name = NE.head (warnFlagNames wflag) in
- Just (col ("-W" ++ name) <+> warn_flag_grp wflag)
+ Just (col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag))
+ flag_msg SevWarning (WarningWithCategory cat) =
+ Just (coloured msg_colour (text "-W" <> ppr cat)
+ <+> warn_flag_grp smallestWarningGroupsForCategory)
flag_msg SevWarning ErrorWithoutFlag =
pprPanic "SevWarning with ErrorWithoutFlag" $
vcat [ text "locn:" <+> ppr locn
, text "msg:" <+> ppr msg ]
- warn_flag_grp flag
- | show_warn_groups =
- case smallestWarningGroups flag of
- [] -> empty
- groups -> text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
+ warn_flag_grp groups
+ | show_warn_groups, not (null groups)
+ = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
| otherwise = empty
-- Add prefixes, like Foo.hs:34: warning:
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index ce26d95a72..3508a218d2 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -337,6 +337,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188
GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058
GhcDiagnosticCode "TcRnShadowedName" = 63397
+ GhcDiagnosticCode "TcRnInvalidWarningCategory" = 53573
GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711
GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822
GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 75f3950208..72f6586094 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -2,13 +2,28 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | Warnings for a module
module GHC.Unit.Module.Warnings
- ( Warnings (..)
+ ( WarningCategory
+ , mkWarningCategory
+ , defaultWarningCategory
+ , validWarningCategory
+
+ , WarningCategorySet
+ , emptyWarningCategorySet
+ , completeWarningCategorySet
+ , nullWarningCategorySet
+ , elemWarningCategorySet
+ , insertWarningCategorySet
+ , deleteWarningCategorySet
+
+ , Warnings (..)
, WarningTxt (..)
+ , warningTxtCategory
, pprWarningTxtForMsg
, mkIfaceWarnCache
, emptyIfaceWarnCache
@@ -18,25 +33,149 @@ where
import GHC.Prelude
+import GHC.Data.FastString (FastString, mkFastString, unpackFS)
import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
import GHC.Types.SrcLoc
+import GHC.Types.Unique
+import GHC.Types.Unique.Set
import GHC.Hs.Doc
import GHC.Hs.Extension
import GHC.Utils.Outputable
import GHC.Utils.Binary
+import GHC.Unicode
import Language.Haskell.Syntax.Extension
import Data.Data
+import Data.List (isPrefixOf)
import GHC.Generics ( Generic )
+
+{-
+Note [Warning categories]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+See GHC Proposal 541 for the design of the warning categories feature:
+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst
+
+A WARNING pragma may be annotated with a category such as "x-partial" written
+after the 'in' keyword, like this:
+
+ {-# WARNING in "x-partial" head "This function is partial..." #-}
+
+This is represented by the 'Maybe (Located WarningCategory)' field in
+'WarningTxt'. The parser will accept an arbitrary string as the category name,
+then the renamer (in 'rnWarningTxt') will check it contains only valid
+characters, so we can generate a nicer error message than a parse error.
+
+The corresponding warnings can then be controlled with the -Wx-partial,
+-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is
+distinguished from an 'unrecognisedWarning' by the flag parser testing
+'validWarningCategory'. The 'x-' prefix means we can still usually report an
+unrecognised warning where the user has made a mistake.
+
+A DEPRECATED pragma may not have a user-defined category, and is always treated
+as belonging to the special category 'deprecations'. Similarly, a WARNING
+pragma without a category belongs to the 'deprecations' category.
+Thus the '-Wdeprecations' flag will enable all of the following:
+
+ {-# WARNING in "deprecations" foo "This function is deprecated..." #-}
+ {-# WARNING foo "This function is deprecated..." #-}
+ {-# DEPRECATED foo "This function is deprecated..." #-}
+
+The '-Wwarnings-deprecations' flag is supported for backwards compatibility
+purposes as being equivalent to '-Wdeprecations'.
+
+The '-Wextended-warnings' warning group collects together all warnings with
+user-defined categories, so they can be enabled or disabled
+collectively. Moreover they are treated as being part of other warning groups
+such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings').
+
+'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal
+warning categories, just as they do for the finite enumeration of 'WarningFlag's
+built in to GHC. These are represented as 'WarningCategorySet's to allow for
+the possibility of them being infinite.
+
+-}
+
+
+
+-- See Note [Warning categories]
+newtype WarningCategory = WarningCategory FastString
+ deriving (Binary, Data, Eq, Outputable, Show, Uniquable)
+
+mkWarningCategory :: FastString -> WarningCategory
+mkWarningCategory = WarningCategory
+
+-- | The @deprecations@ category is used for all DEPRECATED pragmas and for
+-- WARNING pragmas that do not specify a category.
+defaultWarningCategory :: WarningCategory
+defaultWarningCategory = mkWarningCategory (mkFastString "deprecations")
+
+-- | Is this warning category allowed to appear in user-defined WARNING pragmas?
+-- It must either be the known category @deprecations@, or be a custom category
+-- that begins with @x-@ and contains only valid characters (letters, numbers,
+-- apostrophes and dashes).
+validWarningCategory :: WarningCategory -> Bool
+validWarningCategory cat@(WarningCategory c) =
+ cat == defaultWarningCategory || ("x-" `isPrefixOf` s && all is_allowed s)
+ where
+ s = unpackFS c
+ is_allowed c = isAlphaNum c || c == '\'' || c == '-'
+
+
+-- | A finite or infinite set of warning categories.
+--
+-- Unlike 'WarningFlag', there are (in principle) infinitely many warning
+-- categories, so we cannot necessarily enumerate all of them. However the set
+-- is constructed by adding or removing categories one at a time, so we can
+-- represent it as either a finite set of categories, or a cofinite set (where
+-- we store the complement).
+data WarningCategorySet =
+ FiniteWarningCategorySet (UniqSet WarningCategory)
+ -- ^ The set of warning categories is the given finite set.
+ | CofiniteWarningCategorySet (UniqSet WarningCategory)
+ -- ^ The set of warning categories is infinite, so the constructor stores
+ -- its (finite) complement.
+
+-- | The empty set of warning categories.
+emptyWarningCategorySet :: WarningCategorySet
+emptyWarningCategorySet = FiniteWarningCategorySet emptyUniqSet
+
+-- | The set consisting of all possible warning categories.
+completeWarningCategorySet :: WarningCategorySet
+completeWarningCategorySet = CofiniteWarningCategorySet emptyUniqSet
+
+-- | Is this set empty?
+nullWarningCategorySet :: WarningCategorySet -> Bool
+nullWarningCategorySet (FiniteWarningCategorySet s) = isEmptyUniqSet s
+nullWarningCategorySet CofiniteWarningCategorySet{} = False
+
+-- | Does this warning category belong to the set?
+elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool
+elemWarningCategorySet c (FiniteWarningCategorySet s) = c `elementOfUniqSet` s
+elemWarningCategorySet c (CofiniteWarningCategorySet s) = not (c `elementOfUniqSet` s)
+
+-- | Insert an element into a warning category set.
+insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
+insertWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (addOneToUniqSet s c)
+insertWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (delOneFromUniqSet s c)
+
+-- | Delete an element from a warning category set.
+deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet
+deleteWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (delOneFromUniqSet s c)
+deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet s c)
+
+
-- | Warning Text
--
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
= WarningTxt
+ (Maybe (Located WarningCategory))
+ -- ^ Warning category attached to this WARNING pragma, if any;
+ -- see Note [Warning categories]
(Located SourceText)
[Located (WithHsDocIdentifiers StringLiteral pass)]
| DeprecatedTxt
@@ -44,11 +183,17 @@ data WarningTxt pass
[Located (WithHsDocIdentifiers StringLiteral pass)]
deriving Generic
+-- | To which warning category does this WARNING or DEPRECATED pragma belong?
+-- See Note [Warning categories].
+warningTxtCategory :: WarningTxt pass -> WarningCategory
+warningTxtCategory (WarningTxt (Just (L _ cat)) _ _) = cat
+warningTxtCategory _ = defaultWarningCategory
+
deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
instance Outputable (WarningTxt pass) where
- ppr (WarningTxt lsrc ws)
+ ppr (WarningTxt _ lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
SourceText src -> text src <+> pp_ws ws <+> text "#-}"
@@ -59,8 +204,9 @@ instance Outputable (WarningTxt pass) where
SourceText src -> text src <+> pp_ws ds <+> text "#-}"
instance Binary (WarningTxt GhcRn) where
- put_ bh (WarningTxt s w) = do
+ put_ bh (WarningTxt c s w) = do
putByte bh 0
+ put_ bh $ unLoc <$> c
put_ bh $ unLoc s
put_ bh $ unLoc <$> w
put_ bh (DeprecatedTxt s d) = do
@@ -71,9 +217,10 @@ instance Binary (WarningTxt GhcRn) where
get bh = do
h <- getByte bh
case h of
- 0 -> do s <- noLoc <$> get bh
+ 0 -> do c <- fmap noLoc <$> get bh
+ s <- noLoc <$> get bh
w <- fmap noLoc <$> get bh
- return (WarningTxt s w)
+ return (WarningTxt c s w)
_ -> do s <- noLoc <$> get bh
d <- fmap noLoc <$> get bh
return (DeprecatedTxt s d)
@@ -88,7 +235,7 @@ pp_ws ws
pprWarningTxtForMsg :: WarningTxt p -> SDoc
-pprWarningTxtForMsg (WarningTxt _ ws)
+pprWarningTxtForMsg (WarningTxt _ _ ws)
= doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws))
pprWarningTxtForMsg (DeprecatedTxt _ ds)
= text "Deprecated:" <+>
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 8910dd4d38..8ea61c6f39 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -32,7 +32,7 @@ module GHC.Utils.Error (
formatBulleted,
-- ** Construction
- DiagOpts (..), diag_wopt, diag_fatal_wopt,
+ DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,
emptyMessages, mkDecorated, mkLocMessage,
mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
mkErrorMsgEnvelope,
@@ -79,6 +79,7 @@ import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc
+import GHC.Unit.Module.Warnings
import System.Exit ( ExitCode(..), exitWith )
import Data.List ( sortBy )
@@ -93,18 +94,39 @@ import System.CPUTime
data DiagOpts = DiagOpts
{ diag_warning_flags :: !(EnumSet WarningFlag) -- ^ Enabled warnings
, diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings
+ , diag_custom_warning_categories :: !WarningCategorySet -- ^ Enabled custom warning categories
+ , diag_fatal_custom_warning_categories :: !WarningCategorySet -- ^ Fatal custom warning categories
, diag_warn_is_error :: !Bool -- ^ Treat warnings as errors
, diag_reverse_errors :: !Bool -- ^ Reverse error reporting order
, diag_max_errors :: !(Maybe Int) -- ^ Max reported error count
, diag_ppr_ctx :: !SDocContext -- ^ Error printing context
}
+emptyDiagOpts :: DiagOpts
+emptyDiagOpts =
+ DiagOpts
+ { diag_warning_flags = EnumSet.empty
+ , diag_fatal_warning_flags = EnumSet.empty
+ , diag_custom_warning_categories = emptyWarningCategorySet
+ , diag_fatal_custom_warning_categories = emptyWarningCategorySet
+ , diag_warn_is_error = False
+ , diag_reverse_errors = False
+ , diag_max_errors = Nothing
+ , diag_ppr_ctx = defaultSDocContext
+ }
+
diag_wopt :: WarningFlag -> DiagOpts -> Bool
diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts
diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts
+diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool
+diag_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_custom_warning_categories opts
+
+diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool
+diag_fatal_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_fatal_custom_warning_categories opts
+
-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
-- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed,
-- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a
@@ -116,6 +138,10 @@ diagReasonSeverity opts reason = case reason of
| not (diag_wopt wflag opts) -> SevIgnore
| diag_fatal_wopt wflag opts -> SevError
| otherwise -> SevWarning
+ WarningWithCategory wcat
+ | not (diag_wopt_custom wcat opts) -> SevIgnore
+ | diag_fatal_wopt_custom wcat opts -> SevError
+ | otherwise -> SevWarning
WarningWithoutFlag
| diag_warn_is_error opts -> SevError
| otherwise -> SevWarning