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

12 files changed, 71 insertions, 13 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
diff --git a/testsuite/tests/ghci/should_run/T7253.stderr b/testsuite/tests/ghci/should_run/T7253.stderr
index 448f91865d..17a3393ac8 100644
--- a/testsuite/tests/ghci/should_run/T7253.stderr
+++ b/testsuite/tests/ghci/should_run/T7253.stderr
@@ -1,6 +1,6 @@
 
 <interactive>:19:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
-    Unrecognised pragma
+    Unrecognised pragma: FOO
 
 <interactive>:61:1: error:
     • Role mismatch on variable b:
diff --git a/testsuite/tests/parser/should_compile/ColumnPragma.stderr b/testsuite/tests/parser/should_compile/ColumnPragma.stderr
index 4dcfbd1441..a45b2654bf 100644
--- a/testsuite/tests/parser/should_compile/ColumnPragma.stderr
+++ b/testsuite/tests/parser/should_compile/ColumnPragma.stderr
@@ -1,3 +1,3 @@
 
 ColumnPragma.hs:5:1015: warning: [-Wunrecognised-pragmas (in -Wdefault)]
-    Unrecognised pragma
+    Unrecognised pragma: NONEXISTENTPRAGMA
diff --git a/testsuite/tests/parser/should_compile/T21589.hs b/testsuite/tests/parser/should_compile/T21589.hs
new file mode 100644
index 0000000000..d9f9eff724
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T21589.hs
@@ -0,0 +1,8 @@
+{-# LANGUGE BangPatterns #-}
+{-# OPTION_HUGS #-}
+{-# LIE 42 "Foo.vhs" #-}
+module T21589 where
+
+x :: Int
+x = 42
+{-# INLNE x #-}
diff --git a/testsuite/tests/parser/should_compile/T21589.stderr b/testsuite/tests/parser/should_compile/T21589.stderr
new file mode 100644
index 0000000000..5e1524f2f4
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T21589.stderr
@@ -0,0 +1,16 @@
+
+T21589.hs:1:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
+    Unrecognised pragma: LANGUGE
+    Suggested fix: Perhaps you meant ‘LANGUAGE’
+
+T21589.hs:2:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
+    Unrecognised pragma: OPTION_HUGS
+    Suggested fix: Perhaps you meant ‘OPTIONS_HUGS’
+
+T21589.hs:3:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
+    Unrecognised pragma: LIE
+    Suggested fix: Perhaps you meant ‘LINE’
+
+T21589.hs:8:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
+    Unrecognised pragma: INLNE
+    Suggested fix: Perhaps you meant ‘INLINE’
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index ffadeeaf1c..53fd222576 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -190,4 +190,6 @@ test('T20385', normal, compile, [''])
 test('T20385S', normal, compile, [''])
 
 test('T20718',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
-test('T20718b',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
\ No newline at end of file
+test('T20718b',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
+
+test('T21589', normal, compile, [''])
diff --git a/testsuite/tests/parser/should_compile/read064.stderr b/testsuite/tests/parser/should_compile/read064.stderr
index 120961d321..8f79347013 100644
--- a/testsuite/tests/parser/should_compile/read064.stderr
+++ b/testsuite/tests/parser/should_compile/read064.stderr
@@ -1,3 +1,3 @@
 
 read064.hs:4:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
-    Unrecognised pragma
+    Unrecognised pragma: THISISATYPO
diff --git a/testsuite/tests/parser/should_compile/read066.stderr b/testsuite/tests/parser/should_compile/read066.stderr
index 152987f981..967c334b07 100644
--- a/testsuite/tests/parser/should_compile/read066.stderr
+++ b/testsuite/tests/parser/should_compile/read066.stderr
@@ -1,3 +1,3 @@
 
 read066.hs:2:1: warning: [-Wunrecognised-pragmas (in -Wdefault)]
-    Unrecognised pragma
+    Unrecognised pragma: OPTIONS_NO_SUCH_PRAGMA