diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 9185f785f2ca8b527acdcd977088bae6bb1b60e7..8c098c9be50421ac9e4886fe30a7695af01e72b3 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -1283,7 +1283,7 @@ instance OutputableBndrId p
<+> ppr txt
where
ppr_category = case txt of
- WarningTxt (Just cat) _ _ -> text "in" <+> doubleQuotes (ppr cat)
+ WarningTxt (Just cat) _ _ -> ppr cat
_ -> empty
{-
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 5475a05877744a794f54bd0e1c7c72c0d4cfa904..0659ef5119720347beb642f0458dc5a79a74add8 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -406,7 +406,7 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 44dda2f0d805418a714dc43d47b8ab0d539dff79..f1a1cf8b64c1006662b4b97646395f8f0da05ba8 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -595,7 +595,7 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt mb_cat src strs -> WarningTxt (noLoc <$> mb_cat) src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
IfDeprecatedTxt src strs -> DeprecatedTxt src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 82634e4f22f17690ff69fcc07fe681f6a03e2032..9536d1e33d07e7cdc7154e0864ba1d9ebc10d8c6 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1978,8 +1978,9 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
(AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
| {- empty -} { Nothing }
-warning_category :: { Maybe (Located WarningCategory) }
- : 'in' STRING { Just (sL1 $2 (mkWarningCategory (getSTRING $2))) }
+warning_category :: { Maybe (Located InWarningCategory) }
+ : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (hsTok' $1) (getSTRINGs $2)
+ (sL1 $2 $ mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
warnings :: { OrdList (LWarnDecl GhcPs) }
@@ -4462,6 +4463,9 @@ listAsAnchor (L l _:_) = spanAsAnchor (locA l)
hsTok :: Located Token -> LHsToken tok GhcPs
hsTok (L l _) = L (mkTokenLocation l) HsTok
+hsTok' :: Located Token -> Located (HsToken tok)
+hsTok' (L l _) = L l HsTok
+
hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs
hsUniTok t@(L l _) =
L (mkTokenLocation l)
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 66f2224241b834d048cf1c6003f959a5d6689c1a..a13e6a4e70c3eec24c244b2b1dae1bc449123f38 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -300,7 +300,7 @@ rnSrcWarnDecls bndr_set decls'
rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt (WarningTxt mb_cat st wst) = do
- forM_ mb_cat $ \(L loc cat) ->
+ forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) ->
unless (validWarningCategory cat) $
addErrAt loc (TcRnInvalidWarningCategory cat)
wst' <- traverse (traverse rnHsDoc) wst
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index d7028ba33eff3cabe01bb2e595b3ff85f1bf2d08..6048c10d1bca4ade7ba9fc157d46bf3ea3326ec4 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -11,10 +12,12 @@
-- | Warnings for a module
module GHC.Unit.Module.Warnings
- ( WarningCategory
+ ( WarningCategory(..)
, mkWarningCategory
, defaultWarningCategory
, validWarningCategory
+ , InWarningCategory(..)
+ , fromWarningCategory
, WarningCategorySet
, emptyWarningCategorySet
@@ -60,6 +63,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Unicode
+import Language.Haskell.Syntax.Concrete (HsToken (HsTok))
import Language.Haskell.Syntax.Extension
import Data.Data
@@ -114,6 +118,15 @@ the possibility of them being infinite.
-}
+data InWarningCategory
+ = InWarningCategory
+ { iwc_in :: !(Located (HsToken "in")),
+ iwc_st :: !SourceText,
+ iwc_wc :: (Located WarningCategory)
+ } deriving Data
+
+fromWarningCategory :: WarningCategory -> InWarningCategory
+fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc)
-- See Note [Warning categories]
@@ -189,7 +202,7 @@ type LWarningTxt pass = XRec pass (WarningTxt pass)
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
= WarningTxt
- (Maybe (Located WarningCategory))
+ (Maybe (Located InWarningCategory))
-- ^ Warning category attached to this WARNING pragma, if any;
-- see Note [Warning categories]
SourceText
@@ -202,7 +215,7 @@ data WarningTxt pass
-- | 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 (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat
warningTxtCategory _ = defaultWarningCategory
-- | The message that the WarningTxt was specified to output
@@ -223,17 +236,24 @@ warningTxtSame w1 w2
| WarningTxt {} <- w1, WarningTxt {} <- w2 = True
| otherwise = False
-deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
+deriving instance Eq InWarningCategory
+
+deriving instance (Eq (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
+
+instance Outputable InWarningCategory where
+ ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)
+
+
instance Outputable (WarningTxt pass) where
ppr (WarningTxt mcat lsrc ws)
= case lsrc of
NoSourceText -> pp_ws ws
SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
- ctg_doc = maybe empty (\ctg -> text "in" <+> doubleQuotes (ppr ctg)) mcat
+ ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
ppr (DeprecatedTxt lsrc ds)
diff --git a/compiler/Language/Haskell/Syntax/Concrete.hs b/compiler/Language/Haskell/Syntax/Concrete.hs
index 982eac3216a47804a9d20a0fb6acd338179d8e36..76e033baf61a8e0f16ecfbe7901b6d48fbaf7f04 100644
--- a/compiler/Language/Haskell/Syntax/Concrete.hs
+++ b/compiler/Language/Haskell/Syntax/Concrete.hs
@@ -35,6 +35,7 @@ data HsToken (tok :: Symbol) = HsTok
-- avoid a dependency.
data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok
+deriving instance Eq (HsToken tok)
deriving instance KnownSymbol tok => Data (HsToken tok)
deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
diff --git a/testsuite/tests/warnings/should_compile/T23465.hs b/testsuite/tests/warnings/should_compile/T23465.hs
index 885b41b9f3d8222146c8a76fad8ddbf02df67391..4964a7355e069b19709e16950d6f4ed9a0bc9538 100644
--- a/testsuite/tests/warnings/should_compile/T23465.hs
+++ b/testsuite/tests/warnings/should_compile/T23465.hs
@@ -1,4 +1,4 @@
module T23465 {-# WaRNING in "x-a" "b" #-} where
-{-# WARNInG in "x-c" e "d" #-}
+{-# WARNInG in "x-c-\72" e "d" #-}
e = e
diff --git a/testsuite/tests/warnings/should_compile/T23465.stderr b/testsuite/tests/warnings/should_compile/T23465.stderr
index 9141eb0835568b3d7da831a30f1e81851d9d8b6c..ac6ee9a7c76362182d676a766b1f00e2c1cd7ecc 100644
--- a/testsuite/tests/warnings/should_compile/T23465.stderr
+++ b/testsuite/tests/warnings/should_compile/T23465.stderr
@@ -3,7 +3,7 @@
module T23465
{-# WaRNING in "x-a" "b" #-}
where
-{-# WARNInG in "x-c" e "d" #-}
+{-# WARNInG in "x-c-H" e "d" #-}
e = e