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.

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