[Git][ghc/ghc][wip/sgraf-resumptive-fork] Catch more parser errors gracefully
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Sep 9 14:30:36 UTC 2024
Sebastian Graf pushed to branch wip/sgraf-resumptive-fork at Glasgow Haskell Compiler / GHC
Commits:
9075666e by Sebastian Graf at 2024-09-09T16:30:28+02:00
Catch more parser errors gracefully
- - - - -
4 changed files:
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
Changes:
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1234,7 +1234,7 @@ isPtrGlobalRegUse (GlobalRegUse reg ty)
go _ = False
happyError :: PD a
-happyError = PD $ \_ _ s -> unP srcParseFail s
+happyError = PD $ \_ _ s -> unP srcParseAbort s
-- -----------------------------------------------------------------------------
-- Statement-level macros
=====================================
compiler/GHC/Parser.y
=====================================
@@ -100,7 +100,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Semigroup as Semi
}
-%error { srcParseFail } { srcParseFail' }
+%error { srcParseAbort } { srcParseReport }
%error.expected
%expect 0 -- shift/reduce conflicts
@@ -2289,7 +2289,7 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
ftype :: { forall b. DisambTD b => PV (LocatedA b) }
: atype { mkHsAppTyHeadPV $1 }
- | tyop { failOpFewArgs (fst $1) }
+ | tyop { failOpFewArgs (fst $1) >> mkHsAppTyHeadPV (sL1a (fst $1) $ mkAnonWildCardTy) } -- TODO!
| ftype tyarg { $1 >>= \ $1 ->
mkHsAppTyPV $1 $2 }
| ftype PREFIX_AT atype { $1 >>= \ $1 ->
@@ -4159,7 +4159,7 @@ catchHsExpr = ecpFromExp (noLocA (HsPartial noExtField))
-----------------------------------------------------------------------------
happyError :: P a
-happyError = srcParseFail
+happyError = srcParseAbort
getVARID (L _ (ITvarid x)) = x
getCONID (L _ (ITconid x)) = x
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -61,7 +61,7 @@ module GHC.Parser.Lexer (
allocateComments, allocatePriorComments, allocateFinalComments,
MonadP(..), getBit,
getRealSrcLoc, getPState,
- failMsgP, failLocMsgP, srcParseFail, srcParseFail', srcParseErr,
+ failMsgP, failLocMsgP, srcParseReport, srcParseAbort, srcParseErr,
getPsErrorMessages, getPsMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
@@ -3264,11 +3264,11 @@ srcParseErr options buf len loc expected = mkPlainErrorMsgEnvelope loc (PsErrPar
, ped_expected = expected
}
--- Report a parse failure, giving the span of the previous token as
+-- Report a fatal parse failure, giving the span of the previous token as
-- the location of the error. This is the entry point for errors
-- detected during parsing.
-srcParseFail :: P a
-srcParseFail =
+srcParseAbort :: P a
+srcParseAbort =
P $ \s at PState{ buffer = buf
, options = o
, last_len = len
@@ -3300,12 +3300,16 @@ srcParseWarn options buf len loc expected = mkPlainWarningMsgEnvelope loc (PsErr
, ped_expected = expected
}
-srcParseFail' :: Located Token -> [String] -> P a -> P a
-srcParseFail' (L loc _last_tk) expected_toks resume =
+-- Report a resumable parse failure, giving the span of the previous token as
+-- the location of the error. This is the entry point for errors
+-- detected during parsing.
+srcParseReport :: Located Token -> [String] -> P a -> P a
+srcParseReport (L loc _last_tk) expected_toks resume =
do P $ \s at PState{ buffer = buf
, options = o
- , last_len = len } ->
- unP (addWarning $ srcParseWarn o buf len loc expected_toks) s
+ , last_len = len
+ , last_loc = last_loc } ->
+ unP (addError $ srcParseErr o buf len (mkSrcSpanPs last_loc) []) s
resume
-- A lexical error is reported at a particular position in the source file,
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -146,6 +146,7 @@ import GHC.Parser.Errors.Types
import GHC.Utils.Lexeme ( okConOcc )
import GHC.Types.TyThing
import GHC.Core.Type ( Specificity(..) )
+import GHC.Builtin.Names ( wildCardName )
import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
listTyConName, listTyConKey, sumDataCon,
@@ -1077,12 +1078,14 @@ checkTyClHdr is_cls ty
; return (L a' (Unqual name), acc, fix
, (reverse ops') ++ cps', cs) }
- go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
- | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
- go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
- where lhs = HsValArg noExtField t1
- rhs = HsValArg noExtField t2
+ go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix = do
+ unless (isRdrTc tc) $ reportMalformed ty l
+ return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix = do
+ unless (isRdrTc tc) $ reportMalformed ty l
+ let lhs = HsValArg noExtField t1
+ rhs = HsValArg noExtField t2
+ return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
go cs l (HsParTy _ ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
where
(o,c) = mkParensEpAnn (realSrcSpan (locA l))
@@ -1096,9 +1099,16 @@ checkTyClHdr is_cls ty
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
- go _ l _ _ _ _ _
- = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
- (PsErrMalformedTyOrClDecl ty)
+ go cs l this_ty acc ops cps fix = do
+ reportMalformed ty l
+ case this_ty of
+ HsWildCardTy{} -> -- This is actually the partial node case
+ return (L (l2l l) (nameRdrName wildCardName), acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ _ ->
+ P PFailed
+
+ reportMalformed ty l =
+ addError $ mkPlainErrorMsgEnvelope (locA l) (PsErrMalformedTyOrClDecl ty)
-- Combine the annotations from the HsParTy and HsStarTy into a
-- new one for the LocatedN RdrName
@@ -3253,11 +3263,11 @@ failImportQualifiedTwice loc =
warnStarIsType :: SrcSpan -> P ()
warnStarIsType span = addPsMessage span PsWarnStarIsType
-failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
+failOpFewArgs :: MonadP m => LocatedN RdrName -> m ()
failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let is_star_type = if star_is_type then StarIsType else StarIsNotType
- ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+ ; addError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrOpFewArgs is_star_type op) }
requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9075666ef84e50f57d5686e5db0ea35f8fe29a89
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9075666ef84e50f57d5686e5db0ea35f8fe29a89
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240909/ee35f0c4/attachment-0001.html>
More information about the ghc-commits
mailing list