From 06cf6f4a3c9e520b054b7d83feb622ee15796a94 Mon Sep 17 00:00:00 2001 From: Tony Zorman Date: Sun, 12 Jun 2022 16:15:02 +0200 Subject: Add suggestions for unrecognised pragmas (#21589) In case of a misspelled pragma, offer possible corrections as to what the user could have meant. Fixes: https://gitlab.haskell.org/ghc/ghc/-/issues/21589 --- compiler/GHC/Parser/Errors/Ppr.hs | 12 +++++++++--- compiler/GHC/Parser/Errors/Types.hs | 5 +++-- compiler/GHC/Parser/Lexer.x | 21 ++++++++++++++++++--- compiler/GHC/Types/Hint.hs | 8 ++++++++ compiler/GHC/Types/Hint/Ppr.hs | 2 ++ 5 files changed, 40 insertions(+), 8 deletions(-) (limited to 'compiler/GHC') diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index efe708bfee..6f7581c2a2 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -105,8 +105,9 @@ instance Diagnostic PsMessage where <+> quotes (text "Data.Kind.Type") $$ text "relies on the StarIsType extension, which will become" $$ text "deprecated in the future." - PsWarnUnrecognisedPragma + PsWarnUnrecognisedPragma prag _ -> mkSimpleDecorated $ text "Unrecognised pragma" + <> if null prag then empty else text ":" <+> text prag PsWarnMisplacedPragma prag -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma" PsWarnImportPreQualified @@ -511,7 +512,7 @@ instance Diagnostic PsMessage where PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType - PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas + PsWarnUnrecognisedPragma{} -> WarningWithFlag Opt_WarnUnrecognisedPragmas PsWarnMisplacedPragma{} -> WarningWithFlag Opt_WarnMisplacedPragmas PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule PsErrLexer{} -> ErrorWithoutFlag @@ -628,7 +629,12 @@ instance Diagnostic PsMessage where PsWarnHaddockIgnoreMulti -> noHints PsWarnStarBinder -> [SuggestQualifyStarOperator] PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing] - PsWarnUnrecognisedPragma -> noHints + PsWarnUnrecognisedPragma "" _ -> noHints + PsWarnUnrecognisedPragma p avail -> + let suggestions = fuzzyMatch p avail + in if null suggestions + then noHints + else [SuggestCorrectPragmaName suggestions] PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 18b6d60807..b4ea2f42a0 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -117,8 +117,9 @@ data PsMessage -} | PsWarnTransitionalLayout !TransLayoutReason - -- | Unrecognised pragma - | PsWarnUnrecognisedPragma + -- | Unrecognised pragma. First field is the actual pragma name which + -- might be empty. Second field is the set of valid candidate pragmas. + | PsWarnUnrecognisedPragma !String ![String] | PsWarnMisplacedPragma !FileHeaderPragmaType -- | Invalid Haddock comment position diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 2b096aaf9c..71e5fa5eb8 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -371,8 +371,16 @@ $tab { warnTab } } <0,option_prags> { - "{-#" { warnThen PsWarnUnrecognisedPragma - (nested_comment ) } + +-- This code would eagerly accept and hence discard, e.g., "LANGUAGE MagicHash". +-- "{-#" $whitechar* $pragmachar+ +-- $whitechar+ $pragmachar+ +-- { warn_unknown_prag twoWordPrags } + + "{-#" $whitechar* $pragmachar+ + { warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) } + + "{-#" { warn_unknown_prag Map.empty } } -- '0' state: ordinary lexemes @@ -3505,7 +3513,14 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) _ -> prag' canon_ws s = unwords (map canonical (words s)) - +warn_unknown_prag :: Map String Action -> Action +warn_unknown_prag prags span buf len = do + let uppercase = map toUpper + unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) + suggestions = map uppercase (Map.keys prags) + addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ + PsWarnUnrecognisedPragma unknown_prag suggestions + nested_comment span buf len {- %************************************************************************ diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index c348addb7e..3f8c3bbadf 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -136,6 +136,14 @@ data GhcHint -} | SuggestExtension !LanguageExtensionHint + {-| Suggests possible corrections of a misspelled pragma. Its argument + represents all applicable suggestions. + + Example: {-# LNGUAGE BangPatterns #-} + + Test case(s): parser/should_compile/T21589 + -} + | SuggestCorrectPragmaName ![String] {-| Suggests that a monadic code block is probably missing a \"do\" keyword. Example: diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index f1595d96ac..53890e8daf 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -40,6 +40,8 @@ instance Outputable GhcHint where in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo SuggestExtensionInOrderTo extraUserInfo ext -> (text "Use" <+> ppr ext) $$ extraUserInfo + SuggestCorrectPragmaName suggestions + -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo -- cgit v1.2.1