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.

39 files changed, 649 insertions, 94 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
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index 8d8e451e9b..e0eedfe0e7 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -35,6 +35,12 @@ Compiler
 - Fix a bug in TH causing excessive calls to ``setNumCapabilities`` when ``-j`` is greater than ``-N``.
   See GHC ticket #23049.
 
+- ``WARNING`` pragmas may now be annotated with a category, following
+  `GHC proposal #541 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst>`_, in which case they are controlled with new
+  ``-Wx-⟨category⟩`` flags rather than :ghc-flag:`-Wdeprecations`.
+  A new warning group :ghc-flag:`-Wextended-warnings` includes all such warnings
+  regardless of category.  See :ref:`warning-deprecated-pragma`.
+
 
 GHCi
 ~~~~
diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst
index 0197a2fa1a..2c8c5d4759 100644
--- a/docs/users_guide/exts/pragmas.rst
+++ b/docs/users_guide/exts/pragmas.rst
@@ -98,17 +98,17 @@ other compilers.
 
 .. pragma:: WARNING
 
-    :where: declaration
+    :where: declaration or module name
 
     The ``WARNING`` pragma allows you to attach an arbitrary warning to a
-    particular function, class, or type.
+    particular function, class, type, or module.
 
 .. pragma:: DEPRECATED
 
-    :where: declaration
+    :where: declaration or module name
 
     A ``DEPRECATED`` pragma lets you specify that a particular function, class,
-    or type is deprecated.
+    type, or module is deprecated.
 
 There are two ways of using these pragmas.
 
@@ -153,8 +153,23 @@ in an export list. The latter reduces spurious complaints within a
 library in which one module gathers together and re-exports the exports
 of several others.
 
-You can suppress the warnings with the flag
-:ghc-flag:`-Wno-warnings-deprecations <-Wwarnings-deprecations>`.
+A ``WARNING`` pragma (but not a ``DEPRECATED`` pragma) may optionally specify a
+*warning category* as a string literal following the ``in`` keyword.  This affects the flag used to suppress
+the warning.  The examples above do not specify a category, so the default
+category ``deprecations`` applies, and they can be suppressed with the flag
+:ghc-flag:`-Wno-deprecations <-Wdeprecations>` (and its synonym
+:ghc-flag:`-Wno-warnings-deprecations <-Wwarnings-deprecations>`).
+
+If a category is specified, the warning can instead be suppressed with the flag
+``-Wno-x-⟨category⟩``, for example warnings from the following pragma can be
+suppressed with ``-Wno-x-partial``::
+
+    {-# WARNING in "x-partial" head "This function is partial..." #-}
+
+Alternatively, warnings from all ``WARNING`` and ``DEPRECATED`` pragmas
+regardless of category can be suppressed with
+:ghc-flag:`-Wno-extended-warnings <-Wextended-warnings>`).
+
 
 .. _minimal-pragma:
 
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 3624a63384..c7470f7d48 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -488,27 +488,47 @@ of ``-W(no-)*``.
 
     Alias for :ghc-flag:`-Wall-missed-specialisations`
 
-.. ghc-flag:: -Wwarnings-deprecations
-    :shortdesc: warn about uses of functions & types that have warnings or
-        deprecated pragmas
+.. ghc-flag:: -Wextended-warnings
+    :shortdesc: warn about uses of functions & types that have WARNING or
+        DEPRECATED pragmas, across all categories
     :type: dynamic
-    :reverse: -Wno-warnings-deprecations
+    :reverse: -Wno-extended-warnings
     :category:
 
-    :since: 6.10
+    :since: 9.8.1
 
     :default: on
 
     .. index::
        pair: deprecations; warnings
 
-    Causes a warning to be emitted when a module, function or type with
-    a ``WARNING`` or ``DEPRECATED pragma`` is used. See
+    Causes a warning to be emitted when a module, function or type with a
+    ``WARNING`` or ``DEPRECATED`` pragma is used, regardless of the category
+    which may be associated with the pragma. See
+    :ref:`warning-deprecated-pragma` for more details on the pragmas.  This
+    implies :ghc-flag:`-Wdeprecations` and all ``-Wx-⟨category⟩`` flags.
+
+.. ghc-flag:: -Wx-⟨category⟩
+    :shortdesc: warn about uses of functions & types that have WARNING pragmas
+        with the given category
+    :type: dynamic
+    :reverse: -Wno-x-⟨category⟩
+    :category:
+
+    :since: 9.8.1
+
+    :default: on
+
+    .. index::
+       pair: deprecations; warnings
+
+    Causes a warning to be emitted when a module, function or type with a
+    ``WARNING in "x-⟨category⟩"`` pragma is used. See
     :ref:`warning-deprecated-pragma` for more details on the pragmas.
 
 .. ghc-flag:: -Wdeprecations
-    :shortdesc: warn about uses of functions & types that have warnings or
-        deprecated pragmas. Alias for :ghc-flag:`-Wwarnings-deprecations`
+    :shortdesc: warn about uses of functions & types that have DEPRECATED pragmas,
+        or WARNING pragmas with the ``deprecated`` category.
     :type: dynamic
     :reverse: -Wno-deprecations
     :category:
@@ -516,12 +536,32 @@ of ``-W(no-)*``.
     :default: on
 
     .. index::
-       single: deprecations
+       pair: deprecations; warnings
 
     Causes a warning to be emitted when a module, function or type with
-    a ``WARNING`` or ``DEPRECATED pragma`` is used. See
-    :ref:`warning-deprecated-pragma` for more details on the pragmas.
-    An alias for :ghc-flag:`-Wwarnings-deprecations`.
+    ``DEPRECATED pragma``, or a ``WARNING`` pragma with the ``deprecated``
+    category, is used. See :ref:`warning-deprecated-pragma` for more details on
+    the pragmas.
+
+.. ghc-flag:: -Wwarnings-deprecations
+    :shortdesc: warn about uses of functions & types that have DEPRECATED pragmas,
+        or WARNING pragmas with the ``deprecated`` category.
+        Alias for :ghc-flag:`-Wdeprecations`.
+    :type: dynamic
+    :reverse: -Wno-warnings-deprecations
+    :category:
+
+    :since: 6.10
+
+    :default: on
+
+    .. index::
+       pair: deprecations; warnings
+
+    Causes a warning to be emitted when a module, function or type with
+    ``DEPRECATED pragma``, or a ``WARNING`` pragma with the ``deprecated``
+    category, is used. See :ref:`warning-deprecated-pragma` for more details on
+    the pragmas. An alias for :ghc-flag:`-Wdeprecations`.
 
 .. ghc-flag:: -Wnoncanonical-monad-instances
     :shortdesc: warn when ``Applicative`` or ``Monad`` instances have
diff --git a/testsuite/tests/parser/should_compile/T3303.stderr b/testsuite/tests/parser/should_compile/T3303.stderr
index 850a150ecc..323717e99c 100644
--- a/testsuite/tests/parser/should_compile/T3303.stderr
+++ b/testsuite/tests/parser/should_compile/T3303.stderr
@@ -1,9 +1,9 @@
 
-T3303.hs:7:7: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+T3303.hs:7:7: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘foo’ (imported from T3303A):
     Deprecated: "This is a multi-line
                  deprecation message
                  for foo"
 
-T3303.hs:10:8: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+T3303.hs:10:8: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘foo2’ (imported from T3303A): Deprecated: ""
diff --git a/testsuite/tests/rename/should_compile/T5867.stderr b/testsuite/tests/rename/should_compile/T5867.stderr
index 9bef44b1d0..481517f7a6 100644
--- a/testsuite/tests/rename/should_compile/T5867.stderr
+++ b/testsuite/tests/rename/should_compile/T5867.stderr
@@ -1,8 +1,8 @@
 
-T5867.hs:4:7: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+T5867.hs:4:7: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘f’ (imported from T5867a):
     Deprecated: "Don't use f!"
 
