Improve an error message; fixes #984

This code:
    f _ = do
            x <- computation
            case () of
                    _ ->
                            result <- computation
                            case () of () -> undefined
Now gives this error:
    Parse error in pattern: case () of { _ -> result }
    Possibly caused by a missing 'do'?

2 files changed, 70 insertions, 60 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 623ae79565..75e44d19ba 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1358,14 +1358,14 @@ decl    :: { Located (OrdList (LHsDecl RdrName)) }
         : sigdecl               { $1 }
 
         | '!' aexp rhs          {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) };
-                                        pat <- checkPattern e;
+                                        pat <- checkPattern empty e;
                                         return $ LL $ unitOL $ LL $ ValD $
                                                PatBind pat (unLoc $3)
                                                        placeHolderType placeHolderNames (Nothing,[]) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp opt_sig rhs  {% do { r <- checkValDef $1 $2 $3;
+        | infixexp opt_sig rhs  {% do { r <- checkValDef empty $1 $2 $3;
                                         let { l = comb2 $1 $> };
                                         return $! (sL l (unitOL $! (sL l $ ValD r))) } }
         | docdecl               { LL $ unitOL $1 }
@@ -1465,7 +1465,7 @@ exp10 :: { LHsExpr RdrName }
                                                                       else HsPar $2 } }
 
         | 'proc' aexp '->' exp  
-                        {% checkPattern $2 >>= \ p -> 
+                        {% checkPattern empty $2 >>= \ p -> 
                             checkCommand $4 >>= \ cmd ->
                             return (LL $ HsProc p (LL $ HsCmdTop cmd [] 
                                                     placeHolderType undefined)) }
@@ -1548,7 +1548,7 @@ aexp2   :: { LHsExpr RdrName }
         | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr False (unLoc $2)) }
         | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
-        | '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
+        | '[p|' infixexp '|]'   {% checkPattern empty $2 >>= \p ->
                                         return (LL $ HsBracket (PatBr p)) }
         | '[d|' cvtopbody '|]'  { LL $ HsBracket (DecBrL $2) }
         | quasiquote            { L1 (HsQuasiQuoteE (unLoc $1)) }
@@ -1750,12 +1750,16 @@ gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
 -- Bangs inside are parsed as infix operator applications, so that
 -- we parse them right when bang-patterns are off
 pat     :: { LPat RdrName }
-pat     :  exp                  {% checkPattern $1 }
-        | '!' aexp              {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+pat     :  exp                  {% checkPattern empty $1 }
+        | '!' aexp              {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+
+bindpat :: { LPat RdrName }
+bindpat :  exp                  {% checkPattern (text "Possibly caused by a missing 'do'?") $1 }
+        | '!' aexp              {% checkPattern (text "Possibly caused by a missing 'do'?") (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
 
 apat   :: { LPat RdrName }      
-apat    : aexp                  {% checkPattern $1 }
-        | '!' aexp              {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+apat    : aexp                  {% checkPattern empty $1 }
+        | '!' aexp              {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
 
 apats  :: { [LPat RdrName] }
         : apat apats            { $1 : $2 }
@@ -1793,7 +1797,7 @@ stmt  :: { LStmt RdrName (LHsExpr RdrName) }
         | 'rec' stmtlist                { LL $ mkRecStmt (unLoc $2) }
 
 qual  :: { LStmt RdrName (LHsExpr RdrName) }
-    : pat '<-' exp                      { LL $ mkBindStmt $1 $3 }
+    : bindpat '<-' exp                  { LL $ mkBindStmt $1 $3 }
     | exp                               { L1 $ mkBodyStmt $1 }
     | 'let' binds                       { LL $ LetStmt (unLoc $2) }
 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 4d384be276..8c7b0a7e62 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -542,35 +542,36 @@ checkContext (L l orig_t)
 -- We parse patterns as expressions and check for valid patterns below,
 -- converting the expression into a pattern at the same time.
 
-checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
-checkPattern e = checkLPat e
+checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
+checkPattern msg e = checkLPat msg e
 
-checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
-checkPatterns es = mapM checkPattern es
+checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
+checkPatterns msg es = mapM (checkPattern msg) es
 
-checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
-checkLPat e@(L l _) = checkPat l e []
+checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
+checkLPat msg e@(L l _) = checkPat msg l e []
 
-checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
-checkPat loc (L l (HsVar c)) args
+checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
+         -> P (LPat RdrName)
+checkPat _ loc (L l (HsVar c)) args
   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
-checkPat loc e args     -- OK to let this happen even if bang-patterns
+checkPat msg 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 args'
-        ; checkPat loc e' (args'' ++ args) }
-checkPat loc (L _ (HsApp f e)) args
-  = do p <- checkLPat e
-       checkPat loc f (p : args)
-checkPat loc (L _ e) []
-  = do p <- checkAPat loc e
+  = do  { args'' <- checkPatterns msg args'
+        ; checkPat msg loc e' (args'' ++ args) }
+checkPat msg loc (L _ (HsApp f e)) args
+  = do p <- checkLPat msg e
+       checkPat msg loc f (p : args)
+checkPat msg loc (L _ e) []
+  = do p <- checkAPat msg loc e
        return (L loc p)
-checkPat loc e _
-  = patFail loc (unLoc e)
+checkPat msg loc e _
+  = patFail msg loc (unLoc e)
 
-checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
-checkAPat loc e0 = do
+checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
+checkAPat msg loc e0 = do
  pState <- getPState
  let dynflags = dflags pState
  case e0 of
@@ -588,14 +589,14 @@ checkAPat loc e0 = do
    SectionR (L _ (HsVar bang)) e        -- (! x)
         | bang == bang_RDR
         -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then checkLPat e >>= (return . BangPat)
+              ; if bang_on then checkLPat msg e >>= (return . BangPat)
                 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
 
-   ELazyPat e         -> checkLPat e >>= (return . LazyPat)
-   EAsPat n e         -> checkLPat e >>= (return . AsPat n)
+   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
+   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
    -- view pattern is well-formed if the pattern is
-   EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
-   ExprWithTySig e t  -> do e <- checkLPat e
+   EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType))
+   ExprWithTySig e t  -> do e <- checkLPat msg e
                             -- Pattern signatures are parsed as sigtypes,
                             -- but they aren't explicit forall points.  Hence
                             -- we have to remove the implicit forall here.
@@ -610,29 +611,29 @@ checkAPat loc e0 = do
                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) lit)
 
-   OpApp l op _fix r  -> do l <- checkLPat l
-                            r <- checkLPat r
+   OpApp l op _fix r  -> do l <- checkLPat msg l
+                            r <- checkLPat msg r
                             case op of
                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                       -> return (ConPatIn (L cl c) (InfixCon l r))
-                               _ -> patFail loc e0
+                               _ -> patFail msg loc e0
 
-   HsPar e            -> checkLPat e >>= (return . ParPat)
-   ExplicitList _ es  -> do ps <- mapM checkLPat es
+   HsPar e            -> checkLPat msg e >>= (return . ParPat)
+   ExplicitList _ es  -> do ps <- mapM (checkLPat msg) es
                             return (ListPat ps placeHolderType)
-   ExplicitPArr _ es  -> do ps <- mapM checkLPat es
+   ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es
                             return (PArrPat ps placeHolderType)
 
    ExplicitTuple es b
-     | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
+     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
                                    return (TuplePat ps b placeHolderType)
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
    RecordCon c _ (HsRecFields fs dd)
-                      -> do fs <- mapM checkPatField fs
+                      -> do fs <- mapM (checkPatField msg) fs
                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
-   _                  -> patFail loc e0
+   _                  -> patFail msg loc e0
 
 placeHolderPunRhs :: LHsExpr RdrName
 -- The RHS of a punned record field will be filled in by the renamer
@@ -644,42 +645,46 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
-checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
-checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
-                        ; return (fld { hsRecFieldArg = p }) }
+checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
+checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld)
+                           return (fld { hsRecFieldArg = p })
 
-patFail :: SrcSpan -> HsExpr RdrName -> P a
-patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
+patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
+patFail msg loc e = parseErrorSDoc loc err
+    where err = text "Parse error in pattern:" <+> ppr e
+             $$ msg
 
 
 ---------------------------------------------------------------------------
 -- Check Equation Syntax
 
-checkValDef :: LHsExpr RdrName
+checkValDef :: SDoc
+            -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (GRHSs RdrName (LHsExpr RdrName))
             -> P (HsBind RdrName)
 
-checkValDef lhs (Just sig) grhss
+checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
-  = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
+  = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 
-checkValDef lhs opt_sig grhss
+checkValDef msg lhs opt_sig grhss
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
-            Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
+            Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
                                                 fun is_infix pats opt_sig grhss
-            Nothing -> checkPatBind lhs grhss }
+            Nothing -> checkPatBind msg lhs grhss }
 
-checkFunBind :: SrcSpan
+checkFunBind :: SDoc
+             -> SrcSpan
              -> Located RdrName
              -> Bool
              -> [LHsExpr RdrName]
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P (HsBind RdrName)
-checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
-  = do  ps <- checkPatterns pats
+checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+  = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
@@ -691,11 +696,12 @@ makeFunBind fn is_infix ms
   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 
-checkPatBind :: LHsExpr RdrName
+checkPatBind :: SDoc
+             -> LHsExpr RdrName
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P (HsBind RdrName)
-checkPatBind lhs (L _ grhss)
-  = do  { lhs <- checkPattern lhs
+checkPatBind msg lhs (L _ grhss)
+  = do  { lhs <- checkPattern msg lhs
         ; return (PatBind lhs grhss placeHolderType placeHolderNames
                     (Nothing,[])) }