[Git][ghc/ghc][wip/amg/warning-categories] 2 commits: Overhaul lexing of warning categories to be less obviously broken
Adam Gundry (@adamgundry)
gitlab at gitlab.haskell.org
Sat Jan 28 21:03:37 UTC 2023
Adam Gundry pushed to branch wip/amg/warning-categories at Glasgow Haskell Compiler / GHC
Commits:
e86c33fc by Adam Gundry at 2023-01-28T21:03:06+00:00
Overhaul lexing of warning categories to be less obviously broken
- - - - -
a45f1d47 by Adam Gundry at 2023-01-28T21:03:06+00:00
Amend warning category test to include category name that could not be lexed before
- - - - -
7 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- testsuite/tests/warnings/should_fail/WarningCategory1.stderr
- testsuite/tests/warnings/should_fail/WarningCategory2.stderr
- testsuite/tests/warnings/should_fail/WarningCategory5.stderr
- testsuite/tests/warnings/should_fail/WarningCategory7.stderr
- testsuite/tests/warnings/should_fail/WarningCategoryModule.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -709,6 +709,8 @@ are the most common patterns, rewritten as regular expressions for clarity:
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
LABELVARID { L _ (ITlabelvarid _ _) }
+ WARNING_CAT { L _ (ITwarning_category _) }
+
CHAR { L _ (ITchar _ _) }
STRING { L _ (ITstring _ _) }
INTEGER { L _ (ITinteger _) }
@@ -1942,14 +1944,11 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
-- Warnings and deprecations (c.f. rules)
warning_category :: { Maybe (Located WarningCategory) }
- : '{' warning_category_name '}' { Just (fmap mkWarningCategory $2) }
+ : '{' warning_category_name '}' { Just $2 }
| {- empty -} { Nothing }
--- TODO: how to lex warning category names? As `litpkgname` mentions it is a bit
--- of a hack, e.g. it accepts spaces between hyphens, and it does not accept
--- some valid names (e.g. "x-module" or "x-warning-1" are both rejected).
-warning_category_name :: { Located FastString }
- : litpkgname { $1 }
+warning_category_name :: { Located WarningCategory }
+ : WARNING_CAT { sL1 $1 $ mkWarningCategory $ getWARNING_CAT $1 }
warnings :: { OrdList (LWarnDecl GhcPs) }
@@ -3935,6 +3934,7 @@ getQVARSYM (L _ (ITqvarsym x)) = x
getQCONSYM (L _ (ITqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x
getLABELVARID (L _ (ITlabelvarid _ x)) = x
+getWARNING_CAT (L _ (ITwarning_category x)) = x
getCHAR (L _ (ITchar _ x)) = x
getSTRING (L _ (ITstring _ x)) = x
getINTEGER (L _ (ITinteger x)) = x
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -174,6 +174,8 @@ $hexit = [$decdigit A-F a-f]
$pragmachar = [$small $large $digit $uniidchar ]
+$warningcategorychar = [$small $large $digit $uniidchar \-]
+
$docsym = [\| \^ \* \$]
@@ -352,6 +354,9 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
$whitechar+ $pragmachar+ / { known_pragma twoWordPrags }
{ dispatch_pragmas twoWordPrags }
+ "{-#" $whitechar* $pragmachar+ / { is_warning_pragma }
+ { start_warning_pragma }
+
"{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }
{ dispatch_pragmas oneWordPrags }
@@ -363,6 +368,18 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
"#-}" { endPrag }
}
+<warning_pragma> {
+ \n ;
+ "{" { start_warning_category }
+ "#-}" { end_warning_pragma }
+}
+
+<warning_category> {
+ $whitechar ;
+ "}" { end_warning_category }
+ $warningcategorychar+ { warning_cat }
+}
+
<option_prags> {
"{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
{ dispatch_pragmas fileHeaderPrags }
@@ -466,7 +483,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
{ token ITcubxparen }
}
-<0,option_prags> {
+<0,option_prags,warning_pragma> {
\( { special IToparen }
\) { special ITcparen }
\[ { special ITobrack }
@@ -479,7 +496,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
\} { close_brace }
}
-<0,option_prags> {
+<0,option_prags,warning_pragma> {
@qdo { qdo_token ITdo }
@qmdo / { ifExtension RecursiveDoBit } { qdo_token ITmdo }
@qvarid { idtoken qvarid }
@@ -572,7 +589,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
-- that even if we recognise the string or char here in the regex
-- lexer, we would still have to parse the string afterward in order
-- to convert it to a String.
-<0> {
+<0,warning_pragma> {
\' { lex_char_tok }
\" { lex_string_tok }
}
@@ -780,6 +797,7 @@ data Token
| ITsource_prag SourceText
| ITrules_prag SourceText
| ITwarning_prag SourceText
+ | ITwarning_category FastString
| ITdeprecated_prag SourceText
| ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit'
| ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit'
@@ -3570,7 +3588,6 @@ oneWordPrags = Map.fromList [
("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),
("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
("source", strtoken (\s -> ITsource_prag (SourceText s))),
- ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
("scc", strtoken (\s -> ITscc_prag (SourceText s))),
("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
@@ -3610,6 +3627,39 @@ known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
isKnown = isJust $ Map.lookup (clean_pragma l) prags
pragmaNameChar c = isAlphaNum c || c == '_'
+is_warning_pragma :: AlexAccPred ExtsBitmap
+is_warning_pragma _ (AI _ startbuf) _ (AI _ curbuf)
+ = isWarning && nextCharIsNot curbuf pragmaNameChar
+ where l = lexemeToString startbuf (byteDiff startbuf curbuf)
+ isWarning = clean_pragma l == "warning"
+ pragmaNameChar c = isAlphaNum c || c == '_'
+
+start_warning_pragma :: Action
+start_warning_pragma span buf len buf2 = do
+ pushLexState warning_pragma
+ strtoken (ITwarning_prag . SourceText) span buf len buf2
+
+end_warning_pragma :: Action
+end_warning_pragma span buf len buf2 = do
+ _ <- popLexState
+ endPrag span buf len buf2
+
+start_warning_category :: Action
+start_warning_category span buf len buf2 = do
+ pushLexState warning_category
+ token ITocurly span buf len buf2
+
+warning_cat :: Action
+warning_cat span buf len buf2 =
+ token (ITwarning_category fs) span buf len buf2
+ where
+ !fs = lexemeToFastString buf len
+
+end_warning_category :: Action
+end_warning_category span buf len buf2 = do
+ _ <- popLexState
+ token ITccurly span buf len buf2
+
clean_pragma :: String -> String
clean_pragma prag = canon_ws (map toLower (unprefix prag))
where unprefix prag' = case stripPrefix "{-#" prag' of
=====================================
testsuite/tests/warnings/should_fail/WarningCategory1.stderr
=====================================
@@ -1,5 +1,5 @@
-WarningCategory1.hs:4:1: error: [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:4:1: error: [-Werror=x-module-warning-42 (in -Wextended-warnings)]
Module ‘WarningCategoryModule’: "Module-level warning"
WarningCategory1.hs:7:8: error: [GHC-63394] [-Werror=x-dangerous (in -Wextended-warnings)]
@@ -22,6 +22,6 @@ WarningCategory1.hs:7:29: error: [GHC-68441] [-Werror=deprecations (in -Wextende
In the use of ‘plugh’ (imported from WarningCategory1_B):
Deprecated: "plugh is deprecated"
-WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-module-warning-42 (in -Wextended-warnings)]
In the use of ‘wurble’ (imported from WarningCategoryModule):
"Module-level warning"
=====================================
testsuite/tests/warnings/should_fail/WarningCategory2.stderr
=====================================
@@ -1,5 +1,5 @@
-WarningCategory1.hs:4:1: error: [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:4:1: error: [-Werror=x-module-warning-42 (in -Wextended-warnings)]
Module ‘WarningCategoryModule’: "Module-level warning"
WarningCategory1.hs:7:8: error: [GHC-63394] [-Werror=x-dangerous (in -Wextended-warnings)]
@@ -18,6 +18,6 @@ WarningCategory1.hs:7:29: error: [GHC-68441] [-Werror=deprecations (in -Wextende
In the use of ‘plugh’ (imported from WarningCategory1_B):
Deprecated: "plugh is deprecated"
-WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-module-warning-42 (in -Wextended-warnings)]
In the use of ‘wurble’ (imported from WarningCategoryModule):
"Module-level warning"
=====================================
testsuite/tests/warnings/should_fail/WarningCategory5.stderr
=====================================
@@ -1,5 +1,5 @@
-WarningCategory1.hs:4:1: warning: [-Wx-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:4:1: warning: [-Wx-module-warning-42 (in -Wextended-warnings)]
Module ‘WarningCategoryModule’: "Module-level warning"
WarningCategory1.hs:7:8: error: [GHC-63394] [-Werror=x-dangerous (in -Wextended-warnings)]
@@ -14,6 +14,6 @@ WarningCategory1.hs:7:18: warning: [GHC-63394] [-Wx-harmless (in -Wextended-warn
In the use of ‘baz’ (imported from WarningCategory1_B):
"baz is harmless"
-WarningCategory1.hs:7:36: warning: [GHC-63394] [-Wx-mod-warning (in -Wextended-warnings)]
+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"
=====================================
testsuite/tests/warnings/should_fail/WarningCategory7.stderr
=====================================
@@ -1,5 +1,5 @@
-WarningCategory1.hs:4:1: error: [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:4:1: error: [-Werror=x-module-warning-42 (in -Wextended-warnings)]
Module ‘WarningCategoryModule’: "Module-level warning"
WarningCategory1.hs:7:8: error: [GHC-63394] [-Werror=x-dangerous (in -Wextended-warnings)]
@@ -22,6 +22,6 @@ WarningCategory1.hs:7:29: error: [GHC-68441] [-Werror=deprecations (in -Wextende
In the use of ‘plugh’ (imported from WarningCategory1_B):
Deprecated: "plugh is deprecated"
-WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-mod-warning (in -Wextended-warnings)]
+WarningCategory1.hs:7:36: error: [GHC-63394] [-Werror=x-module-warning-42 (in -Wextended-warnings)]
In the use of ‘wurble’ (imported from WarningCategoryModule):
"Module-level warning"
=====================================
testsuite/tests/warnings/should_fail/WarningCategoryModule.hs
=====================================
@@ -1,4 +1,4 @@
-module WarningCategoryModule {-# WARNING {x-mod-warning} "Module-level warning" #-} where
+module WarningCategoryModule {-# WARNING {x-module-warning-42} "Module-level warning" #-} where
wurble :: ()
wurble = ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/022ad0e475f73d74d40d72d60399e01aa6d0dc22...a45f1d4731d7bde10cb206c94a84d46bcbb2f6f4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/022ad0e475f73d74d40d72d60399e01aa6d0dc22...a45f1d4731d7bde10cb206c94a84d46bcbb2f6f4
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/20230128/64dfc192/attachment-0001.html>
More information about the ghc-commits
mailing list