-T5867.hs:5:7: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+T5867.hs:5:7: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘f’ (imported from T5867a):
     Deprecated: "Don't use f!"
diff --git a/testsuite/tests/rename/should_compile/rn050.stderr b/testsuite/tests/rename/should_compile/rn050.stderr
index 7eb3badaa3..4c741b82ab 100644
--- a/testsuite/tests/rename/should_compile/rn050.stderr
+++ b/testsuite/tests/rename/should_compile/rn050.stderr
@@ -1,8 +1,8 @@
 
-rn050.hs:13:7: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+rn050.hs:13:7: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘op’ (imported from Rn050_A):
     Deprecated: "Use bop instead"
 
-rn050.hs:13:10: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+rn050.hs:13:10: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of data constructor ‘C’ (imported from Rn050_A):
     Deprecated: "Use D instead"
diff --git a/testsuite/tests/rename/should_compile/rn066.stderr b/testsuite/tests/rename/should_compile/rn066.stderr
index ff29113bd8..029ebb9d0d 100644
--- a/testsuite/tests/rename/should_compile/rn066.stderr
+++ b/testsuite/tests/rename/should_compile/rn066.stderr
@@ -1,8 +1,8 @@
 
-rn066.hs:13:7: warning: [GHC-63394] [-Wdeprecations (in -Wdefault)]
+rn066.hs:13:7: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘op’ (imported from Rn066_A):
     "Is that really a good idea?"
 
-rn066.hs:13:10: warning: [GHC-63394] [-Wdeprecations (in -Wdefault)]
+rn066.hs:13:10: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
     In the use of data constructor ‘C’ (imported from Rn066_A):
     "Are you sure you want to do that?"
diff --git a/testsuite/tests/rename/should_fail/T5281.stderr b/testsuite/tests/rename/should_fail/T5281.stderr
index a5c5fd2520..75ecd55079 100644
--- a/testsuite/tests/rename/should_fail/T5281.stderr
+++ b/testsuite/tests/rename/should_fail/T5281.stderr
@@ -1,4 +1,4 @@
 
-T5281.hs:6:5: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+T5281.hs:6:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘deprec’ (imported from T5281A):
     Deprecated: "This is deprecated"
diff --git a/testsuite/tests/warnings/should_compile/DeprU.stderr b/testsuite/tests/warnings/should_compile/DeprU.stderr
index f184ef6262..a458dc4f2b 100644
--- a/testsuite/tests/warnings/should_compile/DeprU.stderr
+++ b/testsuite/tests/warnings/should_compile/DeprU.stderr
@@ -1,10 +1,10 @@
 [1 of 2] Compiling DeprM            ( DeprM.hs, DeprM.o )
 [2 of 2] Compiling A                ( DeprU.hs, DeprU.o )
 
-DeprU.hs:3:1: warning: [-Wdeprecations (in -Wdefault)]
+DeprU.hs:3:1: warning: [-Wdeprecations (in -Wextended-warnings)]
     Module ‘DeprM’ is deprecated:
       "Here can be your menacing deprecation warning!"
 
-DeprU.hs:6:5: warning: [GHC-68441] [-Wdeprecations (in -Wdefault)]
+DeprU.hs:6:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
     In the use of ‘f’ (imported from DeprM):
     Deprecated: "Here can be your menacing deprecation warning!"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory1.hs b/testsuite/tests/warnings/should_fail/WarningCategory1.hs
