diff options
Diffstat (limited to 'compiler/GHC/Parser/PostProcess.hs')
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 285 |
1 files changed, 160 insertions, 125 deletions
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 261967be85..e29a8314ff 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -58,7 +58,9 @@ module GHC.Parser.PostProcess ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat - checkPattern_hints, + checkPattern_details, + incompleteDoBlock, + ParseContext(..), checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, @@ -119,12 +121,13 @@ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic -import GHC.Types.Error ( GhcHint(..) ) +import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer -import GHC.Parser.Errors +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( isLexCon ) import GHC.Types.TyThing import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) @@ -138,16 +141,14 @@ import GHC.Data.OrdList import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.Bag +import GHC.Utils.Error import GHC.Utils.Misc import Data.Either import Data.List ( findIndex ) import Data.Foldable -import GHC.Driver.Flags ( WarningFlag(..) ) import qualified Data.Semigroup as Semi import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import qualified GHC.LanguageExtensions as LangExt import qualified GHC.Data.Strict as Strict import Control.Monad @@ -275,12 +276,14 @@ mkStandaloneKindSig loc lhs rhs anns = check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v - else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v) + else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $ + (PsErrUnexpectedQualifiedConstructor (unLoc v)) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v - _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) + _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $ + (PsErrMultipleNamesInStandaloneKindSignature vs) mkTyFamInstEqn :: SrcSpan -> HsOuterFamEqnTyVarBndrs GhcPs @@ -409,7 +412,8 @@ mkRoleAnnotDecl loc tycon roles anns let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in - addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role + addFatalError $ mkPlainErrorMsgEnvelope loc_role $ + (PsErrIllegalRoleName role nearby) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if @@ -429,7 +433,8 @@ fromSpecTyVarBndr bndr = case bndr of where check_spec :: Specificity -> SrcSpanAnnA -> P () check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc) + check_spec InferredSpec loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrInferredTypeVarNotAllowed -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ annBinds :: AddEpAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs @@ -508,7 +513,7 @@ cvBindsAndSigs fb = do -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -618,14 +623,14 @@ constructor, a type, or a context, we would need unlimited lookahead which -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] -tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName) +tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) tyConToDataCon (L loc tc) | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = Left $ PsError (PsErrNotADataCon tc) [] (locA loc) + = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) where occ = rdrNameOcc tc @@ -666,17 +671,21 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = fromDecl (L loc decl) = extraDeclErr (locA loc) decl extraDeclErr loc decl = - addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) wrongNameBindingErr loc decl = - addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) wrongNumberErr loc = - addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrEmptyWhereInPatSynDecl patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = - addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrRecordSyntaxInPatSynDecl pat) mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs @@ -817,7 +826,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} -eitherToP :: MonadP m => Either PsError a -> m a +eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing @@ -831,9 +840,11 @@ checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where - check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc) + check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) check (HsValArg ty) = chkParens [] emptyComments ty - check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp + check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ + (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddEpAnn]) @@ -853,7 +864,8 @@ checkTyVars pp_what equals_or_where tc tparms | isRdrTyVar tv = return (L (widenLocatedAn l an) (UserTyVar (addAnns ann an cs) () (L ltv tv))) chk _ _ t@(L loc _) - = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc) + = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) whereDots, equalsDots :: SDoc @@ -865,7 +877,8 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ + (PsErrIllegalDataTypeContext c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) @@ -895,13 +908,15 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc)) + (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrParseErrorOnInput occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrIllegalTraditionalRecordSyntax (ppr r)) return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for @@ -910,7 +925,8 @@ checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs]) -> P (Located ([AddEpAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax - unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span + unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $ + PsErrIllegalWhereInDataDecl return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. @@ -933,7 +949,7 @@ checkTyClHdr is_cls ty -- workaround to define '*' despite StarIsType go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix - = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l)) + = do { addPsMessage (locA l) PsWarnStarBinder ; let name = mkOccName tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix @@ -955,7 +971,8 @@ checkTyClHdr is_cls ty | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) go l _ _ _ _ - = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l + = addFatalError $ mkPlainErrorMsgEnvelope l $ + (PsErrMalformedTyOrClDecl ty) -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName @@ -1003,7 +1020,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ - addError $ PsError (err a) [] (getLocA a) + addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) -- | Validate the context constraints and break up a context into a list -- of predicates. @@ -1077,8 +1094,8 @@ checkImportDecl mPre mPost = do checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [GhcHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) -checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) +checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] @@ -1092,11 +1109,10 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args , pat_args = PrefixCon tyargs args } | not (null tyargs) = - add_hint TypeApplicationsInPatternsOnlyDataCons $ - patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) - | not (null args) && patIsRec c = - add_hint (SuggestExtension LangExt.RecursiveDo) $ - patFail (locA l) (ppr e) + patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs + | (not (null args) && patIsRec c) = do + ctx <- askParseContext + patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do @@ -1105,7 +1121,9 @@ checkPat loc (L _ (PatBuilderApp f e)) [] args = do checkPat loc (L l e) [] [] = do p <- checkAPat loc e return (L l p) -checkPat loc e _ _ = patFail (locA loc) (ppr e) +checkPat loc e _ _ = do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat (unLoc e) details) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do @@ -1130,7 +1148,7 @@ checkAPat loc e0 = do -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do - addError $ PsError PsErrAtInPatPos [] (getLocA op) + addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos return (WildPat noExtField) PatBuilderOpApp l (L cl c) r anns @@ -1147,7 +1165,9 @@ checkAPat loc e0 = do p <- checkLPat e return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) - _ -> patFail (locA loc) (ppr e0) + _ -> do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat e0 details) placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer @@ -1164,8 +1184,8 @@ checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) return (L l (fld { hfbRHS = p })) -patFail :: SrcSpan -> SDoc -> PV a -patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc +patFail :: SrcSpan -> PsMessage -> PV a +patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") @@ -1204,7 +1224,7 @@ checkFunBind :: SrcStrictness -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkFunBind strictness locF ann fun is_infix pats (L _ grhss) - = do ps <- runPV_hints param_hints (mapM checkLPat pats) + = do ps <- runPV_details extraDetails (mapM checkLPat pats) let match_span = noAnnSrcSpan $ locF cs <- getCommentsFor locF return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) @@ -1218,9 +1238,9 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where - param_hints - | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)] - | otherwise = [] + extraDetails + | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock + | otherwise = noParseContext makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs @@ -1260,11 +1280,11 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) = return lrdr checkValSigLhs lhs@(L l _) - = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l) + = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) - => (a -> Bool -> b -> Bool -> c -> PsErrorDesc) + => (a -> Bool -> b -> Bool -> c -> PsMessage) -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do @@ -1274,7 +1294,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr semiElse (unLoc elseExpr) loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) - unless doAndIfThenElse $ addError (PsError e [] loc) + unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) | otherwise = return () isFunLhs :: LocatedA (PatBuilder GhcPs) @@ -1390,7 +1410,7 @@ instance DisambInfixOp (HsExpr GhcPs) where instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l + mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole type AnnoBody b = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan @@ -1554,7 +1574,8 @@ instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ + PsErrOverloadedRecordDotInvalid mkHsLamPV l mg = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) @@ -1590,7 +1611,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsDoPV l Nothing stmts anns = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts) - mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l + mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) @@ -1605,7 +1626,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ @@ -1624,17 +1645,17 @@ instance DisambECP (HsCmd GhcPs) where rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a -cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc +cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do - when (null (hsLMatchPats matches)) $ addError $ PsError PsErrEmptyLambda [] l + when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda checkLamMatchGroup _ _ = return () instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do - addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c return (L l (hsHoleExpr noAnn)) ecpFromExp' = return mkHsProjUpdatePV l fields arg isPun anns = do @@ -1708,19 +1729,20 @@ instance DisambECP (HsExpr GhcPs) where mkHsSectionR_PV l op e = do cs <- getCommentsFor l return $ L l (SectionR (comment (realSrcSpan l) cs) op e) - mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l) + mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsAsPatPV l v e _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) + mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsLazyPatPV l e _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) + mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsBangPatPV l e _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l) + mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e - rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l) + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrUnallowedPragma prag) rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs @@ -1733,19 +1755,19 @@ type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanA instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l) - ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l) - mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l - mkHsLetPV l _ _ _ = addFatalError $ PsError PsErrLetInPat [] l - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c + ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e + mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat + mkHsLetPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = do cs <- getCommentsFor l let anns = EpAnn (spanAsAnchor l) [] cs return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns - mkHsCasePV l _ _ _ = addFatalError $ PsError PsErrCaseInPat [] l - mkHsLamCasePV l _ _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l + mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat + mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) @@ -1753,8 +1775,8 @@ instance DisambECP (PatBuilder GhcPs) where cs <- getCommentsFor (locA l) let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) - mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l - mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat + mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do @@ -1774,7 +1796,7 @@ instance DisambECP (PatBuilder GhcPs) where mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid else do cs <- getCommentsFor l r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs) @@ -1782,11 +1804,11 @@ instance DisambECP (PatBuilder GhcPs) where mkHsNegAppPV l (L lp p) anns = do lit <- case p of PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit) - _ -> patFail l (text "-" <> ppr p) + _ -> patFail l $ PsErrInPat p PEIP_NegApp cs <- getCommentsFor l let an = EpAnn (spanAsAnchor l) anns cs return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) - mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) + mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) mkHsViewPatPV l a b anns = do p <- checkLPat b cs <- getCommentsFor l @@ -1812,7 +1834,8 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 - -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc + -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedStringInPat lit) _ -> return () mkPatRec :: @@ -1829,7 +1852,8 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns , pat_args = RecCon (HsRecFields fs dd) } mkPatRec p _ _ = - addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p) + addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + (PsErrInvalidRecordCon (unLoc p)) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor. @@ -1892,7 +1916,8 @@ instance DisambTD DataConBuilder where panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs l_at ki = - addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at + addFatalError $ mkPlainErrorMsgEnvelope l_at $ + (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) mkHsOpTyPV lhs tc rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative @@ -1902,7 +1927,8 @@ instance DisambTD DataConBuilder where l = combineLocsA lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) = - addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l) + addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff @@ -1913,7 +1939,7 @@ instance DisambTD DataConBuilder where let l = combineLocsA (reLocA unpk) constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise = - do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk) + do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon return constr_stuff tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) @@ -1924,7 +1950,8 @@ tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t = - addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t) + addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $ + (PsErrInvalidDataCon (unLoc t)) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2373,7 +2400,7 @@ checkPrecP checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () - | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l + | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) where -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR @@ -2391,10 +2418,12 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps)) + then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $ + PsErrOverloadedRecordDotInvalid else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns - | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc + | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ + PsErrDotsInRecordUpdate | otherwise = mkRdrRecordUpd overloaded_update exp fs anns mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) @@ -2408,7 +2437,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do case overloaded_on of False | not $ null ps -> -- A '.' was found in an update and OverloadedRecordUpdate isn't on. - addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc) + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled False -> -- This is just a regular record update. return RecordUpd { @@ -2422,7 +2451,8 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do ] if not $ null qualifiedFields then - addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) + addFatalError $ mkPlainErrorMsgEnvelope (getLoc (head qualifiedFields)) $ + PsErrOverloadedRecordUpdateNoQualifiedFields else -- This is a RecordDotSyntax update. return RecordUpd { rupd_ext = anns @@ -2505,7 +2535,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of - Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc + Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + PsErrMalformedEntityString Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in @@ -2646,12 +2677,14 @@ mkModuleImpExp anns (L l specname) subs = do in (\newName -> IEThingWith ann (L l newName) pos ies) <$> nameT - else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l) + else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPatSynExport where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l) + then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrVarForTyCon name) else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln @@ -2668,7 +2701,8 @@ mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space -> P (LocatedN RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name) + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $ + PsErrIllegalExplicitNamespace return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs]) @@ -2678,7 +2712,7 @@ checkImportSpec ie@(L _ specs) = (l:_) -> importSpecError (locA l) where importSpecError l = - addFatalError $ PsError PsErrIllegalImportBundleForm [] l + addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm -- In the correct order mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) @@ -2699,21 +2733,24 @@ isImpExpQcWildcard _ = False warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span = - addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span) + addPsMessage span PsWarnImportPreQualified failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc +failOpNotEnabledImportQualifiedPost loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc +failOpImportQualifiedTwice loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice warnStarIsType :: SrcSpan -> P () -warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span) +warnStarIsType span = addPsMessage span PsWarnStarIsType failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit - ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) } + ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrOpFewArgs (StarIsType star_is_type) op) } ----------------------------------------------------------------------------- -- Misc utils @@ -2721,13 +2758,13 @@ failOpFewArgs (L loc op) = data PV_Context = PV_Context { pv_options :: ParserOpts - , pv_hints :: [GhcHint] -- See Note [Parser-Validator Hint] + , pv_details :: ParseContext -- See Note [Parser-Validator Details] } data PV_Accum = PV_Accum - { pv_warnings :: Bag PsWarning - , pv_errors :: Bag PsError + { pv_warnings :: Messages PsMessage + , pv_errors :: Messages PsMessage , pv_header_comments :: Strict.Maybe [LEpaComment] , pv_comment_q :: [LEpaComment] } @@ -2769,15 +2806,18 @@ instance Monad PV where PV_Failed acc' -> PV_Failed acc' runPV :: PV a -> P a -runPV = runPV_hints [] +runPV = runPV_details noParseContext -runPV_hints :: [GhcHint] -> PV a -> P a -runPV_hints hints m = +askParseContext :: PV ParseContext +askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details + +runPV_details :: ParseContext -> PV a -> P a +runPV_details details m = P $ \s -> let pv_ctx = PV_Context { pv_options = options s - , pv_hints = hints } + , pv_details = details } pv_acc = PV_Accum { pv_warnings = warnings s , pv_errors = errors s @@ -2792,22 +2832,14 @@ runPV_hints hints m = PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: GhcHint -> PV a -> PV a -add_hint hint m = - let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in - PV (\ctx acc -> unPV m (modifyHint ctx) acc) - instance MonadP PV where - addError err@(PsError e hints loc) = - PV $ \ctx acc -> - let err' | null (pv_hints ctx) = err - | otherwise = PsError e (hints ++ pv_hints ctx) loc - in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} () - addWarning option w = - PV $ \ctx acc -> - if warnopt option (pv_options ctx) - then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} () - else PV_Ok acc () + addError err = + PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} () + addWarning w = + PV $ \_ctx acc -> + -- No need to check for the warning flag to be set, GHC will correctly discard suppressed + -- diagnostics. + PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () addFatalError err = addError err >> PV (const PV_Failed) getBit ext = @@ -2834,9 +2866,9 @@ instance MonadP PV where pv_comment_q = comment_q' } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) -{- Note [Parser-Validator Hint] +{- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parametrized by a hint for error messages, which can be set +A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984. Consider this example, where the user has forgotten a 'do': @@ -2863,16 +2895,17 @@ Note that this fragment is parsed as a pattern: _ -> result -We attempt to detect such cases and add a hint to the error messages: +We attempt to detect such cases and add a hint to the diagnostic messages: T984.hs:6:9: Parse error in pattern: case () of { _ -> result } Possibly caused by a missing 'do'? -The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed -as the 'pv_hints' field 'PV_Context'. When validating in a context other than -'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has -no effect on the error messages. +The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed +out of the 'ParseContext', which are read by functions like 'patFail' when +constructing the 'PsParseErrorInPatDetails' data structure. When validating in a +context other than 'bindpat' (a pattern to the left of <-), we set the +details to 'noParseContext' and it has no effect on the diagnostic messages. -} @@ -2881,7 +2914,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ - addError $ PsError (PsErrIllegalBangPattern e) [] span + addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) -> [AddEpAnn] @@ -2907,7 +2940,7 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do cs <- getCommentsFor (locA l) return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} _ = - addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l) + addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a mkSumOrTuplePat :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn] @@ -2923,7 +2956,8 @@ mkSumOrTuplePat l boxity (Tuple ps) anns = do -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. toTupPat p = case p of - Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l) + Left _ -> addFatalError $ + mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat Right p' -> checkLPat p' -- Sum @@ -2933,7 +2967,8 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs return $ L l (PatBuilderPat (SumPat an p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} _ = - addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l) + addFatalError $ + mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = |