1 files changed, 23 insertions, 32 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9eed1e6572..b7d8fb80f4 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -51,13 +51,13 @@ module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
    P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
    getRealSrcLoc, getPState, withThisPackage,
-   failLocMsgP, failSpanMsgP, srcParseFail,
-   getMessages,
+   failLocMsgP, srcParseFail,
+   getErrorMessages, getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..), getBit,
-   addWarning, addError,
+   addWarning, addError, addFatalError,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
    commentToAnnotation
@@ -977,7 +977,7 @@ hopefully_open_brace span buf len
                  Layout prev_off _ : _ -> prev_off < offset
                  _                     -> True
       if isOK then pop_and open_brace span buf len
-              else failSpanMsgP (RealSrcSpan span) (text "Missing block")
+              else addFatalError (RealSrcSpan span) (text "Missing block")
 
 pop_and :: Action -> Action
 pop_and act span buf len = do _ <- popLexState
@@ -1925,15 +1925,9 @@ data LayoutContext
 
 data ParseResult a
   = POk PState a
-  | PFailed
-        (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
+  | PFailed PState
+             -- The parsing state right before failure.
+             -- 'getMessages' must return a non-empty bag of errors.
 
 -- | Test whether a 'WarningFlag' is set
 warnopt :: WarningFlag -> ParserFlags -> Bool
@@ -2019,7 +2013,7 @@ instance Monad P where
 #endif
 
 instance MonadFail.MonadFail P where
-  fail = failP
+  fail = failMsgP
 
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
@@ -2028,27 +2022,16 @@ 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 warnFn span err -> PFailed warnFn span err
-
-failP :: String -> P a
-failP msg =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
+                PFailed s1 -> PFailed s1
 
 failMsgP :: String -> P a
-failMsgP msg =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
+failMsgP msg = do
+  pState <- getPState
+  addFatalError (RealSrcSpan (last_loc pState)) (text msg)
 
 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
 failLocMsgP loc1 loc2 str =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
-
-failSpanMsgP :: SrcSpan -> SDoc -> P a
-failSpanMsgP span msg =
-  P $ \s ->
-    PFailed (getMessages s) span msg
+  addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
 
 getPState :: P PState
 getPState = P $ \s -> POk s s
@@ -2488,6 +2471,10 @@ addError srcspan msg
                in (ws, es')
        in POk s{messages=m'} ()
 
+addFatalError :: SrcSpan -> SDoc -> P a
+addFatalError span msg =
+  addError span msg >> P PFailed
+
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=m, options=o} ->
@@ -2522,6 +2509,10 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d =
   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
 
+getErrorMessages :: PState -> DynFlags -> ErrorMessages
+getErrorMessages PState{messages=m} d =
+  let (_, es) = m d in es
+
 getMessages :: PState -> DynFlags -> Messages
 getMessages p@PState{messages=m} d =
   let (ws, es) = m d
@@ -2542,7 +2533,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
         (_:tl) ->
           POk s{ context = tl } ()
         []     ->
-          PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
+          unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
 
 -- Push a new layout context at the indentation of the last token read.
 pushCurrentContext :: GenSemic -> P ()
@@ -2602,7 +2593,7 @@ srcParseErr options buf len
 srcParseFail :: P a
 srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
                             last_loc = last_loc } ->
-    PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
+    unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
 
 -- A lexical error is reported at a particular position in the source file,
 -- not over a token range.