diff options
author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-06-01 09:57:09 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-04 12:43:41 -0400 |
commit | f1b748b491dc49cfbe698cd790610ca21ae21ee7 (patch) | |
tree | d6ffa50d52e96217c1893a89adc840cbb0a5c5fa | |
parent | 44d131af861e58b17f52c89da77a7ceeeba392c0 (diff) | |
download | haskell-f1b748b491dc49cfbe698cd790610ca21ae21ee7.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Driver/Errors.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Errors/Types.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 41 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 24 | ||||
-rw-r--r-- | compiler/GHC/Parser/Header.hs | 27 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923a.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923a.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923b.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923b.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923c.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19923c.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/all.T | 3 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/readFail046.stderr | 3 |
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’ |