new file mode 100644
index 0000000000..5f56cb031e
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory1.hs
@@ -0,0 +1,7 @@
+module WarningCategory1 where
+
+import WarningCategory1_B
+import WarningCategoryModule
+
+use :: [()]
+use = [foo, bar, baz, quux, plugh, wurble]
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory1.stderr b/testsuite/tests/warnings/should_fail/WarningCategory1.stderr
new file mode 100644
index 0000000000..1d86cedab1
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory1.stderr
@@ -0,0 +1,27 @@
+
+WarningCategory1.hs:4:1: error: [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    Module ‘WarningCategoryModule’: "Module-level warning"
+
+WarningCategory1.hs:7:8: error: [GHC-63394] [-Wx-dangerous (in -Wextended-warnings), -Werror=x-dangerous]
+    In the use of ‘foo’ (imported from WarningCategory1_B):
+    "foo is dangerous"
+
+WarningCategory1.hs:7:13: error: [GHC-63394] [-Wx-mostly-harmless (in -Wextended-warnings), -Werror=x-mostly-harmless]
+    In the use of ‘bar’ (imported from WarningCategory1_B):
+    "bar is mostly harmless"
+
+WarningCategory1.hs:7:18: error: [GHC-63394] [-Wx-harmless (in -Wextended-warnings), -Werror=x-harmless]
+    In the use of ‘baz’ (imported from WarningCategory1_B):
+    "baz is harmless"
+
+WarningCategory1.hs:7:23: error: [GHC-63394] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘quux’ (imported from WarningCategory1_B):
+    "quux has no category"
+
+WarningCategory1.hs:7:29: error: [GHC-68441] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘plugh’ (imported from WarningCategory1_B):
+    Deprecated: "plugh is deprecated"
+
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    In the use of ‘wurble’ (imported from WarningCategoryModule):
+    "Module-level warning"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory1_B.hs b/testsuite/tests/warnings/should_fail/WarningCategory1_B.hs
new file mode 100644
index 0000000000..9d9c3b1b90
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory1_B.hs
@@ -0,0 +1,21 @@
+module WarningCategory1_B where
+
+{-# WARNING in "x-dangerous" foo "foo is dangerous" ;
+            in "x-mostly-harmless" bar "bar is mostly harmless" #-}
+foo :: ()
+foo = foo
+
+bar :: ()
+bar = undefined
+
+{-# WARNING in "x-harmless" baz "baz is harmless" #-}
+baz :: ()
+baz = ()
+
+{-# WARNING quux "quux has no category" #-}
+quux :: ()
+quux = ()
+
+{-# DEPRECATED plugh "plugh is deprecated" #-}
+plugh :: ()
+plugh = ()
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory2.stderr b/testsuite/tests/warnings/should_fail/WarningCategory2.stderr
new file mode 100644
index 0000000000..6b8faed762
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory2.stderr
@@ -0,0 +1,23 @@
+
+WarningCategory1.hs:4:1: error: [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    Module ‘WarningCategoryModule’: "Module-level warning"
+
+WarningCategory1.hs:7:8: error: [GHC-63394] [-Wx-dangerous (in -Wextended-warnings), -Werror=x-dangerous]
+    In the use of ‘foo’ (imported from WarningCategory1_B):
+    "foo is dangerous"
+
+WarningCategory1.hs:7:13: warning: [GHC-63394] [-Wx-mostly-harmless (in -Wextended-warnings)]
+    In the use of ‘bar’ (imported from WarningCategory1_B):
+    "bar is mostly harmless"
+
+WarningCategory1.hs:7:23: error: [GHC-63394] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘quux’ (imported from WarningCategory1_B):
+    "quux has no category"
+
+WarningCategory1.hs:7:29: error: [GHC-68441] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘plugh’ (imported from WarningCategory1_B):
+    Deprecated: "plugh is deprecated"
+
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    In the use of ‘wurble’ (imported from WarningCategoryModule):
+    "Module-level warning"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory4.stderr b/testsuite/tests/warnings/should_fail/WarningCategory4.stderr
new file mode 100644
index 0000000000..87e0757c02
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory4.stderr
@@ -0,0 +1,8 @@
+
+WarningCategory1.hs:7:8: error: [GHC-63394] [-Wx-dangerous (in -Wextended-warnings), -Werror=x-dangerous]
+    In the use of ‘foo’ (imported from WarningCategory1_B):
+    "foo is dangerous"
+
+WarningCategory1.hs:7:13: warning: [GHC-63394] [-Wx-mostly-harmless (in -Wextended-warnings)]
+    In the use of ‘bar’ (imported from WarningCategory1_B):
+    "bar is mostly harmless"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory5.stderr b/testsuite/tests/warnings/should_fail/WarningCategory5.stderr
new file mode 100644
index 0000000000..536a40bc25
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory5.stderr
@@ -0,0 +1,19 @@
+
+WarningCategory1.hs:4:1: warning: [-Wx-module-warning-42 (in -Wextended-warnings)]
+    Module ‘WarningCategoryModule’: "Module-level warning"
+
+WarningCategory1.hs:7:8: error: [GHC-63394] [-Wx-dangerous (in -Wextended-warnings), -Werror=x-dangerous]
+    In the use of ‘foo’ (imported from WarningCategory1_B):
+    "foo is dangerous"
+
+WarningCategory1.hs:7:13: warning: [GHC-63394] [-Wx-mostly-harmless (in -Wextended-warnings)]
+    In the use of ‘bar’ (imported from WarningCategory1_B):
+    "bar is mostly harmless"
+
+WarningCategory1.hs:7:18: warning: [GHC-63394] [-Wx-harmless (in -Wextended-warnings)]
+    In the use of ‘baz’ (imported from WarningCategory1_B):
+    "baz is harmless"
+
+WarningCategory1.hs:7:36: warning: [GHC-63394] [-Wx-module-warning-42 (in -Wextended-warnings)]
+    In the use of ‘wurble’ (imported from WarningCategoryModule):
+    "Module-level warning"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory6.stderr b/testsuite/tests/warnings/should_fail/WarningCategory6.stderr
new file mode 100644
index 0000000000..afbf9198a7
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory6.stderr
@@ -0,0 +1,8 @@
+
+WarningCategory1.hs:7:23: error: [GHC-63394] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘quux’ (imported from WarningCategory1_B):
+    "quux has no category"
+
+WarningCategory1.hs:7:29: error: [GHC-68441] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘plugh’ (imported from WarningCategory1_B):
+    Deprecated: "plugh is deprecated"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategory7.stderr b/testsuite/tests/warnings/should_fail/WarningCategory7.stderr
new file mode 100644
index 0000000000..1d86cedab1
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategory7.stderr
@@ -0,0 +1,27 @@
+
+WarningCategory1.hs:4:1: error: [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    Module ‘WarningCategoryModule’: "Module-level warning"
+
+WarningCategory1.hs:7:8: error: [GHC-63394] [-Wx-dangerous (in -Wextended-warnings), -Werror=x-dangerous]
+    In the use of ‘foo’ (imported from WarningCategory1_B):
+    "foo is dangerous"
+
+WarningCategory1.hs:7:13: error: [GHC-63394] [-Wx-mostly-harmless (in -Wextended-warnings), -Werror=x-mostly-harmless]
+    In the use of ‘bar’ (imported from WarningCategory1_B):
+    "bar is mostly harmless"
+
+WarningCategory1.hs:7:18: error: [GHC-63394] [-Wx-harmless (in -Wextended-warnings), -Werror=x-harmless]
+    In the use of ‘baz’ (imported from WarningCategory1_B):
+    "baz is harmless"
+
+WarningCategory1.hs:7:23: error: [GHC-63394] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘quux’ (imported from WarningCategory1_B):
+    "quux has no category"
+
+WarningCategory1.hs:7:29: error: [GHC-68441] [-Wdeprecations (in -Wextended-warnings), -Werror=deprecations]
+    In the use of ‘plugh’ (imported from WarningCategory1_B):
+    Deprecated: "plugh is deprecated"
+
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Wx-module-warning-42 (in -Wextended-warnings), -Werror=x-module-warning-42]
+    In the use of ‘wurble’ (imported from WarningCategoryModule):
+    "Module-level warning"
diff --git a/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.hs b/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.hs
new file mode 100644
index 0000000000..eba4b38a93
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.hs
@@ -0,0 +1,5 @@
+module WarningCategoryInvalid {-# WARNING in "invalid-category1" "Invalid category 1" #-} where
+
+{-# WARNING in "x-IN VALID-category2" wurble "Invalid category 2" #-}
+wurble :: ()
+wurble = ()
diff --git a/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.stderr b/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.stderr
new file mode 100644
index 0000000000..53ca4eb21c
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategoryInvalid.stderr
@@ -0,0 +1,10 @@
+
+WarningCategoryInvalid.hs:1:46: error: [GHC-53573]
+    Warning category ‘invalid-category1’ is not valid
+    (user-defined category names must begin with ‘x-’
+    and contain only letters, numbers, apostrophes and dashes)
+
+WarningCategoryInvalid.hs:3:16: error: [GHC-53573]
+    Warning category ‘x-IN VALID-category2’ is not valid
+    (user-defined category names must begin with ‘x-’
+    and contain only letters, numbers, apostrophes and dashes)
diff --git a/testsuite/tests/warnings/should_fail/WarningCategoryModule.hs b/testsuite/tests/warnings/should_fail/WarningCategoryModule.hs
new file mode 100644
index 0000000000..15ec2ebd3d
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/WarningCategoryModule.hs
@@ -0,0 +1,4 @@
+module WarningCategoryModule {-# WARNING in "x-module-warning-42" "Module-level warning" #-} where
+
+wurble :: ()
+wurble = ()
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
index f016212ed9..a7ded1ebf8 100644
--- a/testsuite/tests/warnings/should_fail/all.T
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -18,3 +18,11 @@ test('CaretDiagnostics1',
 test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret'])
 test('Colour', normal, compile_fail, ['-fdiagnostics-color=always'])
 test('T20263', normal, compile_fail, ['-Wunicode-bidirectional-format-characters -Werror'])
+test('WarningCategory1', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Werror'])
+test('WarningCategory2', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Wall -Werror -Wno-x-harmless -Wwarn=x-mostly-harmless -Werror=x-dangerous'])
+test('WarningCategory3', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile, ['WarningCategory1', '-v0 -Wall -Werror -Wno-extended-warnings'])
+test('WarningCategory4', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -w -Wx-mostly-harmless -Wwarn=extended-warnings -Werror=x-dangerous -Wx-dangerous'])
+test('WarningCategory5', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Wwarnings-deprecations -Wno-deprecations -Werror=x-dangerous'])
+test('WarningCategory6', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Wno-extended-warnings -Wdeprecations -Werror=warnings-deprecations'])
+test('WarningCategory7', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Werror -w -Wall'])
+test('WarningCategoryInvalid', normal, compile_fail, [''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index a569b803d4..d4f1961176 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1424,13 +1424,13 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
   getAnnotationEntry = entryFromLocatedA
   setAnnotationAnchor = setAnchorAn
 
-  exact (L (SrcSpanAnn an l) (WarningTxt (L la src) ws)) = do
+  exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do
     an0 <- markAnnOpenP an src "{-# WARNING"
     an1 <- markEpAnnL an0 lapr_rest AnnOpenS
     ws' <- markAnnotated ws
     an2 <- markEpAnnL an1 lapr_rest AnnCloseS
     an3 <- markAnnCloseP an2
-    return (L (SrcSpanAnn an3 l) (WarningTxt (L la src) ws'))
+    return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat (L la src) ws'))
 
   exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do
     an0 <- markAnnOpenP an src "{-# DEPRECATED"
@@ -1766,9 +1766,9 @@ instance ExactPrint (WarnDecl GhcPs) where
     an0 <- markEpAnnL an lidl AnnOpenS -- "["
     txt' <-
       case txt of
-        WarningTxt    src ls -> do
+        WarningTxt mb_cat src ls -> do
           ls' <- markAnnotated ls
-          return (WarningTxt    src ls')
+          return (WarningTxt mb_cat src ls')
         DeprecatedTxt src ls -> do
           ls' <- markAnnotated ls
           return (DeprecatedTxt src ls')
diff --git a/utils/haddock b/utils/haddock
-Subproject 1f22a95c1db942fce2623b9daa26f66d193a4e7
+Subproject 6f1b9093395f4b12298b8b785b855a637206f5f