Commit 49012ebc authored by Dave Laing's avatar Dave Laing Committed by Ben Gamari

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
parent bc066558
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
{-# OPTIONS -fwarn-tabs #-}
module T12610 where
p = let x = 4
y = 5
in 12
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’
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment