Fix warnings and fatal parsing errors

3 files changed, 92 insertions, 84 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9eed1e6572..5fb48eba36 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
@@ -1923,17 +1923,18 @@ data LayoutContext
   | Layout !Int !GenSemic
   deriving Show
 
+-- | The result of running a parser.
 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
+  = POk      -- ^ The parser has consumed a (possibly empty) prefix
+             --   of the input and produced a result. Use 'getMessages'
+             --   to check for accumulated warnings and non-fatal errors.
+      PState -- ^ The resulting parsing state. Can be used to resume parsing.
+      a      -- ^ The resulting value.
+  | PFailed  -- ^ The parser has consumed a (possibly empty) prefix
+             --   of the input and failed.
+      PState -- ^ The parsing state right before failure, including the fatal
+             --   parse error. 'getMessages' and 'getErrorMessages' must return
+             --   a non-empty bag of errors.
 
 -- | Test whether a 'WarningFlag' is set
 warnopt :: WarningFlag -> ParserFlags -> Bool
@@ -2003,6 +2004,7 @@ data ALRLayout = ALRLayoutLet
                | ALRLayoutOf
                | ALRLayoutDo
 
+-- | The parsing monad, isomorphic to @StateT PState Maybe@.
 newtype P a = P { unP :: PState -> ParseResult a }
 
 instance Functor P where
@@ -2019,7 +2021,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 +2030,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
@@ -2477,6 +2468,18 @@ mkPStatePure options buf loc =
       annotations_comments = []
     }
 
+-- | Add a non-fatal error. Use this when the parser can produce a result
+--   despite the error.
+--
+--   For example, when GHC encounters a @forall@ in a type,
+--   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
+--   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
+--   the accumulator.
+--
+--   Control flow wise, non-fatal errors act like warnings: they are added
+--   to the accumulator and parsing continues. This allows GHC to report
+--   more than one parse error per file.
+--
 addError :: SrcSpan -> SDoc -> P ()
 addError srcspan msg
  = P $ \s@PState{messages=m} ->
@@ -2488,6 +2491,14 @@ addError srcspan msg
                in (ws, es')
        in POk s{messages=m'} ()
 
+-- | Add a fatal error. This will be the last error reported by the parser, and
+--   the parser will not produce any result, ending in a 'PFailed' state.
+addFatalError :: SrcSpan -> SDoc -> P a
+addFatalError span msg =
+  addError span msg >> P PFailed
+
+-- | Add a warning to the accumulator.
+--   Use 'getMessages' to get the accumulated warnings.
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=m, options=o} ->
@@ -2522,6 +2533,14 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d =
   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
 
+-- | Get a bag of the errors that have been accumulated so far.
+--   Does not take -Werror into account.
+getErrorMessages :: PState -> DynFlags -> ErrorMessages
+getErrorMessages PState{messages=m} d =
+  let (_, es) = m d in es
+
+-- | Get the warnings and errors accumulated so far.
+--   Does not take -Werror into account.
 getMessages :: PState -> DynFlags -> Messages
 getMessages p@PState{messages=m} d =
   let (ws, es) = m d
@@ -2542,7 +2561,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 +2621,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.
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 69114ee9c2..78f1013151 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -973,13 +973,13 @@ maybe_safe :: { ([AddAnn],Bool) }
         | {- empty -}                           { ([],False) }
 
 maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
-        : STRING  {% let pkgFS = getSTRING $1 in
-                     if looksLikePackageName (unpackFS pkgFS)
-                        then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))
-                        else parseErrorSDoc (getLoc $1) $ vcat [
-                             text "parse error" <> colon <+> quotes (ppr pkgFS),
+        : STRING  {% do { let { pkgFS = getSTRING $1 }
+                        ; unless (looksLikePackageName (unpackFS pkgFS)) $
+                             addError (getLoc $1) $ vcat [
+                             text "Parse error" <> colon <+> quotes (ppr pkgFS),
                              text "Version number or non-alphanumeric" <+>
-                             text "character in package name"] }
+                             text "character in package name"]
+                        ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
         | {- empty -}                           { ([],Nothing) }
 
 optqualified :: { ([AddAnn],Bool) }
@@ -3668,7 +3668,7 @@ getSCC lt = do let s = getSTRING lt
                    err = "Spaces are not allowed in SCCs"
                -- We probably actually want to be more restrictive than this
                if ' ' `elem` unpackFS s
-                   then failSpanMsgP (getLoc lt) (text err)
+                   then addFatalError (getLoc lt) (text err)
                    else return s
 
 -- Utilities for combining source spans
@@ -3756,23 +3756,15 @@ fileSrcSpan = do
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
   mwiEnabled <- getBit MultiWayIfBit
-  unless mwiEnabled $ parseErrorSDoc span $
+  unless mwiEnabled $ addError span $
     text "Multi-way if-expressions need MultiWayIf turned on"
 
--- Hint about if usage for beginners
-hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs)
-hintIf span msg = do
-  mwiEnabled <- getBit MultiWayIfBit
-  if mwiEnabled
-    then parseErrorSDoc span $ text $ "parse error in if statement"
-    else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
-
 -- Hint about explicit-forall
 hintExplicitForall :: Located Token -> P ()
 hintExplicitForall tok = do
     forall   <- getBit ExplicitForallBit
     rulePrag <- getBit InRulePragBit
