[Git][ghc/ghc][master] EPA: Keep track of "in" token for WarningTxt category
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Aug 25 14:59:26 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a936f244 by Alan Zimmerman at 2023-08-25T10:58:56-04:00
EPA: Keep track of "in" token for WarningTxt category
A warning can now be written with a category, e.g.
{-# WARNInG in "x-c" e "d" #-}
Keep track of the location of the 'in' keyword and string, as well as
the original SourceText of the label, in case it uses character escapes.
- - - - -
9 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/Language/Haskell/Syntax/Concrete.hs
- testsuite/tests/warnings/should_compile/T23465.hs
- testsuite/tests/warnings/should_compile/T23465.stderr
Changes:
=====================================
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
{-
=====================================
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])
=====================================
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
=====================================
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)
=====================================
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
=====================================
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)
=====================================
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)
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a936f244934b78edb24d7462057670dbec72e938
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a936f244934b78edb24d7462057670dbec72e938
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230825/e78ef2f3/attachment-0001.html>
More information about the ghc-commits
mailing list