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

5 files changed, 40 insertions, 8 deletions

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