[Git][ghc/ghc][wip/parser-validator] 3 commits: gitlab-ci: source-tarball job should have no dependencies
Marge Bot
gitlab at gitlab.haskell.org
Thu Apr 25 18:29:01 UTC 2019
Marge Bot pushed to branch wip/parser-validator at Glasgow Haskell Compiler / GHC
Commits:
465f8f48 by Ben Gamari at 2019-04-24T16:19:24Z
gitlab-ci: source-tarball job should have no dependencies
- - - - -
0fc69416 by Vladislav Zavialov at 2019-04-25T18:28:56Z
Introduce MonadP, make PV a newtype
Previously we defined type PV = P,
this had the downside that if we wanted to change PV,
we would have to modify P as well.
Now PV is free to evolve independently from P.
The common operations addError, addFatalError, getBit, addAnnsAt,
were abstracted into a class called MonadP.
- - - - -
f85efdec by Vladislav Zavialov at 2019-04-25T18:28:56Z
checkPattern error hint is PV context
There is a hint added to error messages reported in checkPattern.
Instead of passing it manually, we put it in a ReaderT environment inside PV.
- - - - -
4 changed files:
- .gitlab-ci.yml
- compiler/parser/Lexer.x
- compiler/parser/Parser.y
- compiler/parser/RdrHsSyn.hs
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -747,6 +747,7 @@ source-tarball:
tags:
- x86_64-linux
image: ghcci/x86_64-linux-deb9:0.2
+ dependencies: []
only:
- tags
artifacts:
=====================================
compiler/parser/Lexer.x
=====================================
@@ -50,16 +50,17 @@
module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
+ MonadP(..),
getRealSrcLoc, getPState, withThisPackage,
failLocMsgP, srcParseFail,
getErrorMessages, getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
- ExtBits(..), getBit,
- addWarning, addError, addFatalError,
+ ExtBits(..),
+ addWarning,
lexTokenStream,
- addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
+ AddAnn,mkParensApiAnn,
commentToAnnotation
) where
@@ -2276,11 +2277,6 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- stored in a @Word64 at .
type ExtsBitmap = Word64
--- | Check if a given flag is currently set in the bitmap.
-getBit :: ExtBits -> P Bool
-getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
- in b `seq` POk s b
-
xbit :: ExtBits -> ExtsBitmap
xbit = bit . fromEnum
@@ -2474,34 +2470,59 @@ 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.
+-- | An mtl-style class for monads that support parsing-related operations.
+-- For example, sometimes we make a second pass over the parsing results to validate,
+-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume
+-- input but can report parsing errors, check for extension bits, and accumulate
+-- parsing annotations. Both P and PV are instances of MonadP.
--
--- 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.
+-- MonadP grants us convenient overloading. The other option is to have separate operations
+-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.
--
-addError :: SrcSpan -> SDoc -> P ()
-addError srcspan msg
- = P $ \s at PState{messages=m} ->
- let
- m' d =
- let (ws, es) = m d
- errormsg = mkErrMsg d srcspan alwaysQualify msg
- es' = es `snocBag` errormsg
- 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
+class Monad m => MonadP m where
+ -- | 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 -> 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 -> m a
+ -- | Check if a given flag is currently set in the bitmap.
+ getBit :: ExtBits -> m Bool
+ -- | Given a location and a list of AddAnn, apply them all to the location.
+ addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
+ addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
+ -> AnnKeywordId -- The first two parameters are the key
+ -> SrcSpan -- The location of the keyword itself
+ -> m ()
+
+instance MonadP P where
+ addError srcspan msg
+ = P $ \s at PState{messages=m} ->
+ let
+ m' d =
+ let (ws, es) = m d
+ errormsg = mkErrMsg d srcspan alwaysQualify msg
+ es' = es `snocBag` errormsg
+ in (ws, es')
+ in POk s{messages=m'} ()
+ addFatalError span msg =
+ addError span msg >> P PFailed
+ getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
+ in b `seq` POk s b
+ addAnnsAt loc anns = mapM_ (\a -> a loc) anns
+ addAnnotation l a v = do
+ addAnnotationOnly l a v
+ allocateComments l
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
@@ -3042,23 +3063,11 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
-- function, and then it can be discharged using the 'ams' function.
type AddAnn = SrcSpan -> P ()
-addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
- -> AnnKeywordId -- The first two parameters are the key
- -> SrcSpan -- The location of the keyword itself
- -> P ()
-addAnnotation l a v = do
- addAnnotationOnly l a v
- allocateComments l
-
addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
--- |Given a location and a list of AddAnn, apply them all to the location.
-addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
-addAnnsAt loc anns = mapM_ (\a -> a loc) anns
-
-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddAnn' values for the opening and closing bordering on the start
-- and end of the span
=====================================
compiler/parser/Parser.y
=====================================
@@ -2396,8 +2396,8 @@ decl_no_th :: { LHsDecl GhcPs }
| '!' aexp rhs {% runExpCmdP $2 >>= \ $2 ->
do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
; l = comb2 $1 $> };
- (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
- hintBangPat (comb2 $1 $2) (unLoc e) ;
+ (ann, r) <- checkValDef SrcStrict e Nothing $3 ;
+ runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
@@ -2410,7 +2410,7 @@ decl_no_th :: { LHsDecl GhcPs }
_ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
return $! (sL l $ ValD noExt r) } }
- | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
+ | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
@@ -2582,8 +2582,8 @@ exp :: { ExpCmdP }
infixexp :: { ExpCmdP }
: exp10 { $1 }
| infixexp qop exp10 { ExpCmdP $
- runExpCmdP $1 >>= \ $1 ->
- runExpCmdP $3 >>= \ $3 ->
+ runExpCmdPV $1 >>= \ $1 ->
+ runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> (ecOpApp $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
@@ -2670,13 +2670,13 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
fexp :: { ExpCmdP }
: fexp aexp {% runExpCmdP $2 >>= \ $2 ->
- checkBlockArguments $2 >>= \_ ->
+ runPV (checkBlockArguments $2) >>= \_ ->
return $ ExpCmdP $
- runExpCmdP $1 >>= \ $1 ->
+ runExpCmdPV $1 >>= \ $1 ->
checkBlockArguments $1 >>= \_ ->
return (sLL $1 $> (ecHsApp $1 $2)) }
| fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 ->
- checkBlockArguments $1 >>= \_ ->
+ runPV (checkBlockArguments $1) >>= \_ ->
fmap ecFromExp $
ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
@@ -2699,7 +2699,7 @@ aexp :: { ExpCmdP }
| '\\' apat apats '->' exp
{ ExpCmdP $
- runExpCmdP $5 >>= \ $5 ->
+ runExpCmdPV $5 >>= \ $5 ->
ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match { m_ext = noExt
, m_ctxt = LambdaExpr
@@ -2707,12 +2707,12 @@ aexp :: { ExpCmdP }
, m_grhss = unguardedGRHSs $5 }]))
[mj AnnLam $1, mu AnnRarrow $4] }
| 'let' binds 'in' exp { ExpCmdP $
- runExpCmdP $4 >>= \ $4 ->
+ runExpCmdPV $4 >>= \ $4 ->
ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
- {% $3 >>= \ $3 ->
+ {% runPV $3 >>= \ $3 ->
fmap ecFromExp $
ams (sLL $1 $> $ HsLamCase noExt
(mkMatchGroup FromSource (snd $ unLoc $3)))
@@ -2720,8 +2720,8 @@ aexp :: { ExpCmdP }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runExpCmdP $2 >>= \ $2 ->
return $ ExpCmdP $
- runExpCmdP $5 >>= \ $5 ->
- runExpCmdP $8 >>= \ $8 ->
+ runExpCmdPV $5 >>= \ $5 ->
+ runExpCmdPV $8 >>= \ $8 ->
checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
ams (sLL $1 $> $ ecHsIf $2 $5 $8)
(mj AnnIf $1:mj AnnThen $4
@@ -2746,13 +2746,13 @@ aexp :: { ExpCmdP }
ams (cL (comb2 $1 $2)
(ecHsDo (mapLoc snd $2)))
(mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% $2 >>= \ $2 ->
+ | 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecFromExp $
ams (cL (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
- {% (checkPattern empty <=< runExpCmdP) $2 >>= \ p ->
+ {% (checkPattern <=< runExpCmdP) $2 >>= \ p ->
runExpCmdP $4 >>= \ $4 at cmd ->
fmap ecFromExp $
ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
@@ -2788,7 +2788,7 @@ aexp2 :: { ExpCmdP }
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { ExpCmdP $
- runExpCmdP $2 >>= \ $2 ->
+ runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; fmap ecFromExp $
@@ -2825,7 +2825,7 @@ aexp2 :: { ExpCmdP }
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
| '[t|' ktype '|]' {% fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
- | '[p|' infixexp '|]' {% (checkPattern empty <=< runExpCmdP) $2 >>= \p ->
+ | '[p|' infixexp '|]' {% (checkPattern <=< runExpCmdP) $2 >>= \p ->
fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
@@ -3022,12 +3022,12 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
amsL (comb2 $1 $>) (fst $ unLoc $3) >>
return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
| squals ',' qual
- {% $3 >>= \ $3 ->
+ {% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
- | qual {% $1 >>= \ $1 ->
+ | qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
@@ -3068,11 +3068,11 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 ',' qual {% $3 >>= \ $3 ->
+ : guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma
(gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
- | qual {% $1 >>= \ $1 ->
+ | qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-----------------------------------------------------------------------------
@@ -3126,7 +3126,7 @@ alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (
return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) }
ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
- : '->' exp { runExpCmdP $2 >>= \ $2 ->
+ : '->' exp { runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
[mu AnnRarrow $1] }
| gdpats { $1 >>= \gdpats ->
@@ -3142,14 +3142,14 @@ gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
- : '{' gdpats '}' {% $2 >>= \ $2 ->
+ : '{' gdpats '}' {% runPV $2 >>= \ $2 ->
return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
- | gdpats close {% $1 >>= \ $1 ->
+ | gdpats close {% runPV $1 >>= \ $1 ->
return $ sL1 $1 ([],unLoc $1) }
gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
: '|' guardquals '->' exp
- { runExpCmdP $4 >>= \ $4 ->
+ { runExpCmdPV $4 >>= \ $4 ->
ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mu AnnRarrow $3] }
@@ -3158,26 +3158,26 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
-- Bangs inside are parsed as infix operator applications, so that
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
-pat : exp {% (checkPattern empty <=< runExpCmdP) $1 }
+pat : exp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty (sLL $1 $> (SectionR noExt
+ amms (checkPattern (sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
bindpat : exp {% runExpCmdP $1 >>= \ $1 ->
- checkPattern
- (text "Possibly caused by a missing 'do'?") $1 }
+ -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
+ checkPattern_msg (text "Possibly caused by a missing 'do'?") $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern
- (text "Possibly caused by a missing 'do'?")
+ -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
+ amms (checkPattern_msg (text "Possibly caused by a missing 'do'?")
(sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
-apat : aexp {% (checkPattern empty <=< runExpCmdP) $1 }
+apat : aexp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty
+ amms (checkPattern
(sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
@@ -3229,12 +3229,12 @@ stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b
-- For typing stmts at the GHCi prompt, where
-- the input may consist of just comments.
maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
- : stmt {% fmap Just $1 }
+ : stmt {% fmap Just (runPV $1) }
| {- nothing -} { Nothing }
-- For GHC API.
e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
- : stmt {% $1 }
+ : stmt {% runPV $1 }
stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
: qual { $1 }
@@ -3243,10 +3243,10 @@ stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
(mj AnnRec $1:(fst $ unLoc $2)) }
qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
- : bindpat '<-' exp { runExpCmdP $3 >>= \ $3 ->
+ : bindpat '<-' exp { runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> $ mkBindStmt $1 $3)
[mu AnnLarrow $2] }
- | exp { runExpCmdP $1 >>= \ $1 ->
+ | exp { runExpCmdPV $1 >>= \ $1 ->
return $ sL1 $1 $ mkBodyStmt $1 }
| 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
@@ -4037,7 +4037,7 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: Located a -> [AddAnn] -> P (Located a)
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -15,6 +15,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsOpApp,
@@ -53,10 +54,10 @@ module RdrHsSyn (
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
+ checkPattern_msg,
bang_RDR,
isBangRdr,
isTildeRdr,
- checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -88,7 +89,9 @@ module RdrHsSyn (
-- Expression/command ambiguity resolution
PV,
- ExpCmdP(ExpCmdP, runExpCmdP),
+ runPV,
+ ExpCmdP(ExpCmdP, runExpCmdPV),
+ runExpCmdP,
ExpCmdI(..),
ecFromExp,
ecFromCmd,
@@ -127,6 +130,7 @@ import Data.List
import DynFlags ( WarningFlag(..) )
import Control.Monad
+import Control.Monad.Trans.Reader
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
@@ -970,11 +974,11 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
-checkExpBlockArguments :: LHsExpr GhcPs -> P ()
-checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
- checkExpr :: LHsExpr GhcPs -> P ()
+ checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
HsDo _ DoExpr _ -> check "do block" expr
HsDo _ MDoExpr _ -> check "mdo block" expr
@@ -986,7 +990,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsProc {} -> check "proc expression" expr
_ -> return ()
- checkCmd :: LHsCmd GhcPs -> P ()
+ checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
HsCmdLam {} -> check "lambda command" cmd
HsCmdCase {} -> check "case command" cmd
@@ -995,7 +999,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsCmdDo {} -> check "do command" cmd
_ -> return ()
- check :: (HasSrcSpan a, Outputable a) => String -> a -> P ()
+ check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
@@ -1052,38 +1056,39 @@ checkNoDocs msg ty = go ty
-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.
-checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkPattern msg e = checkLPat msg e
+checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
+checkPattern = runPV . checkLPat
-checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
-checkPatterns msg es = mapM (checkPattern msg) es
+checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
+checkPattern_msg msg = runPV_msg msg . checkLPat
-checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkLPat msg e@(dL->L l _) = checkPat msg l e []
+checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs)
+checkLPat e@(dL->L l _) = checkPat l e []
-checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
- -> P (LPat GhcPs)
-checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args
+checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
+ -> PV (LPat GhcPs)
+checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args
| isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c =
- patFail (text "Perhaps you intended to use RecursiveDo") l e
-checkPat msg loc e args -- OK to let this happen even if bang-patterns
+ localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
+ patFail l e
+checkPat loc e args -- OK to let this happen even if bang-patterns
-- are not enabled, because there is no valid
-- non-bang-pattern parse of (C ! e)
| Just (e', args') <- splitBang e
- = do { args'' <- checkPatterns msg args'
- ; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (dL->L _ (HsApp _ f e)) args
- = do p <- checkLPat msg e
- checkPat msg loc f (p : args)
-checkPat msg loc (dL->L _ e) []
- = do p <- checkAPat msg loc e
+ = do { args'' <- mapM checkLPat args'
+ ; checkPat loc e' (args'' ++ args) }
+checkPat loc (dL->L _ (HsApp _ f e)) args
+ = do p <- checkLPat e
+ checkPat loc f (p : args)
+checkPat loc (dL->L _ e) []
+ = do p <- checkAPat loc e
return (cL loc p)
-checkPat msg loc e _
- = patFail msg loc (unLoc e)
+checkPat loc e _
+ = patFail loc (unLoc e)
-checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
-checkAPat msg loc e0 = do
+checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs)
+checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
EWildPat _ -> return (WildPat noExt)
@@ -1104,16 +1109,16 @@ checkAPat msg loc e0 = do
SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
| bang == bang_RDR
-> do { hintBangPat loc e0
- ; e' <- checkLPat msg e
+ ; e' <- checkLPat e
; addAnnotation loc AnnBang lb
; return (BangPat noExt e') }
- ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
- EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
+ ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt))
+ EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
- EViewPat _ expr patE -> checkLPat msg patE >>=
+ EViewPat _ expr patE -> checkLPat patE >>=
(return . (\p -> ViewPat noExt expr p))
- ExprWithTySig _ e t -> do e <- checkLPat msg e
+ ExprWithTySig _ e t -> do e <- checkLPat e
return (SigPat noExt e t)
-- n+k patterns
@@ -1124,34 +1129,34 @@ checkAPat msg loc e0 = do
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
- l <- checkLPat msg l
- r <- checkLPat msg r
+ l <- checkLPat l
+ r <- checkLPat r
return (ConPatIn (cL cl c) (InfixCon l r))
- OpApp {} -> patFail msg loc e0
+ OpApp {} -> patFail loc e0
- ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
+ ExplicitList _ _ es -> do ps <- mapM checkLPat es
return (ListPat noExt ps)
- HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
+ HsPar _ e -> checkLPat e >>= (return . (ParPat noExt))
ExplicitTuple _ es b
- | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
+ | all tupArgPresent es -> do ps <- mapM checkLPat
[e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
| otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
$$ ppr e0)
ExplicitSum _ alt arity expr -> do
- p <- checkLPat msg expr
+ p <- checkLPat expr
return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
- -> do fs <- mapM (checkPatField msg) fs
+ -> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE _ s | not (isTypedSplice s)
-> return (SplicePat noExt s)
- _ -> patFail msg loc e0
+ _ -> patFail loc e0
placeHolderPunRhs :: LHsExpr GhcPs
-- The RHS of a punned record field will be filled in by the renamer
@@ -1169,15 +1174,13 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR)
-checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
- -> P (LHsRecField GhcPs (LPat GhcPs))
-checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
- return (cL l (fld { hsRecFieldArg = p }))
+checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs)
+ -> PV (LHsRecField GhcPs (LPat GhcPs))
+checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
+ return (cL l (fld { hsRecFieldArg = p }))
-patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
-patFail msg loc e = addFatalError loc err
- where err = text "Parse error in pattern:" <+> ppr e
- $$ msg
+patFail :: SrcSpan -> HsExpr GhcPs -> PV a
+patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
@@ -1186,28 +1189,26 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef :: SDoc
- -> SrcStrictness
+checkValDef :: SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkValDef msg _strictness lhs (Just sig) grhss
+checkValDef _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
- = checkPatBind msg (cL (combineLocs lhs sig)
+ = checkPatBind (cL (combineLocs lhs sig)
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
-checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss))
+checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
- checkFunBind msg strictness ann (getLoc lhs)
+ checkFunBind strictness ann (getLoc lhs)
fun is_infix pats (cL l grhss)
- Nothing -> checkPatBind msg lhs g }
+ Nothing -> checkPatBind lhs g }
-checkFunBind :: SDoc
- -> SrcStrictness
+checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
@@ -1215,8 +1216,8 @@ checkFunBind :: SDoc
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
- = do ps <- checkPatterns msg pats
+checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
+ = do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
@@ -1241,12 +1242,11 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
-checkPatBind :: SDoc
- -> LHsExpr GhcPs
+checkPatBind :: LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind msg lhs (dL->L _ (_,grhss))
- = do { lhs <- checkPattern msg lhs
+checkPatBind lhs (dL->L _ (_,grhss))
+ = do { lhs <- checkPattern lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
@@ -1284,7 +1284,7 @@ checkValSigLhs lhs@(dL->L l _)
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
- => a -> Bool -> b -> Bool -> c -> P ()
+ => a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
@@ -1876,7 +1876,10 @@ checkMonadComp = do
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
newtype ExpCmdP =
- ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+ ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+
+runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs))
+runExpCmdP p = runPV (runExpCmdPV p)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp a = ExpCmdP (ecFromExp' a)
@@ -1910,7 +1913,7 @@ class ExpCmdI b where
checkBlockArguments :: Located (b GhcPs) -> PV ()
-- | Check if -XDoAndIfThenElse is enabled.
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
- -> Bool -> Located (b GhcPs) -> P ()
+ -> Bool -> Located (b GhcPs) -> PV ()
instance ExpCmdI HsCmd where
ecFromCmd' = return
@@ -2661,7 +2664,30 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
-----------------------------------------------------------------------------
-- Misc utils
-type PV = P -- See Note [Parser-Validator]
+-- See Note [Parser-Validator] and Note [Parser-Validator ReaderT SDoc]
+newtype PV a = PV (ReaderT SDoc P a)
+ deriving (Functor, Applicative, Monad)
+
+runPV :: PV a -> P a
+runPV (PV m) = runReaderT m empty
+
+runPV_msg :: SDoc -> PV a -> P a
+runPV_msg msg (PV m) = runReaderT m msg
+
+localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
+localPV_msg f (PV m) = PV (local f m)
+
+instance MonadP PV where
+ addError srcspan msg =
+ PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
+ addFatalError srcspan msg =
+ PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
+ getBit ext =
+ PV $ ReaderT $ \_ -> getBit ext
+ addAnnsAt loc anns =
+ PV $ ReaderT $ \_ -> addAnnsAt loc anns
+ addAnnotation l a v =
+ PV $ ReaderT $ \_ -> addAnnotation l a v
{- Note [Parser-Validator]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2693,8 +2719,50 @@ not consume any input, but may fail or use other effects. Thus we have:
-}
+{- Note [Parser-Validator ReaderT SDoc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A PV computation is parametrized by a hint for error 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':
+
+ f _ = do
+ x <- computation
+ case () of
+ _ ->
+ result <- computation
+ case () of () -> undefined
+
+GHC parses it as follows:
+
+ f _ = do
+ x <- computation
+ (case () of
+ _ ->
+ result) <- computation
+ case () of () -> undefined
+
+Note that this fragment is parsed as a pattern:
+
+ case () of
+ _ ->
+ result
+
+We attempt to detect such cases and add a hint to the error 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
+via ReaderT SDoc in PV. 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.
+
+-}
+
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
-hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/1ca8ef4b59e8ff801ac0d4f7fa9d282ee427af50...f85efdec3e0580591eed0d132404a20df9a76316
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/1ca8ef4b59e8ff801ac0d4f7fa9d282ee427af50...f85efdec3e0580591eed0d132404a20df9a76316
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/20190425/21148a29/attachment-0001.html>
More information about the ghc-commits
mailing list