diff options
Diffstat (limited to 'compiler/GHC/Parser/Lexer.x')
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 165 |
1 files changed, 96 insertions, 69 deletions
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index f9494afa6a..10c9f2042f 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -75,6 +75,7 @@ module GHC.Parser.Lexer ( commentToAnnotation, HdkComment(..), warnopt, + addPsMessage ) where import GHC.Prelude @@ -101,17 +102,17 @@ import Data.Map (Map) import qualified Data.Map as Map -- compiler -import GHC.Data.Bag +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.StringBuffer import GHC.Data.FastString +import GHC.Types.Error hiding ( getErrorMessages, getMessages ) import GHC.Types.Unique.FM import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) -import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) @@ -121,7 +122,8 @@ import GHC.Parser.CharClass import GHC.Parser.Annotation import GHC.Driver.Flags -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () } -- ----------------------------------------------------------------------------- @@ -362,7 +364,7 @@ $tab { warnTab } } <0,option_prags> { - "{-#" { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma + "{-#" { warnThen PsWarnUnrecognisedPragma (nested_comment lexToken) } } @@ -1143,7 +1145,8 @@ hopefully_open_brace span buf len Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len - else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span) + else addFatalError $ + mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -1528,7 +1531,10 @@ docCommentEnd input commentAcc docType buf span = do commentEnd lexToken input commentAcc finalizeComment buf span errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) []) +errBrace (AI end _) span = + failLocMsgP (realSrcSpanStart span) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) open_brace, close_brace :: Action open_brace span _str _len = do @@ -1587,7 +1593,7 @@ varid span buf len = lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState - addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState)) + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase return ITlcase _ -> return ITcase maybe_layout keyword @@ -1619,8 +1625,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False varsym_prefix :: Action varsym_prefix = sym $ \span exts s -> let warnExtConflict errtok = - do { addWarning Opt_WarnOperatorWhitespaceExtConflict $ - PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok + do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) ; return (ITvarsym s) } in if | s == fsLit "@" -> @@ -1646,19 +1651,19 @@ varsym_prefix = sym $ \span exts s -> | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_Prefix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action varsym_suffix = sym $ \span _ s -> - if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT []) + if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_Suffix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] @@ -1668,9 +1673,9 @@ varsym_tight_infix = sym $ \span exts s -> | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) | s == fsLit "." -> return ITdot | otherwise -> - do { addWarning Opt_WarnOperatorWhitespace $ - PsWarnOperatorWhitespace (mkSrcSpanPs span) s - OperatorWhitespaceOccurrence_TightInfix + do { addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix)) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] @@ -1726,7 +1731,8 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrNumUnderscores NumUnderscore_Integral + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int @@ -1767,7 +1773,8 @@ tok_frac drop f span buf len = do let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState - addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrNumUnderscores NumUnderscore_Float + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token @@ -1946,7 +1953,9 @@ lex_string_prag_comment mkTok span _buf _len = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) []) + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) -- ----------------------------------------------------------------------------- -- Strings & Chars @@ -1983,7 +1992,8 @@ lex_string s = do setInput i when (any (> '\xFF') s') $ do pState <- getPState - let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState)) + let msg = PsErrPrimStringInvalidChar + let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg addError err return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> @@ -2246,7 +2256,7 @@ quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput reportLexError start (psRealLoc end) buf - (\k -> PsError (PsErrLexer LexUnterminatedQQ k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) -- ----------------------------------------------------------------------------- -- Warnings @@ -2256,9 +2266,9 @@ warnTab srcspan _buf _len = do addTabWarning (psRealSpan srcspan) lexToken -warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action -warnThen flag warning action srcspan buf len = do - addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Strict.Nothing)) +warnThen :: PsMessage -> Action -> Action +warnThen warning action srcspan buf len = do + addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -2310,6 +2320,10 @@ warnopt f options = f `EnumSet.member` pWarningFlags options data ParserOpts = ParserOpts { pWarningFlags :: EnumSet WarningFlag -- ^ enabled warning flags , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + , pMakePsMessage :: SrcSpan -> PsMessage -> MsgEnvelope PsMessage + -- ^ The function to be used to construct diagnostic messages. + -- The idea is to partially-apply 'mkParserMessage' upstream, to + -- avoid the dependency on the 'DynFlags' in the Lexer. } -- | Haddock comment as produced by the lexer. These are accumulated in @@ -2324,10 +2338,9 @@ data HdkComment data PState = PState { buffer :: StringBuffer, options :: ParserOpts, - warnings :: Bag PsWarning, - errors :: Bag PsError, - tab_first :: Strict.Maybe RealSrcSpan, - -- pos of first tab warning in the file + warnings :: Messages PsMessage, + errors :: Messages PsMessage, + tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Word, -- number of tab warnings in the file last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token prev_loc :: PsSpan, -- pos of previous token, including comments, @@ -2414,12 +2427,12 @@ thenP :: P a -> (a -> P b) -> P b POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> PsError) -> P a +failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a failMsgP f = do pState <- getPState addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a failLocMsgP loc1 loc2 f = addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) @@ -2757,6 +2770,7 @@ data ExtBits mkParserOpts :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens @@ -2768,11 +2782,12 @@ mkParserOpts -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts' -mkParserOpts warningFlags extensionFlags +mkParserOpts warningFlags extensionFlags mkMessage safeImports isHaddock rawTokStream usePosPrags = ParserOpts { - pWarningFlags = warningFlags - , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + pWarningFlags = warningFlags + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + , pMakePsMessage = mkMessage } where safeHaskellBit = SafeHaskellBit `setBitIf` safeImports @@ -2845,8 +2860,8 @@ initParserState options buf loc = PState { buffer = buf, options = options, - errors = emptyBag, - warnings = emptyBag, + errors = emptyMessages, + warnings = emptyMessages, tab_first = Strict.Nothing, tab_count = 0, last_tk = Strict.Nothing, @@ -2893,15 +2908,15 @@ class Monad m => MonadP m where -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. -- - addError :: PsError -> m () + addError :: MsgEnvelope PsMessage -> m () -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings. - addWarning :: WarningFlag -> PsWarning -> m () + addWarning :: MsgEnvelope PsMessage -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state. - addFatalError :: PsError -> m a + addFatalError :: MsgEnvelope PsMessage -> m a -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool @@ -2917,12 +2932,13 @@ class Monad m => MonadP m where instance MonadP P where addError err - = P $ \s -> POk s { errors = err `consBag` errors s} () + = P $ \s -> POk s { errors = err `addMessage` errors s} () - addWarning option w - = P $ \s -> if warnopt option (options s) - then POk (s { warnings = w `consBag` warnings s }) () - else POk s () + -- If the warning is meant to be suppressed, GHC will assign + -- a `SevIgnore` severity and the message will be discarded, + -- so we can simply add it no matter what. + addWarning w + = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () addFatalError err = addError err >> P PFailed @@ -2964,6 +2980,11 @@ getFinalCommentsFor _ = return emptyComments getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos +addPsMessage :: SrcSpan -> PsMessage -> P () +addPsMessage srcspan msg = do + opts <- options <$> getPState + addWarning ((pMakePsMessage opts) srcspan msg) + addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> @@ -2976,12 +2997,12 @@ addTabWarning srcspan -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account. -getErrorMessages :: PState -> Bag PsError +getErrorMessages :: PState -> Messages PsMessage getErrorMessages p = errors p -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account. -getMessages :: PState -> (Bag PsWarning, Bag PsError) +getMessages :: PState -> (Messages PsMessage, Messages PsMessage) getMessages p = let ws = warnings p -- we add the tabulation warning on the fly because @@ -2989,9 +3010,12 @@ getMessages p = ws' = case tab_first p of Strict.Nothing -> ws Strict.Just tf -> - PsWarnTab (RealSrcSpan tf Strict.Nothing) (tab_count p) - `consBag` ws + let msg = mkMsg (RealSrcSpan tf Strict.Nothing) $ + (PsWarnTab (tab_count p)) + in msg `addMessage` ws in (ws', errors p) + where + mkMsg = pMakePsMessage . options $ p getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx @@ -3037,8 +3061,8 @@ srcParseErr -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token -> SrcSpan - -> PsError -srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc + -> MsgEnvelope PsMessage +srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) where token = lexemeToString (offsetBytes (-len) buf) len pattern_ = decodePrevNChars 8 buf @@ -3047,16 +3071,13 @@ srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc mdoInLast100 = "mdo" `isInfixOf` last100 th_enabled = ThQuotesBit `xtest` pExtsBitmap options ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options - - sug c s = if c then Just s else Nothing - sug_th = sug (not th_enabled && token == "$") (SuggestExtension LangExt.TemplateHaskell) -- #7396 - sug_rdo = sug (token == "<-" && mdoInLast100) (SuggestExtension LangExt.RecursiveDo) - sug_do = sug (token == "<-" && not mdoInLast100) SuggestMissingDo - sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849 - sug_pat = sug (not ps_enabled && pattern_ == "pattern ") (SuggestExtension LangExt.PatternSynonyms) -- #12429 - suggests - | null token = [] - | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat] + details = PsErrParseDetails { + ped_th_enabled = th_enabled + , ped_do_in_last_100 = doInLast100 + , ped_mdo_in_last_100 = mdoInLast100 + , ped_pat_syn_enabled = ps_enabled + , ped_pattern_parsed = pattern_ == "pattern " + } -- Report a parse failure, giving the span of the previous token as -- the location of the error. This is the entry point for errors @@ -3073,7 +3094,7 @@ lexError e = do loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc (psRealLoc end) buf - (\k -> PsError (PsErrLexer e k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a @@ -3188,8 +3209,9 @@ alternativeLayoutRuleToken t -- This next case is to handle a transitional issue: (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Where) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3198,8 +3220,9 @@ alternativeLayoutRuleToken t -- This next case is to handle a transitional issue: (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> - do addWarning Opt_WarnAlternativeLayoutRuleTransitional - $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Pipe) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close @@ -3322,7 +3345,7 @@ lexToken = do return (L span ITeof) AlexError (AI loc2 buf) -> reportLexError (psRealLoc loc1) (psRealLoc loc2) buf - (\k -> PsError (PsErrLexer LexError k) []) + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) AlexSkip inp2 _ -> do setInput inp2 lexToken @@ -3336,7 +3359,11 @@ lexToken = do if (isComment lt') then setLastComment lt else setLastTk lt return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a +reportLexError :: RealSrcLoc + -> RealSrcLoc + -> StringBuffer + -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage) + -> P a reportLexError loc1 loc2 buf f | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) | otherwise = |