[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