diff options
Diffstat (limited to 'compiler/parser')
-rw-r--r-- | compiler/parser/Lexer.x | 85 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 30 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 61 |
3 files changed, 92 insertions, 84 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 9eed1e6572..5fb48eba36 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -51,13 +51,13 @@ module Lexer ( Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags, getRealSrcLoc, getPState, withThisPackage, - failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + failLocMsgP, srcParseFail, + getErrorMessages, getMessages, popContext, pushModuleContext, setLastToken, setSrcLoc, activeContext, nextIsEOF, getLexState, popLexState, pushLexState, ExtBits(..), getBit, - addWarning, addError, + addWarning, addError, addFatalError, lexTokenStream, addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, commentToAnnotation @@ -977,7 +977,7 @@ hopefully_open_brace span buf len Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len - else failSpanMsgP (RealSrcSpan span) (text "Missing block") + else addFatalError (RealSrcSpan span) (text "Missing block") pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -1923,17 +1923,18 @@ data LayoutContext | Layout !Int !GenSemic deriving Show +-- | The result of running a parser. data ParseResult a - = POk PState a - | PFailed - (DynFlags -> Messages) -- A function that returns warnings that - -- accumulated during parsing, including - -- the warnings related to tabs. - SrcSpan -- The start and end of the text span related - -- to the error. Might be used in environments - -- which can show this span, e.g. by - -- highlighting it. - MsgDoc -- The error message + = POk -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and produced a result. Use 'getMessages' + -- to check for accumulated warnings and non-fatal errors. + PState -- ^ The resulting parsing state. Can be used to resume parsing. + a -- ^ The resulting value. + | PFailed -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and failed. + PState -- ^ The parsing state right before failure, including the fatal + -- parse error. 'getMessages' and 'getErrorMessages' must return + -- a non-empty bag of errors. -- | Test whether a 'WarningFlag' is set warnopt :: WarningFlag -> ParserFlags -> Bool @@ -2003,6 +2004,7 @@ data ALRLayout = ALRLayoutLet | ALRLayoutOf | ALRLayoutDo +-- | The parsing monad, isomorphic to @StateT PState Maybe@. newtype P a = P { unP :: PState -> ParseResult a } instance Functor P where @@ -2019,7 +2021,7 @@ instance Monad P where #endif instance MonadFail.MonadFail P where - fail = failP + fail = failMsgP returnP :: a -> P a returnP a = a `seq` (P $ \s -> POk s a) @@ -2028,27 +2030,16 @@ thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> case m s of POk s1 a -> (unP (k a)) s1 - PFailed warnFn span err -> PFailed warnFn span err - -failP :: String -> P a -failP msg = - P $ \s -> - PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg) + PFailed s1 -> PFailed s1 failMsgP :: String -> P a -failMsgP msg = - P $ \s -> - PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg) +failMsgP msg = do + pState <- getPState + addFatalError (RealSrcSpan (last_loc pState)) (text msg) failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a failLocMsgP loc1 loc2 str = - P $ \s -> - PFailed (getMessages s) (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) - -failSpanMsgP :: SrcSpan -> SDoc -> P a -failSpanMsgP span msg = - P $ \s -> - PFailed (getMessages s) span msg + addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) getPState :: P PState getPState = P $ \s -> POk s s @@ -2477,6 +2468,18 @@ mkPStatePure options buf loc = annotations_comments = [] } +-- | Add a non-fatal error. Use this when the parser can produce a result +-- despite the error. +-- +-- For example, when GHC encounters a @forall@ in a type, +-- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ +-- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to +-- the accumulator. +-- +-- Control flow wise, non-fatal errors act like warnings: they are added +-- to the accumulator and parsing continues. This allows GHC to report +-- more than one parse error per file. +-- addError :: SrcSpan -> SDoc -> P () addError srcspan msg = P $ \s@PState{messages=m} -> @@ -2488,6 +2491,14 @@ addError srcspan msg in (ws, es') in POk s{messages=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 :: SrcSpan -> SDoc -> P a +addFatalError span msg = + addError span msg >> P PFailed + +-- | Add a warning to the accumulator. +-- Use 'getMessages' to get the accumulated warnings. addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=m, options=o} -> @@ -2522,6 +2533,14 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d = in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf +-- | Get a bag of the errors that have been accumulated so far. +-- Does not take -Werror into account. +getErrorMessages :: PState -> DynFlags -> ErrorMessages +getErrorMessages PState{messages=m} d = + let (_, es) = m d in es + +-- | Get the warnings and errors accumulated so far. +-- Does not take -Werror into account. getMessages :: PState -> DynFlags -> Messages getMessages p@PState{messages=m} d = let (ws, es) = m d @@ -2542,7 +2561,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, (_:tl) -> POk s{ context = tl } () [] -> - PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len) + unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s -- Push a new layout context at the indentation of the last token read. pushCurrentContext :: GenSemic -> P () @@ -2602,7 +2621,7 @@ srcParseErr options buf len srcParseFail :: P a srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, last_loc = last_loc } -> - PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len) + unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s -- A lexical error is reported at a particular position in the source file, -- not over a token range. diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 69114ee9c2..78f1013151 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -973,13 +973,13 @@ maybe_safe :: { ([AddAnn],Bool) } | {- empty -} { ([],False) } maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } - : STRING {% let pkgFS = getSTRING $1 in - if looksLikePackageName (unpackFS pkgFS) - then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) - else parseErrorSDoc (getLoc $1) $ vcat [ - text "parse error" <> colon <+> quotes (ppr pkgFS), + : STRING {% do { let { pkgFS = getSTRING $1 } + ; unless (looksLikePackageName (unpackFS pkgFS)) $ + addError (getLoc $1) $ vcat [ + text "Parse error" <> colon <+> quotes (ppr pkgFS), text "Version number or non-alphanumeric" <+> - text "character in package name"] } + text "character in package name"] + ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } | {- empty -} { ([],Nothing) } optqualified :: { ([AddAnn],Bool) } @@ -3668,7 +3668,7 @@ getSCC lt = do let s = getSTRING lt err = "Spaces are not allowed in SCCs" -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s - then failSpanMsgP (getLoc lt) (text err) + then addFatalError (getLoc lt) (text err) else return s -- Utilities for combining source spans @@ -3756,23 +3756,15 @@ fileSrcSpan = do hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit - unless mwiEnabled $ parseErrorSDoc span $ + unless mwiEnabled $ addError span $ text "Multi-way if-expressions need MultiWayIf turned on" --- Hint about if usage for beginners -hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs) -hintIf span msg = do - mwiEnabled <- getBit MultiWayIfBit - if mwiEnabled - then parseErrorSDoc span $ text $ "parse error in if statement" - else parseErrorSDoc span $ text $ "parse error in if statement: "++msg - -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit - unless (forall || rulePrag) $ parseErrorSDoc (getLoc tok) $ vcat + unless (forall || rulePrag) $ addError (getLoc tok) $ vcat [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type" , text "Perhaps you intended to use RankNTypes or a similar language" , text "extension to enable explicit-forall syntax:" <+> @@ -3803,13 +3795,13 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit if thQuotes - then parseErrorSDoc span $ vcat + then addFatalError span $ vcat [ text "Parser error on `''`" , text "Character literals may not be empty" , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," , text "but the type variable or constructor is missing" ] - else parseErrorSDoc span $ vcat + else addFatalError span $ vcat [ text "Parser error on `''`" , text "Character literals may not be empty" ] diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ddbd885576..606e2e7d6b 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -60,7 +60,7 @@ module RdrHsSyn ( checkRuleTyVarBndrNames, checkRecordSyntax, checkEmptyGADTs, - parseErrorSDoc, hintBangPat, + addFatalError, hintBangPat, TyEl(..), mergeOps, mergeDataCon, -- Help with processing exports @@ -357,7 +357,7 @@ mkRoleAnnotDecl loc tycon roles let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in - parseErrorSDoc loc_role + addFatalError loc_role (text "Illegal role name" <+> quotes (ppr role) $$ suggestions nearby) parse_role _ = panic "parse_role: Impossible Match" @@ -427,7 +427,7 @@ cvBindsAndSigs fb = go (fromOL fb) DocD _ d -> return (bs, ss, ts, tfis, dfis, cL l d : docs) SpliceD _ d - -> parseErrorSDoc l $ + -> addFatalError l $ hang (text "Declaration splices are allowed only" <+> text "at the top level:") 2 (ppr d) @@ -620,23 +620,23 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = fromDecl (dL->L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = - parseErrorSDoc loc $ + addFatalError loc $ text "pattern synonym 'where' clause must contain a single binding:" $$ ppr decl wrongNameBindingErr loc decl = - parseErrorSDoc loc $ + addFatalError loc $ text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> quotes (ppr patsyn_name) $$ ppr decl wrongNumberErr loc = - parseErrorSDoc loc $ + addFatalError loc $ text "pattern synonym 'where' clause cannot be empty" $$ text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = - parseErrorSDoc loc $ + addFatalError loc $ text "record syntax not supported for pattern synonym declarations:" $$ ppr pat @@ -816,7 +816,7 @@ checkTyVarsP pp_what equals_or_where tc tparms eitherToP :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad -eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc +eitherToP (Left (loc, doc)) = addFatalError loc doc eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] @@ -915,7 +915,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (dL->L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) - (parseErrorSDoc loc (text $ "parse error on input " + (addFatalError loc (text $ "parse error on input " ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" @@ -977,7 +977,7 @@ checkTyClHdr is_cls ty | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) go l _ _ _ _ - = parseErrorSDoc l (text "Malformed head of type or class declaration:" + = addFatalError l (text "Malformed head of type or class declaration:" <+> ppr ty) -- | Yield a parse error if we have a function applied directly to a do block @@ -1087,7 +1087,7 @@ checkAPat msg loc e0 = do EWildPat _ -> return (WildPat noExt) HsVar _ x -> return (VarPat noExt x) HsLit _ (HsStringPrim _ _) -- (#13260) - -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" + -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) HsLit _ l -> return (LitPat noExt l) @@ -1137,7 +1137,7 @@ checkAPat msg loc e0 = do | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | (dL->L _ (Present _ e)) <- es] return (TuplePat noExt ps b) - | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" + | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:" $$ ppr e0) ExplicitSum _ alt arity expr -> do @@ -1168,7 +1168,7 @@ checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) return (cL l (fld { hsRecFieldArg = p })) patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a -patFail msg loc e = parseErrorSDoc loc err +patFail msg loc e = addFatalError loc err where err = text "Parse error in pattern:" <+> ppr e $$ msg @@ -1250,7 +1250,7 @@ checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) = return lrdr checkValSigLhs lhs@(dL->L l _) - = parseErrorSDoc l ((text "Invalid type signature:" <+> + = addFatalError l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) where @@ -1482,7 +1482,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs bt = HsBangTy noExt strictMark a ; addAnnsAt bl anns ; return (cL bl bt) } - else parseErrorSDoc l unpkError + else addFatalError l unpkError where unpkSDoc = case unpkSrc of NoSourceText -> ppr unpk @@ -1951,9 +1951,9 @@ checkCmdGRHS = locMap $ const convert cmdFail :: SrcSpan -> HsExpr GhcPs -> P a -cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) +cmdFail loc e = addFatalError loc (text "Parse error in command:" <+> ppr e) cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a -cmdStmtFail loc e = parseErrorSDoc loc +cmdStmtFail loc e = addFatalError loc (text "Parse error in command statement:" <+> ppr e) --------------------------------------------------------------------------- @@ -1968,7 +1968,7 @@ checkPrecP checkPrecP (dL->L l (_,i)) (dL->L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () - | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) + | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) where specialOp op = unLoc op `elem` [ eqTyCon_RDR , getRdrName funTyCon ] @@ -1983,7 +1983,7 @@ mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd) - | Just dd_loc <- dd = parseErrorSDoc dd_loc (text "You cannot use `..' in a record update") + | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs @@ -2051,7 +2051,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of - Nothing -> parseErrorSDoc loc (text "Malformed entity string") + Nothing -> addFatalError loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in @@ -2189,13 +2189,13 @@ mkModuleImpExp (dL->L l specname) subs = in (\newName -> IEThingWith noExt (cL l newName) pos ies []) <$> nameT - else parseErrorSDoc l + else addFatalError l (text "Illegal export form (use PatternSynonyms to enable)") where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then parseErrorSDoc l + then addFatalError l (text "Expecting a type constructor but found a variable," <+> quotes (ppr name) <> text "." $$ if isSymOcc $ rdrNameOcc name @@ -2230,7 +2230,7 @@ checkImportSpec ie@(dL->L _ specs) = (l:_) -> importSpecError l where importSpecError l = - parseErrorSDoc l + addFatalError l (text "Illegal import form, this syntax can only be used to bundle" $+$ text "pattern synonyms with types in module exports.") @@ -2275,39 +2275,36 @@ failOpFewArgs :: Located RdrName -> P a failOpFewArgs (dL->L loc op) = do { star_is_type <- getBit StarIsTypeBit ; let msg = too_few $$ starInfo star_is_type op - ; parseErrorSDoc loc msg } + ; addFatalError loc msg } where too_few = text "Operator applied to too few arguments:" <+> ppr op failOpDocPrev :: SrcSpan -> P a -failOpDocPrev loc = parseErrorSDoc loc msg +failOpDocPrev loc = addFatalError loc msg where msg = text "Unexpected documentation comment." failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a -failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg +failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg where msg = text "Strictness annotation applied to a compound type." $$ text "Did you mean to add parentheses?" $$ nest 2 (ppr str <> parens (ppr ty)) failOpStrictnessPosition :: Located SrcStrictness -> P a -failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg +failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg where msg = text "Strictness annotation cannot appear in this position." ----------------------------------------------------------------------------- -- Misc utils -parseErrorSDoc :: SrcSpan -> SDoc -> P a -parseErrorSDoc span s = failSpanMsgP span s - -- | Hint about bang patterns, assuming @BangPatterns@ is off. hintBangPat :: SrcSpan -> HsExpr GhcPs -> P () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ - parseErrorSDoc span + addFatalError span (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) data SumOrTuple @@ -2323,7 +2320,7 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) mkSumOrTuple Unboxed _ (Sum alt arity e) = return (ExplicitSum noExt alt arity e) mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = - parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 + addFatalError l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc |