Add PsHeaderMessage diagnostic (fixes #19923)

This commit replaces the PsUnknownMessage diagnostics over at
`GHC.Parser.Header` with a new `PsHeaderMessage` type (part of
the more general `PsMessage`), so that we can throw parser header's
errors which can be correctly caught by `GHC.Driver.Pipeline.preprocess`
and rewrapped (correctly) as Driver messages (using the
`DriverPsHeaderMessage`).

This gets rid of the nasty compiler crash as part of #19923.

14 files changed, 99 insertions, 26 deletions

diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 777761f201..157fd77735 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -9,7 +9,6 @@ import GHC.Driver.Session
 import GHC.Driver.Errors.Types
 import GHC.Data.Bag
 import GHC.Prelude
-import GHC.Parser.Errors.Types
 import GHC.Types.SrcLoc
 import GHC.Types.SourceError
 import GHC.Types.Error
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
index 142b3b2be9..4c593fb681 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -2,7 +2,7 @@
 
 module GHC.Driver.Errors.Types (
     GhcMessage(..)
-  , DriverMessage(..), DriverMessages
+  , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage)
   , BuildingCabalPackage(..)
   , WarningMessages
   , ErrorMessages
@@ -24,7 +24,7 @@ import GHC.Driver.Session
 import GHC.Types.Error
 import GHC.Unit.Module
 
-import GHC.Parser.Errors.Types ( PsMessage )
+import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) )
 import GHC.Tc.Errors.Types     ( TcRnMessage )
 import GHC.HsToCore.Errors.Types ( DsMessage )
 
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 44ae426e2d..205c767aed 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -166,8 +166,12 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
                              (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
       Just msgs' -> msgs'
 
-    to_driver_message (GhcDriverMessage msg) = Just msg
-    to_driver_message _other                 = Nothing
+    to_driver_message = \case
+      GhcDriverMessage msg
+        -> Just msg
+      GhcPsMessage (PsHeaderMessage msg)
+        -> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
+      _ -> Nothing
 
 -- ---------------------------------------------------------------------------
 
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 725d99fea4..2cf52db558 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -9,6 +9,7 @@ module GHC.Parser.Errors.Ppr where
 
 import GHC.Prelude
 import GHC.Driver.Flags
+import GHC.Driver.Session (supportedLanguagesAndExtensions)
 import GHC.Parser.Errors.Types
 import GHC.Parser.Types
 import GHC.Types.Basic
@@ -33,6 +34,9 @@ instance Diagnostic PsMessage where
     PsUnknownMessage m
       -> diagnosticMessage m
 
+    PsHeaderMessage m
+      -> psHeaderMessageDiagnostic m
+
     PsWarnHaddockInvalidPos
        -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored."
     PsWarnHaddockIgnoreMulti
@@ -529,6 +533,7 @@ instance Diagnostic PsMessage where
 
   diagnosticReason  = \case
     PsUnknownMessage m                            -> diagnosticReason m
+    PsHeaderMessage  _                            -> ErrorWithoutFlag
     PsWarnTab{}                                   -> WarningWithFlag Opt_WarnTabs
     PsWarnTransitionalLayout{}                    -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional
     PsWarnOperatorWhitespaceExtConflict{}         -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict
@@ -639,6 +644,7 @@ instance Diagnostic PsMessage where
 
   diagnosticHints  = \case
     PsUnknownMessage m                            -> diagnosticHints m
+    PsHeaderMessage  m                            -> psHeaderMessageHints m
     PsWarnTab{}                                   -> [SuggestUseSpaces]
     PsWarnTransitionalLayout{}                    -> noHints
     PsWarnOperatorWhitespaceExtConflict{}         -> noHints
@@ -764,6 +770,41 @@ instance Diagnostic PsMessage where
     PsErrInvalidPackageName{}                     -> noHints
     PsErrIllegalGadtRecordMultiplicity{}          -> noHints
 
+psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc
+psHeaderMessageDiagnostic = \case
+  PsErrParseLanguagePragma
+    -> mkSimpleDecorated $
+         vcat [ text "Cannot parse LANGUAGE pragma"
+              , text "Expecting comma-separated list of language options,"
+              , text "each starting with a capital letter"
+              , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
+  PsErrUnsupportedExt unsup _
+    -> mkSimpleDecorated $ text "Unsupported extension: " <> text unsup
+  PsErrParseOptionsPragma str
+    -> mkSimpleDecorated $
+         vcat [ text "Error while parsing OPTIONS_GHC pragma."
+              , text "Expecting whitespace-separated list of GHC options."
+              , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
+              , text ("Input was: " ++ show str) ]
+
+psHeaderMessageHints :: PsHeaderMessage -> [GhcHint]
+psHeaderMessageHints = \case
+  PsErrParseLanguagePragma
+    -> noHints
+  PsErrUnsupportedExt unsup arch
+    -> if null suggestions
+          then noHints
+          -- FIXME(adn) To fix the compiler crash in #19923 we just rewrap this into an
+          -- UnknownHint, but we should have here a proper hint, but that would require
+          -- changing 'supportedExtensions' to emit a list of 'Extension'.
+          else [UnknownHint $ text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)]
+       where
+         suggestions :: [String]
+         suggestions = fuzzyMatch unsup (supportedLanguagesAndExtensions arch)
+  PsErrParseOptionsPragma{}
+    -> noHints
+
+
 suggestParensAndBlockArgs :: [GhcHint]
 suggestParensAndBlockArgs =
   [SuggestParentheses, SuggestExtension LangExt.BlockArguments]
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 38c54b7149..88a287d69b 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -15,6 +15,7 @@ import GHC.Types.Name.Occurrence (OccName)
 import GHC.Types.Name.Reader
 import GHC.Unit.Module.Name
 import GHC.Utils.Outputable
+import GHC.Platform.ArchOS
 
 -- The type aliases below are useful to make some type signatures a bit more
 -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.
@@ -22,6 +23,24 @@ import GHC.Utils.Outputable
 type PsWarning = PsMessage   -- /INVARIANT/: The diagnosticReason is a Warning reason
 type PsError   = PsMessage   -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag
 
+{-
+Note [Messages from GHC.Parser.Header
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We group the messages from 'GHC.Parser.Header' because we need to
+be able to pattern match on them in the driver code. This is because
+in functions like 'GHC.Driver.Pipeline.preprocess' we want to handle
+only a specific subset of parser messages, during dependency analysis,
+and having a single constructor to handle them all is handy.
+
+-}
+
+data PsHeaderMessage
+  = PsErrParseLanguagePragma
+  | PsErrUnsupportedExt !String !ArchOS
+  | PsErrParseOptionsPragma !String
+
+
 data PsMessage
   =
     {-| An \"unknown\" message from the parser. This type constructor allows
@@ -30,6 +49,11 @@ data PsMessage
     -}
    forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a
 
+    {-| A group of parser messages emitted in 'GHC.Parser.Header'.
+        See Note [Messages from GHC.Parser.Header].
+    -}
+   | PsHeaderMessage !PsHeaderMessage
+
    {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs
        when tabulations (tabs) are found within a file.
 
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index daa8bc78a5..cd4c0c8295 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -442,30 +442,17 @@ checkExtension dflags (L l ext)
 
 languagePragParseError :: SrcSpan -> a
 languagePragParseError loc =
-    throwErr loc $
-       vcat [ text "Cannot parse LANGUAGE pragma"
-            , text "Expecting comma-separated list of language options,"
-            , text "each starting with a capital letter"
-            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
+    throwErr loc $ PsErrParseLanguagePragma
 
 unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
 unsupportedExtnError dflags loc unsup =
-    throwErr loc $
-        text "Unsupported extension: " <> text unsup $$
-        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
-  where
-     supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags
-     suggestions = fuzzyMatch unsup supported
+    throwErr loc $ PsErrUnsupportedExt unsup (platformArchOS $ targetPlatform dflags)
 
 optionsParseError :: String -> SrcSpan -> a     -- #15053
 optionsParseError str loc =
-  throwErr loc $
-      vcat [ text "Error while parsing OPTIONS_GHC pragma."
-           , text "Expecting whitespace-separated list of GHC options."
-           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
-           , text ("Input was: " ++ show str) ]
-
-throwErr :: SrcSpan -> SDoc -> a                -- #15053
-throwErr loc doc =
-  let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints doc
+  throwErr loc $ PsErrParseOptionsPragma str
+
+throwErr :: SrcSpan -> PsHeaderMessage -> a                -- #15053
+throwErr loc ps_msg =
+  let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage (PsHeaderMessage ps_msg)
   in throw $ mkSrcErr $ singleMessage msg
diff --git a/testsuite/tests/parser/should_fail/T19923a.hs b/testsuite/tests/parser/should_fail/T19923a.hs
new file mode 100644
index 0000000000..2e24cb5b6a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923a.hs
@@ -0,0 +1,2 @@
+{-# LANGUAGE T19923 #-}
+module ShouldFail where
diff --git a/testsuite/tests/parser/should_fail/T19923a.stderr b/testsuite/tests/parser/should_fail/T19923a.stderr
new file mode 100644
index 0000000000..223c670921
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923a.stderr
@@ -0,0 +1,2 @@
+
+T19923a.hs:1:14: error: Unsupported extension: T19923
diff --git a/testsuite/tests/parser/should_fail/T19923b.hs b/testsuite/tests/parser/should_fail/T19923b.hs
new file mode 100644
index 0000000000..92c5f4b768
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923b.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC T19923 #-}
+module ShouldFail where
diff --git a/testsuite/tests/parser/should_fail/T19923b.stderr b/testsuite/tests/parser/should_fail/T19923b.stderr
new file mode 100644
index 0000000000..564095bd2a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923b.stderr
@@ -0,0 +1,3 @@
+
+T19923b.hs:1:17: error:
+    unknown flag in  {-# OPTIONS_GHC #-} pragma: T19923
diff --git a/testsuite/tests/parser/should_fail/T19923c.hs b/testsuite/tests/parser/should_fail/T19923c.hs
new file mode 100644
index 0000000000..550f61e490
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923c.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC TemplateHaskell, #-}
+module ShouldFail where
diff --git a/testsuite/tests/parser/should_fail/T19923c.stderr b/testsuite/tests/parser/should_fail/T19923c.stderr
new file mode 100644
index 0000000000..373d959164
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19923c.stderr
@@ -0,0 +1,3 @@
+
+T19923c.hs:1:17: error:
+    unknown flag in  {-# OPTIONS_GHC #-} pragma: TemplateHaskell,
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 9975f6c5d7..82cddd8ed8 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -191,3 +191,6 @@ test('RecordDotSyntaxFail12', normal, compile_fail, [''])
 test('RecordDotSyntaxFail13', normal, compile_fail, [''])
 test('T19504', normal, compile_fail, [''])
 test('T19928', normal, compile_fail, [''])
+test('T19923a', normal, compile_fail, [''])
+test('T19923b', normal, compile_fail, [''])
+test('T19923c', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_fail/readFail046.stderr b/testsuite/tests/parser/should_fail/readFail046.stderr
index 5ac8b7091a..c3f3cab7a4 100644
--- a/testsuite/tests/parser/should_fail/readFail046.stderr
+++ b/testsuite/tests/parser/should_fail/readFail046.stderr
@@ -1,4 +1,5 @@
 
 readFail046.hs:1:14:
     Unsupported extension: ExistientialQuantification
-    Perhaps you meant ‘ExistentialQuantification’ or ‘NoExistentialQuantification’
+    Suggested fix:
+      Perhaps you meant ‘ExistentialQuantification’ or ‘NoExistentialQuantification’