-    unless (forall || rulePrag) $ parseErrorSDoc (getLoc tok) $ vcat
+    unless (forall || rulePrag) $ addError (getLoc tok) $ vcat
       [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"
       , text "Perhaps you intended to use RankNTypes or a similar language"
       , text "extension to enable explicit-forall syntax:" <+>
@@ -3803,13 +3795,13 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a
 reportEmptyDoubleQuotes span = do
     thQuotes <- getBit ThQuotesBit
     if thQuotes
-      then parseErrorSDoc span $ vcat
+      then addFatalError span $ vcat
         [ text "Parser error on `''`"
         , text "Character literals may not be empty"
         , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
         , text "but the type variable or constructor is missing"
         ]
-      else parseErrorSDoc span $ vcat
+      else addFatalError span $ vcat
         [ text "Parser error on `''`"
         , text "Character literals may not be empty"
         ]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index ddbd885576..606e2e7d6b 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -60,7 +60,7 @@ module   RdrHsSyn (
         checkRuleTyVarBndrNames,
         checkRecordSyntax,
         checkEmptyGADTs,
-        parseErrorSDoc, hintBangPat,
+        addFatalError, hintBangPat,
         TyEl(..), mergeOps, mergeDataCon,
 
         -- Help with processing exports
@@ -357,7 +357,7 @@ mkRoleAnnotDecl loc tycon roles
             let nearby = fuzzyLookup (unpackFS role)
                   (mapFst unpackFS possible_roles)
             in
-            parseErrorSDoc loc_role
+            addFatalError loc_role
               (text "Illegal role name" <+> quotes (ppr role) $$
                suggestions nearby)
     parse_role _ = panic "parse_role: Impossible Match"
@@ -427,7 +427,7 @@ cvBindsAndSigs fb = go (fromOL fb)
                DocD _ d
                  -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
                SpliceD _ d
-                 -> parseErrorSDoc l $
+                 -> addFatalError l $
                     hang (text "Declaration splices are allowed only" <+>
                           text "at the top level:")
                        2 (ppr d)
@@ -620,23 +620,23 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
     fromDecl (dL->L loc decl) = extraDeclErr loc decl
 
     extraDeclErr loc decl =
-        parseErrorSDoc loc $
+        addFatalError loc $
         text "pattern synonym 'where' clause must contain a single binding:" $$
         ppr decl
 
     wrongNameBindingErr loc decl =
-      parseErrorSDoc loc $
+      addFatalError loc $
       text "pattern synonym 'where' clause must bind the pattern synonym's name"
       <+> quotes (ppr patsyn_name) $$ ppr decl
 
     wrongNumberErr loc =
-      parseErrorSDoc loc $
+      addFatalError loc $
       text "pattern synonym 'where' clause cannot be empty" $$
       text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
 
 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
 recordPatSynErr loc pat =
-    parseErrorSDoc loc $
+    addFatalError loc $
     text "record syntax not supported for pattern synonym declarations:" $$
     ppr pat
 
@@ -816,7 +816,7 @@ checkTyVarsP pp_what equals_or_where tc tparms
 
 eitherToP :: Either (SrcSpan, SDoc) a -> P a
 -- Adapts the Either monad to the P monad
-eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
+eitherToP (Left (loc, doc)) = addFatalError loc doc
 eitherToP (Right thing)     = return thing
 
 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
@@ -915,7 +915,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
   where check (dL->L loc (Unqual occ)) = do
           when ((occNameString occ ==) `any` ["forall","family","role"])
-               (parseErrorSDoc loc (text $ "parse error on input "
+               (addFatalError loc (text $ "parse error on input "
                                     ++ occNameString occ))
         check _ = panic "checkRuleTyVarBndrNames"
 
@@ -977,7 +977,7 @@ checkTyClHdr is_cls ty
                  | otherwise = getName (tupleTyCon Boxed arity)
           -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)
     go l _ _ _ _
-      = parseErrorSDoc l (text "Malformed head of type or class declaration:"
+      = addFatalError l (text "Malformed head of type or class declaration:"
                           <+> ppr ty)
 
 -- | Yield a parse error if we have a function applied directly to a do block
@@ -1087,7 +1087,7 @@ checkAPat msg loc e0 = do
    EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
    HsLit _ (HsStringPrim _ _) -- (#13260)
-       -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:"
+       -> addFatalError loc (text "Illegal unboxed string literal in pattern:"
                               $$ ppr e0)
 
    HsLit _ l  -> return (LitPat noExt l)
@@ -1137,7 +1137,7 @@ checkAPat msg loc e0 = do
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
                                            [e | (dL->L _ (Present _ e)) <- es]
                                    return (TuplePat noExt ps b)
-     | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:"
+     | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
                                         $$ ppr e0)
 
    ExplicitSum _ alt arity expr -> do
@@ -1168,7 +1168,7 @@ checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
                                      return (cL l (fld { hsRecFieldArg = p }))
 
 patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
-patFail msg loc e = parseErrorSDoc loc err
+patFail msg loc e = addFatalError loc err
     where err = text "Parse error in pattern:" <+> ppr e
              $$ msg
 
@@ -1250,7 +1250,7 @@ checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
   = return lrdr
 
 checkValSigLhs lhs@(dL->L l _)
-  = parseErrorSDoc l ((text "Invalid type signature:" <+>
+  = addFatalError l ((text "Invalid type signature:" <+>
                        ppr lhs <+> text ":: ...")
                       $$ text hint)
   where
@@ -1482,7 +1482,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
                     bt = HsBangTy noExt strictMark a
               ; addAnnsAt bl anns
               ; return (cL bl bt) }
-      else parseErrorSDoc l unpkError
+      else addFatalError l unpkError
       where
         unpkSDoc = case unpkSrc of
           NoSourceText -> ppr unpk
@@ -1951,9 +1951,9 @@ checkCmdGRHS = locMap $ const convert
 
 
 cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
-cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
+cmdFail loc e = addFatalError loc (text "Parse error in command:" <+> ppr e)
 cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
-cmdStmtFail loc e = parseErrorSDoc loc
+cmdStmtFail loc e = addFatalError loc
                     (text "Parse error in command statement:" <+> ppr e)
 
 ---------------------------------------------------------------------------
@@ -1968,7 +1968,7 @@ checkPrecP
 checkPrecP (dL->L l (_,i)) (dL->L _ ol)
  | 0 <= i, i <= maxPrecedence = pure ()
  | all specialOp ol = pure ()
- | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
+ | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
   where
     specialOp op = unLoc op `elem` [ eqTyCon_RDR
                                    , getRdrName funTyCon ]
@@ -1983,7 +1983,7 @@ mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
   | isRdrDataCon c
   = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp _ (fs,dd)
-  | Just dd_loc <- dd = parseErrorSDoc dd_loc (text "You cannot use `..' in a record update")
+  | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
@@ -2051,7 +2051,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
     mkCImport = do
       let e = unpackFS entity
       case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
-        Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
+        Nothing         -> addFatalError loc (text "Malformed entity string")
         Just importSpec -> returnSpec importSpec
 
     -- currently, all the other import conventions only support a symbol name in
@@ -2189,13 +2189,13 @@ mkModuleImpExp (dL->L l specname) subs =
             in (\newName
                         -> IEThingWith noExt (cL l newName) pos ies [])
                <$> nameT
-          else parseErrorSDoc l
+          else addFatalError l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
     name = ieNameVal specname
     nameT =
       if isVarNameSpace (rdrNameSpace name)
-        then parseErrorSDoc l
+        then addFatalError l
               (text "Expecting a type constructor but found a variable,"
                <+> quotes (ppr name) <> text "."
               $$ if isSymOcc $ rdrNameOcc name
@@ -2230,7 +2230,7 @@ checkImportSpec ie@(dL->L _ specs) =
       (l:_) -> importSpecError l
   where
     importSpecError l =
-      parseErrorSDoc l
+      addFatalError l
         (text "Illegal import form, this syntax can only be used to bundle"
         $+$ text "pattern synonyms with types in module exports.")
 
@@ -2275,39 +2275,36 @@ failOpFewArgs :: Located RdrName -> P a
 failOpFewArgs (dL->L loc op) =
   do { star_is_type <- getBit StarIsTypeBit
      ; let msg = too_few $$ starInfo star_is_type op
-     ; parseErrorSDoc loc msg }
+     ; addFatalError loc msg }
   where
     too_few = text "Operator applied to too few arguments:" <+> ppr op
 
 failOpDocPrev :: SrcSpan -> P a
-failOpDocPrev loc = parseErrorSDoc loc msg
+failOpDocPrev loc = addFatalError loc msg
   where
     msg = text "Unexpected documentation comment."
 
 failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
-failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg
+failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg
   where
     msg = text "Strictness annotation applied to a compound type." $$
           text "Did you mean to add parentheses?" $$
           nest 2 (ppr str <> parens (ppr ty))
 
 failOpStrictnessPosition :: Located SrcStrictness -> P a
-failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg
+failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
   where
     msg = text "Strictness annotation cannot appear in this position."
 
 -----------------------------------------------------------------------------
 -- Misc utils
 
-parseErrorSDoc :: SrcSpan -> SDoc -> P a
-parseErrorSDoc span s = failSpanMsgP span s
-
 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
 hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
 hintBangPat span e = do
     bang_on <- getBit BangPatBit
     unless bang_on $
-      parseErrorSDoc span
+      addFatalError span
         (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
 
 data SumOrTuple
@@ -2323,7 +2320,7 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
 mkSumOrTuple Unboxed _ (Sum alt arity e) =
     return (ExplicitSum noExt alt arity e)
 mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) =
-    parseErrorSDoc l (hang (text "Boxed sums not supported:") 2
+    addFatalError l (hang (text "Boxed sums not supported:") 2
                       (ppr_boxed_sum alt arity e))
   where
     ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc