Print warnings on parser failures (#12610).

Test Plan: validate

Reviewers: austin, bgamari, simonmar, mpickering

Reviewed By: mpickering

Subscribers: mpickering, rwbarton, thomie

GHC Trac Issues: #12610

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

compiler/backpack/DriverBkp.hs

@@ -80,7 +80,7 @@ doBackpack [src_filename] = do
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
     case unP parseBackpack (mkPState dflags buf loc) of
-        PFailed span err -> do
+        PFailed _ span err -> do
             liftIO $ throwOneError (mkPlainErrMsg dflags span err)
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an

compiler/cmm/CmmMonad.hs

@@ -49,7 +49,7 @@ thenPD :: PD a -> (a -> PD b) -> PD b
 (PD m) `thenPD` k = PD $ \d s ->
         case m d s of
                 POk s1 a         -> unPD (k a) d s1
-                PFailed span err -> PFailed span err
+                PFailed warnFn span err -> PFailed warnFn span err
 
 failPD :: String -> PD a
 failPD = liftP . fail

compiler/cmm/CmmParse.y

@@ -1403,9 +1403,11 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
   case unPD cmmParse dflags init_state of
-    PFailed span err -> do
+    PFailed warnFn span err -> do
         let msg = mkPlainErrMsg dflags span err
-        return ((emptyBag, unitBag msg), Nothing)
+            errMsgs = (emptyBag, unitBag msg)
+            warnMsgs = warnFn dflags
+        return (unionMessages warnMsgs errMsgs, Nothing)
     POk pst code -> do
         st <- initC
         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()

compiler/main/GHC.hs

@@ -1300,7 +1300,7 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
-    PFailed span err ->
+    PFailed _ span err ->
         do dflags <- getDynFlags
            liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
@@ -1313,7 +1313,7 @@ getRichTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
-    PFailed span err ->
+    PFailed _ span err ->
         do dflags <- getDynFlags
            liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
@@ -1481,7 +1481,7 @@ lookupName name =
 parser :: String         -- ^ Haskell module source text (full Unicode is supported)
        -> DynFlags       -- ^ the flags
        -> FilePath       -- ^ the filename (for source locations)
-       -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+       -> (WarningMessages, Either ErrorMessages (Located (HsModule RdrName)))
 
 parser str dflags filename =
    let
@@ -1490,9 +1490,10 @@ parser str dflags filename =
    in
    case unP Parser.parseModule (mkPState dflags buf loc) of
 
-     PFailed span err   ->
-         Left (unitBag (mkPlainErrMsg dflags span err))
+     PFailed warnFn span err   ->
+         let (warns,_) = warnFn dflags in
+         (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst dflags in
-         Right (warns, rdr_module)
+         (warns, Right rdr_module)

compiler/main/HeaderInfo.hs

@@ -63,7 +63,9 @@ getImports :: DynFlags
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
   case unP parseHeader (mkPState dflags buf loc) of
-    PFailed span err -> parseError dflags span err
+    PFailed _ span err -> do
+        -- assuming we're not logging warnings here as per below
+      parseError dflags span err
     POk pst rdr_module -> do
       let _ms@(_warns, errs) = getMessages pst dflags
       -- don't log warnings: they'll be reported when we parse the file

compiler/main/HscMain.hs

@@ -328,7 +328,9 @@ hscParse' mod_summary
                  | otherwise = parseModule
 
     case unP parseMod (mkPState dflags buf loc) of
-        PFailed span err ->
+        PFailed warnFn span err -> do
+            logWarningsReportErrors (warnFn dflags)
+            handleWarnings
             liftIO $ throwOneError (mkPlainErrMsg dflags span err)
 
         POk pst rdr_module -> do
@@ -1705,7 +1707,9 @@ hscParseThingWithLocation source linenumber parser str
         loc = mkRealSrcLoc (fsLit source) linenumber 1
 
     case unP parser (mkPState dflags buf loc) of
-        PFailed span err -> do
+        PFailed warnFn span err -> do
+            logWarningsReportErrors (warnFn dflags)
+            handleWarnings
             let msg = mkPlainErrMsg dflags span err
             throwErrors $ unitBag msg
 

compiler/main/InteractiveEval.hs

@@ -782,14 +782,14 @@ isStmt :: DynFlags -> String -> Bool
 isStmt dflags stmt =
   case parseThing Parser.parseStmt dflags stmt of
     Lexer.POk _ _ -> True
-    Lexer.PFailed _ _ -> False
+    Lexer.PFailed _ _ _ -> False
 
 -- | Returns @True@ if passed string has an import declaration.
 hasImport :: DynFlags -> String -> Bool
 hasImport dflags stmt =
   case parseThing Parser.parseModule dflags stmt of
     Lexer.POk _ thing -> hasImports thing
-    Lexer.PFailed _ _ -> False
+    Lexer.PFailed _ _ _ -> False
   where
     hasImports = not . null . hsmodImports . unLoc
 
@@ -798,7 +798,7 @@ isImport :: DynFlags -> String -> Bool
 isImport dflags stmt =
   case parseThing Parser.parseImport dflags stmt of
     Lexer.POk _ _ -> True
-    Lexer.PFailed _ _ -> False
+    Lexer.PFailed _ _ _ -> False
 
 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
 isDecl :: DynFlags -> String -> Bool
@@ -808,7 +808,7 @@ isDecl dflags stmt = do
       case unLoc thing of
         SpliceD _ -> False
         _ -> True
-    Lexer.PFailed _ _ -> False
+    Lexer.PFailed _ _ _ -> False
 
 parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
 parseThing parser dflags stmt = do

compiler/parser/Lexer.x

@@ -1800,10 +1800,14 @@ data LayoutContext
 data ParseResult a
   = POk PState a
   | PFailed
-        SrcSpan         -- The start and end of the text span related to
-                        -- the error.  Might be used in environments which can
-                        -- show this span, e.g. by highlighting it.
-        MsgDoc          -- The error message
+        (DynFlags -> Messages) -- A function that returns warnings that
+                               -- accumulated during parsing, including
+                               -- the warnings related to tabs.
+        SrcSpan                -- The start and end of the text span related
+                               -- to the error.  Might be used in environments
+                               -- which can show this span, e.g. by
+                               -- highlighting it.
+        MsgDoc                 -- The error message
 
 -- | Test whether a 'WarningFlag' is set
 warnopt :: WarningFlag -> ParserFlags -> Bool
@@ -1902,19 +1906,27 @@ thenP :: P a -> (a -> P b) -> P b
 (P m) `thenP` k = P $ \ s ->
         case m s of
                 POk s1 a         -> (unP (k a)) s1
-                PFailed span err -> PFailed span err
+                PFailed warnFn span err -> PFailed warnFn span err
 
 failP :: String -> P a
-failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
+failP msg =
+  P $ \s ->
+    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
 
 failMsgP :: String -> P a
-failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
+failMsgP msg =
+  P $ \s ->
+    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
 
 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
+failLocMsgP loc1 loc2 str =
+  P $ \s ->
+    PFailed (getMessages s) (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
 
 failSpanMsgP :: SrcSpan -> SDoc -> P a
-failSpanMsgP span msg = P $ \_ -> PFailed span msg
+failSpanMsgP span msg =
+  P $ \s ->
+    PFailed (getMessages s) span msg
 
 getPState :: P PState
 getPState = P $ \s -> POk s s
@@ -2375,8 +2387,10 @@ popContext :: P ()
 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
                               last_len = len, last_loc = last_loc }) ->
   case ctx of
-        (_:tl) -> POk s{ context = tl } ()
-        []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
+        (_:tl) ->
+          POk s{ context = tl } ()
+        []     ->
+          PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
 
 -- Push a new layout context at the indentation of the last token read.
 pushCurrentContext :: GenSemic -> P ()
@@ -2433,9 +2447,9 @@ srcParseErr options buf len
 -- the location of the error.  This is the entry point for errors
 -- detected during parsing.
 srcParseFail :: P a
-srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len,
+srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
                             last_loc = last_loc } ->
-    PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
+    PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
 
 -- A lexical error is reported at a particular position in the source file,
 -- not over a token range.

testsuite/tests/parser/should_fail/T12610.hs

+{-# OPTIONS -fwarn-tabs #-}
+module T12610 where
+
+p = let  x = 4
+	y = 5
+    in 12

testsuite/tests/parser/should_fail/T12610.stderr

+
+T12610.hs:5:1: warning: [-Wtabs (in -Wdefault)]
+    Tab character found here.
+    Please use spaces instead.
+
+T12610.hs:5:9: parse error on input ‘y’

testsuite/tests/parser/should_fail/all.T

@@ -55,7 +55,7 @@ test('T3153', normal, compile_fail, [''])
 test('T3751', normal, compile_fail, [''])
 
 test('position001', normal, compile_fail, [''])
-test('position002', normal, compile_fail, [''])
+test('position002', normal, compile_fail, ['-Wno-tabs'])
 
 test('T1344a', normal, compile_fail, [''])
 test('T1344b', normal, compile_fail, [''])
@@ -101,3 +101,4 @@ test('T13414', literate, compile_fail, [''])
 test('T8501a', normal, compile_fail, [''])
 test('T8501b', normal, compile_fail, [''])
 test('T8501c', normal, compile_fail, [''])
+test('T12610', normal, compile_fail, [''])