Fixed error messages for RecursiveDo (#8501)

Changes in a few different places to catch several different
types of error related to RecursiveDo

Signed-off-by: Rupert Horlick <[email protected]>

Test Plan: Three test cases, with further tests in comments

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3271

compiler/parser/Lexer.x

@@ -2405,14 +2405,18 @@ srcParseErr options buf len
               $$ ppWhen (not th_enabled && token == "$") -- #7396
                         (text "Perhaps you intended to use TemplateHaskell")
               $$ ppWhen (token == "<-")
-                        (text "Perhaps this statement should be within a 'do' block?")
+                        (if mdoInLast100
+                           then text "Perhaps you intended to use RecursiveDo"
+                           else text "Perhaps this statement should be within a 'do' block?")
               $$ ppWhen (token == "=")
                         (text "Perhaps you need a 'let' in a 'do' block?"
                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
-              $$ ppWhen (not ps_enabled && pattern == "pattern") -- #12429
+              $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
                         (text "Perhaps you intended to use PatternSynonyms")
   where token = lexemeToString (offsetBytes (-len) buf) len
-        pattern = lexemeToString (offsetBytes (-len - 8) buf) 7
+        pattern = decodePrevNChars 8 buf
+        last100 = decodePrevNChars 100 buf
+        mdoInLast100 = "mdo" `isInfixOf` last100
         th_enabled = extopt LangExt.TemplateHaskell options
         ps_enabled = extopt LangExt.PatternSynonyms options
 

compiler/parser/RdrHsSyn.hs

@@ -805,8 +805,10 @@ checkLPat msg e@(L l _) = checkPat msg l e []
 
 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
          -> P (LPat RdrName)
-checkPat _ loc (L l (HsVar (L _ c))) args
+checkPat _ loc (L l e@(HsVar (L _ c))) args
   | isRdrDataCon c = return (L loc (ConPatIn (L 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
                         -- are not enabled, because there is no valid
                         -- non-bang-pattern parse of (C ! e)
@@ -913,6 +915,9 @@ patFail msg loc e = parseErrorSDoc loc err
     where err = text "Parse error in pattern:" <+> ppr e
              $$ msg
 
+patIsRec :: RdrName -> Bool
+patIsRec e = e == mkUnqual varName (fsLit "rec")
+
 
 ---------------------------------------------------------------------------
 -- Check Equation Syntax

compiler/rename/RnEnv.hs

@@ -1856,7 +1856,8 @@ unknownNameSuggestions_ :: WhereLooking -> DynFlags
                        -> RdrName -> SDoc
 unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =
     similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
-    importSuggestions where_look imports tried_rdr_name
+    importSuggestions where_look  imports tried_rdr_name $$
+    extensionSuggestions tried_rdr_name
 
 
 similarNameSuggestions :: WhereLooking -> DynFlags
@@ -2087,6 +2088,13 @@ importSuggestions where_look imports rdr_name
   (helpful_imports_hiding, helpful_imports_non_hiding)
     = partition (imv_is_hiding . snd) helpful_imports
 
+extensionSuggestions :: RdrName -> SDoc
+extensionSuggestions rdrName
+  | rdrName == mkUnqual varName (fsLit "mdo") ||
+    rdrName == mkUnqual varName (fsLit "rec")
+      = text "Perhaps you meant to use RecursiveDo"
+  | otherwise = Outputable.empty
+
 {-
 ************************************************************************
 *                                                                      *

compiler/utils/StringBuffer.hs

@@ -36,6 +36,7 @@ module StringBuffer
         -- * Conversion
         lexemeToString,
         lexemeToFastString,
+        decodePrevNChars,
 
          -- * Parsing integers
         parseUnsignedInteger,
@@ -263,6 +264,20 @@ lexemeToFastString (StringBuffer buf _ cur) len =
      withForeignPtr buf $ \ptr ->
        return $! mkFastStringBytes (ptr `plusPtr` cur) len
 
+-- | Return the previous @n@ characters (or fewer if we are less than @n@
+-- characters into the buffer.
+decodePrevNChars :: Int -> StringBuffer -> String
+decodePrevNChars n (StringBuffer buf _ cur) =
+    inlinePerformIO $ withForeignPtr buf $ \p0 ->
+      go p0 n "" (p0 `plusPtr` (cur - 1))
+  where
+    go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String
+    go buf0 n acc p | n == 0 || buf0 >= p = return acc
+    go buf0 n acc p = do
+        p' <- utf8PrevChar p
+        let (c,_) = utf8DecodeChar p'
+        go buf0 (n - 1) (c:acc) p'
+
 -- -----------------------------------------------------------------------------
 -- Parsing integer strings in various bases
 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer

testsuite/tests/ghci/prog011/prog011.stderr

@@ -1,2 +1,2 @@
 
-prog011.hx:14:22: Empty 'do' block
+prog011.hx:14:22: error: Empty 'do' block