diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 25d7f4648d4355a7d0bb0c668b16af9adb76b374..929650093476be77888f2a646a385e5055632cd5 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1030,7 +1030,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ check . mapMaybe (hsTyVarLName . unLoc)
where check (L loc (Unqual occ)) =
when (occNameFS occ `elem` [fsLit "family",fsLit "role"])
- (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+ (addError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrParseErrorOnInput occ))
check _ = panic "checkRuleTyVarBndrNames"
@@ -1475,17 +1475,17 @@ checkPatBind _loc lhs (L _ grhss) mult = do
checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
checkValSigLhs lhs@(L l lhs_expr) =
case lhs_expr of
- HsVar _ lrdr@(L _ v) -> check_var v lrdr
- _ -> make_err PsErrInvalidTypeSig_Other
+ HsVar _ lrdr -> check_var lrdr
+ _ -> make_err noAnn PsErrInvalidTypeSig_Other
where
- check_var v lrdr
- | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified
- | isDataOcc occ_n = make_err PsErrInvalidTypeSig_DataCon
+ check_var lrdr@(L ll v)
+ | not (isUnqual v) = make_err ll PsErrInvalidTypeSig_Qualified
+ | isDataOcc occ_n = make_err ll PsErrInvalidTypeSig_DataCon
| otherwise = pure lrdr
where occ_n = rdrNameOcc v
- make_err reason = addFatalError $
- mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs)
-
+ make_err ll reason = do
+ addError $ mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs)
+ return (L ll badHsExprRdrName)
checkDoAndIfThenElse
:: (Outputable a, Outputable b, Outputable c)
@@ -1631,7 +1631,9 @@ 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 l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole
+ mkHsInfixHolePV (L l _) = do
+ addError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole
+ return $ L l (badHsExprRdrName)
type AnnoBody b
= ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO
@@ -1908,11 +1910,11 @@ instance DisambECP (HsExpr GhcPs) where
type Body (HsExpr GhcPs) = HsExpr
ecpFromCmd' (L l c) = do
addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c
- return (L l (hsHoleExpr noAnn))
+ return (L l badHsExpr)
ecpFromExp' = return
ecpFromPat' p@(L l _) = do
addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p
- return (L l (hsHoleExpr noAnn))
+ return (L l badHsExpr)
mkHsProjUpdatePV l fields arg isPun anns = do
!cs <- getCommentsFor l
return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns
@@ -1982,11 +1984,11 @@ instance DisambECP (HsExpr GhcPs) where
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e)
mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
- >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
+ >> return (L (noAnnSrcSpan l) badHsExpr)
mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)
- >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
+ >> return (L (noAnnSrcSpan l) badHsExpr)
mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)
- >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
+ >> return (L (noAnnSrcSpan l) badHsExpr)
mkSumOrTuplePV = mkSumOrTupleExpr
mkHsEmbTyPV l toktype ty =
return $ L (noAnnSrcSpan l) $
@@ -2025,7 +2027,9 @@ instance DisambECP (PatBuilder GhcPs) where
addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e
return $ L l (PatBuilderPat badHsPat)
ecpFromPat' (L l p) = return $ L l (PatBuilderPat p)
- mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
+ mkHsLetPV l _ _ _ _ = do
+ addError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
@@ -2033,17 +2037,25 @@ instance DisambECP (PatBuilder GhcPs) where
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[])
- mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)
+ mkHsLamPV l lam_variant _ _ = do
+ addError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
- mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
+ mkHsCasePV l _ _ _ = do
+ addError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsAppTypePV l p at t = do
!cs <- getCommentsFor (locA l)
return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
- mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
- mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+ mkHsIfPV l _ _ _ _ _ _ = do
+ addError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
+ mkHsDoPV l _ _ _ _ = do
+ addError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
@@ -2067,7 +2079,9 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do
let (fs, ps) = partitionEithers fbinds
if not (null ps)
- then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
+ then do
+ addError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
+ return $ L (noAnnSrcSpan l) (PatBuilderPat badHsPat)
else do
!cs <- getCommentsFor l
r <- mkPatRec a (mk_rec_fields fs ddLoc) anns
@@ -2302,10 +2316,10 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields x fs dd) anns
, pat_con = c
, pat_args = RecCon (HsRecFields x fs dd)
}
-mkPatRec p _ _ =
- addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
+mkPatRec p _ _ = do
+ addError $ mkPlainErrorMsgEnvelope (getLocA p) $
(PsErrInvalidRecordCon (unLoc p))
-
+ return (PatBuilderPat badHsPat)
-- | Disambiguate constructs that may appear when we do not know
-- ahead of time whether we are parsing a type or a newtype/data constructor.
--
@@ -2876,7 +2890,7 @@ checkPrecP
checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
- | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)
+ | otherwise = addError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)
where
-- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
specialOp op = unLoc op == getRdrName unrestrictedFunTyCon
@@ -2893,12 +2907,15 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
= do
let (fs, ps) = partitionEithers fbinds
case ps of
- p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
- PsErrOverloadedRecordDotInvalid
+ p:_ -> do
+ addError $ mkPlainErrorMsgEnvelope (getLocA p) PsErrOverloadedRecordDotInvalid
+ return badHsExpr
_ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
- | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $
- PsErrDotsInRecordUpdate
+ | Just dd_loc <- dd = do
+ addError $ mkPlainErrorMsgEnvelope dd_loc PsErrDotsInRecordUpdate
+ return badHsExpr
+
| otherwise = mkRdrRecordUpd overloaded_update exp fs anns
mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> (Maybe (EpToken "{"), Maybe (EpToken "}"))
@@ -2912,9 +2929,11 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
fs' :: [LHsRecUpdField GhcPs GhcPs]
fs' = map (fmap mk_rec_upd_field) fs
case overloaded_on of
- False | not $ null ps ->
+ False | not $ null ps -> do
-- A '.' was found in an update and OverloadedRecordUpdate isn't on.
- addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled
+ addError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled
+ return badHsExpr
+
False ->
-- This is just a regular record update.
return RecordUpd {
@@ -2931,8 +2950,10 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
, isQual . fieldOccRdrName $ lbl
]
case qualifiedFields of
- qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $
- PsErrOverloadedRecordUpdateNoQualifiedFields
+ qf:_ -> do
+ addError $ mkPlainErrorMsgEnvelope (getLocA qf) PsErrOverloadedRecordUpdateNoQualifiedFields
+ return badHsExpr
+
_ -> return $
RecordUpd
{ rupd_ext = anns
@@ -3047,7 +3068,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td)
CApiConv -> do
imp <- mkCImport
if isCWrapperImport imp
- then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
+ then
+ do
+ addError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
+ return (const badHsDecl)
else returnSpec imp
StdCallConv -> returnSpec =<< mkCImport
PrimCallConv -> mkOtherImport
@@ -3474,9 +3498,9 @@ mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) (
let an = AnnExplicitSum o barsp barsa c
!cs <- getCommentsFor (locA l)
return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)
-mkSumOrTupleExpr l Boxed a@Sum{} _ =
- addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
-
+mkSumOrTupleExpr l Boxed a@Sum{} _ = do
+ addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
+ return (L l badHsExpr)
mkSumOrTuplePat
:: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation)
-> PV (LocatedA (PatBuilder GhcPs))
@@ -3490,8 +3514,9 @@ 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 $
- mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat
+ Left _ -> do
+ addError $ mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat
+ return (L l badHsPat)
Right p' -> checkLPat p'
-- Sum
@@ -3499,9 +3524,9 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do
p' <- checkLPat p
let an = EpAnnSumPat anns barsb barsa
return $ L l (PatBuilderPat (SumPat an p' alt arity))
-mkSumOrTuplePat l Boxed a@Sum{} _ =
- addFatalError $
- mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
+mkSumOrTuplePat l Boxed a@Sum{} _ = do
+ addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
+ return (L l (PatBuilderPat badHsPat))
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =