Fix warnings and fatal parsing errors
authorVladislav Zavialov <vlad.z.4096@gmail.com>
Sat, 16 Feb 2019 00:38:21 +0000 (03:38 +0300)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Mon, 18 Feb 2019 01:04:33 +0000 (20:04 -0500)
22 files changed:
compiler/backpack/DriverBkp.hs
compiler/cmm/CmmMonad.hs
compiler/cmm/CmmParse.y
compiler/main/ErrUtils.hs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
testsuite/tests/parser/should_fail/T16270.hs
testsuite/tests/parser/should_fail/T16270.stderr
testsuite/tests/parser/should_fail/T16270h.hs [new file with mode: 0644]
testsuite/tests/parser/should_fail/T16270h.stderr [new file with mode: 0644]
testsuite/tests/parser/should_fail/T3095.hs
testsuite/tests/parser/should_fail/T3095.stderr
testsuite/tests/parser/should_fail/T9225.stderr
testsuite/tests/parser/should_fail/all.T
testsuite/tests/rename/should_fail/rnfail052.stderr
utils/haddock

index e10d6d1..d7763f7 100644 (file)
@@ -82,8 +82,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
-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
+        PFailed pst -> throwErrors (getErrorMessages pst dflags)
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an
             -- LHsUnit HsComponentId.  So let's rename it.
index 821c0a6..a04c4ad 100644 (file)
@@ -50,7 +50,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 warnFn span err -> PFailed warnFn span err
+                PFailed s1 -> PFailed s1
 
 failPD :: String -> PD a
 failPD = liftP . fail
index e580368..bb389d1 100644 (file)
@@ -1424,11 +1424,8 @@ 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 warnFn span err -> do
-        let msg = mkPlainErrMsg dflags span err
-            errMsgs = (emptyBag, unitBag msg)
-            warnMsgs = warnFn dflags
-        return (unionMessages warnMsgs errMsgs, Nothing)
+    PFailed pst ->
+        return (getMessages pst dflags, Nothing)
     POk pst code -> do
         st <- initC
         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
index ac97f17..9ee6856 100644 (file)
@@ -22,6 +22,7 @@ module ErrUtils (
         errMsgSpan, errMsgContext,
         errorsFound, isEmptyMessages,
         isWarnMsgFatal,
+        warningsToMessages,
 
         -- ** Formatting
         pprMessageBag, pprErrMsgBagWithLoc,
@@ -359,6 +360,15 @@ isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
 errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
+warningsToMessages :: DynFlags -> WarningMessages -> Messages
+warningsToMessages dflags =
+  partitionBagWith $ \warn ->
+    case isWarnMsgFatal dflags warn of
+      Nothing -> Left warn
+      Just err_reason ->
+        Right warn{ errMsgSeverity = SevError
+                  , errMsgReason = ErrReason err_reason }
+
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle dflags unqual
index a1cc4a7..9e58f35 100644 (file)
@@ -337,7 +337,7 @@ import Annotations
 import Module
 import Panic
 import Platform
-import Bag              ( listToBag, unitBag )
+import Bag              ( listToBag )
 import ErrUtils
 import MonadUtils
 import Util
@@ -1363,9 +1363,9 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
-    PFailed _ span err ->
+    PFailed pst ->
         do dflags <- getDynFlags
-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           throwErrors (getErrorMessages pst dflags)
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1376,9 +1376,9 @@ 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 pst ->
         do dflags <- getDynFlags
-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           throwErrors (getErrorMessages pst dflags)
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1553,9 +1553,9 @@ parser str dflags filename =
    in
    case unP Parser.parseModule (mkPState dflags buf loc) of
 
-     PFailed warnFn span err   ->
-         let (warns,_) = warnFn dflags in
-         (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
+     PFailed pst ->
+         let (warns,errs) = getMessages pst dflags in
+         (warns, Left errs)
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst dflags in
index 3fd510b..450ac95 100644 (file)
@@ -66,9 +66,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 -> do
+    PFailed pst -> do
         -- assuming we're not logging warnings here as per below
-      parseError dflags span err
+      throwErrors (getErrorMessages pst dflags)
     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
@@ -136,9 +136,6 @@ mkPrelImports this_mod loc implicit_prelude import_decls
                                 ideclAs        = Nothing,
                                 ideclHiding    = Nothing  }
 
-parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
-parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
-
 --------------------------------------------------------------
 -- Get options
 --------------------------------------------------------------
index 674afc9..bb16ae3 100644 (file)
@@ -233,9 +233,15 @@ logWarningsReportErrors (warns,errs) = do
     logWarnings warns
     when (not $ isEmptyBag errs) $ throwErrors errs
 
--- | Throw some errors.
-throwErrors :: ErrorMessages -> Hsc a
-throwErrors = liftIO . throwIO . mkSrcErr
+-- | Log warnings and throw errors, assuming the messages
+-- contain at least one error (e.g. coming from PFailed)
+handleWarningsThrowErrors :: Messages -> Hsc a
+handleWarningsThrowErrors (warns, errs) = do
+    logWarnings warns
+    dflags <- getDynFlags
+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
+    liftIO $ printBagOfErrors dflags wWarns
+    throwErrors (unionBags errs wErrs)
 
 -- | Deal with errors and warnings returned by a compilation step
 --
@@ -341,19 +347,18 @@ hscParse' mod_summary
                  | otherwise = parseModule
 
     case unP parseMod (mkPState dflags buf loc) of
-        PFailed warnFn span err -> do
-            logWarningsReportErrors (warnFn dflags)
-            handleWarnings
-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
-
+        PFailed pst ->
+            handleWarningsThrowErrors (getMessages pst dflags)
         POk pst rdr_module -> do
-            logWarningsReportErrors (getMessages pst dflags)
+            let (warns, errs) = getMessages pst dflags
+            logWarnings warns
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
                                    ppr rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
                                    showAstData NoBlankSrcSpan rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
                                    ppSourceStats False rdr_module
+            when (not $ isEmptyBag errs) $ throwErrors errs
 
             -- To get the list of extra source files, we take the list
             -- that the parser gave us,
@@ -1023,7 +1028,7 @@ checkSafeImports tcg_env
         | imv_is_safe v1 /= imv_is_safe v2
         = do
             dflags <- getDynFlags
-            throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
+            throwOneError $ mkPlainErrMsg dflags (imv_span v1)
               (text "Module" <+> ppr (imv_name v1) <+>
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
@@ -1089,7 +1094,7 @@ hscCheckSafe' m l = do
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
-            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
+            Nothing -> throwOneError $ mkPlainErrMsg dflags l
                          $ text "Can't load the interface file for" <+> ppr m
                            <> text ", to check that it can be safely imported"
 
@@ -1760,7 +1765,7 @@ hscParseExpr expr = do
   maybe_stmt <- hscParseStmt expr
   case maybe_stmt of
     Just (L _ (BodyStmt _ expr _ _)) -> return expr
-    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+    _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
       (text "not an expression:" <+> quotes (text expr))
 
 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
@@ -1794,11 +1799,8 @@ hscParseThingWithLocation source linenumber parser str
         loc = mkRealSrcLoc (fsLit source) linenumber 1
 
     case unP parser (mkPState dflags buf loc) of
-        PFailed warnFn span err -> do
-            logWarningsReportErrors (warnFn dflags)
-            handleWarnings
-            let msg = mkPlainErrMsg dflags span err
-            throwErrors $ unitBag msg
+        PFailed pst -> do
+            handleWarningsThrowErrors (getMessages pst dflags)
 
         POk pst thing -> do
             logWarningsReportErrors (getMessages pst dflags)
index d17fa5f..0ca7bda 100644 (file)
@@ -133,7 +133,7 @@ module HscTypes (
 
         -- * Compilation errors and warnings
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
-        throwOneError, handleSourceError,
+        throwOneError, throwErrors, handleSourceError,
         handleFlagWarnings, printOrThrowWarnings,
 
         -- * COMPLETE signature
@@ -278,8 +278,11 @@ srcErrorMessages (SourceError msgs) = msgs
 mkApiErr :: DynFlags -> SDoc -> GhcApiError
 mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
 
-throwOneError :: MonadIO m => ErrMsg -> m ab
-throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
+throwErrors :: MonadIO io => ErrorMessages -> io a
+throwErrors = liftIO . throwIO . mkSrcErr
+
+throwOneError :: MonadIO io => ErrMsg -> io a
+throwOneError = throwErrors . unitBag
 
 -- | A source error is an error that is caused by one or more errors in the
 -- source code.  A 'SourceError' is thrown by many functions in the
index 4e6d26b..5ff1b03 100644 (file)
@@ -816,14 +816,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
 
@@ -832,7 +832,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
@@ -842,7 +842,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
index 9eed1e6..5fb48eb 100644 (file)
@@ -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.
index 69114ee..78f1013 100644 (file)
@@ -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"
         ]
index ddbd885..606e2e7 100644 (file)
@@ -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
index fa788c2..0c5166d 100644 (file)
@@ -1,20 +1,13 @@
-{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse #-}
-
--- module T16270 (type G) where
---
--- ^ Uncommenting this line prevents other errors from printing
--- because HeaderInfo.getImports fails fast on parsing imports:
---
---      if errorsFound dflags ms
---        then throwIO $ mkSrcErr errs
---
--- :(
+{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse, NoMultiWayIf #-}
+{-# OPTIONS -Werror=missing-space-after-bang #-}
+
+module T16270 where
 
 c = do
-  if c then
-    False
-  else
-    True
+       if c then
+               False
+       else
+               True
 
 f = id do { 1 }
 g = id \x -> x
@@ -24,6 +17,20 @@ data Num a => D a
 data Pair a b = Pair { fst :: a, snd :: b }
 t = p { fst = 1, snd = True }
 
+z :: forall a. ()
 z = if True; then (); else ();
 
 data G a where
+
+multiWayIf !i = (a, b)
+  where
+    a = if | i -> True
+           | otherwise -> False
+    b = if | i -> False
+           | otherwise -> True
+
+-- a fatal error.
+k = let
+
+-- not reported, as the previous one was fatal.
+k = let
index 7877a28..7eccd95 100644 (file)
@@ -1,38 +1,61 @@
 
-T16270.hs:14:6: error:
+T16270.hs:7:1: warning: [-Wtabs (in -Wdefault)]
+    Tab character found here, and in five further locations.
+    Please use spaces instead.
+
+T16270.hs:7:12: error:
     Unexpected semi-colons in conditional:
         if c then False; else True
     Perhaps you meant to use DoAndIfThenElse?
 
-T16270.hs:19:8: error:
+T16270.hs:12:8: error:
     Unexpected do block in function application:
         do 1
     You could write it with parentheses
     Or perhaps you meant to enable BlockArguments?
 
-T16270.hs:20:8: error:
+T16270.hs:13:8: error:
     Unexpected lambda expression in function application:
         \ x -> x
     You could write it with parentheses
     Or perhaps you meant to enable BlockArguments?
 
-T16270.hs:22:6: error:
+T16270.hs:15:6: error:
     Illegal datatype context (use DatatypeContexts): Num a =>
 
-T16270.hs:24:22: error:
+T16270.hs:17:22: error:
     Illegal record syntax (use TraditionalRecordSyntax): {fst :: a,
                                                           snd :: b}
 
-T16270.hs:25:5: error:
+T16270.hs:18:5: error:
     Illegal record syntax (use TraditionalRecordSyntax): p {fst = 1,
                                                             snd = True}
 
-T16270.hs:27:8: error:
+T16270.hs:20:6: error:
+    Illegal symbol ‘forall’ in type
+    Perhaps you intended to use RankNTypes or a similar language
+    extension to enable explicit-forall syntax: forall <tvs>. <type>
+
+T16270.hs:21:8: error:
     Unexpected semi-colons in conditional:
         if True; then (); else ()
     Perhaps you meant to use DoAndIfThenElse?
 
-T16270.hs:29:10: error:
+T16270.hs:23:10: error:
     Illegal keyword 'where' in data declaration
     Perhaps you intended to use GADTs or a similar language
     extension to enable syntax: data T where
+
+T16270.hs:25:12: error: [-Wmissing-space-after-bang (in -Wdefault), -Werror=missing-space-after-bang]
+    Did you forget to enable BangPatterns?
+    If you mean to bind (!) then perhaps you want
+    to add a space after the bang for clarity.
+
+T16270.hs:27:9: error:
+    Multi-way if-expressions need MultiWayIf turned on
+
+T16270.hs:29:9: error:
+    Multi-way if-expressions need MultiWayIf turned on
+
+T16270.hs:36:1: error:
+    parse error (possibly incorrect indentation or mismatched brackets)
diff --git a/testsuite/tests/parser/should_fail/T16270h.hs b/testsuite/tests/parser/should_fail/T16270h.hs
new file mode 100644 (file)
index 0000000..c44d6ed
--- /dev/null
@@ -0,0 +1,13 @@
+-- We can't test module header parsing errors using the same file as other
+-- parsing errors (in ../T16270.hs) because HeaderInfo.getImports fails fast
+-- on parsing imports:
+--
+--      if errorsFound dflags ms
+--        then throwIO $ mkSrcErr errs
+--
+module T16270h (type G) where
+
+import "pkg?" M
+import "pkg!" M
+
+data G a
diff --git a/testsuite/tests/parser/should_fail/T16270h.stderr b/testsuite/tests/parser/should_fail/T16270h.stderr
new file mode 100644 (file)
index 0000000..fb7fc43
--- /dev/null
@@ -0,0 +1,11 @@
+
+T16270h.hs:8:22: error:
+    Illegal keyword 'type' (use ExplicitNamespaces to enable)
+
+T16270h.hs:10:8: error:
+    Parse error: ‘pkg?’
+    Version number or non-alphanumeric character in package name
+
+T16270h.hs:11:8: error:
+    Parse error: ‘pkg!’
+    Version number or non-alphanumeric character in package name
index ad6b62c..fc7889f 100644 (file)
@@ -2,4 +2,6 @@
 -- Trac #3095
 module T3095 where
 
-class Bla (forall x . x :: *) where
+import Data.Kind (Type)
+
+class Bla (forall x . x :: Type) where
index b2b6848..ea2ee44 100644 (file)
@@ -1,5 +1,11 @@
 
-T3095.hs:5:12: error:
+T3095.hs:7:12: error:
     Illegal symbol ‘forall’ in type
     Perhaps you intended to use RankNTypes or a similar language
     extension to enable explicit-forall syntax: forall <tvs>. <type>
+
+T3095.hs:7:12: error:
+    Unexpected type ‘forall x. x :: Type’
+    In the class declaration for ‘Bla’
+    A class declaration should have form
+      class Bla a where ...
index abbfd0a..4763302 100644 (file)
@@ -1,4 +1,4 @@
 
-T9225.hs:4:8:
-    parse error: ‘some-package-0.1.2.3’
+T9225.hs:4:8: error:
+    Parse error: ‘some-package-0.1.2.3’
     Version number or non-alphanumeric character in package name
index 1a049bb..aa089de 100644 (file)
@@ -142,3 +142,4 @@ test('unpack_empty_type', normal, compile_fail, [''])
 test('unpack_inside_type', normal, compile_fail, [''])
 test('unpack_before_opr', normal, compile_fail, [''])
 test('T16270', normal, compile_fail, [''])
+test('T16270h', normal, compile_fail, [''])
index 7979dac..b8501cf 100644 (file)
@@ -3,3 +3,13 @@ rnfail052.hs:6:6: error:
     Illegal symbol ‘forall’ in type
     Perhaps you intended to use RankNTypes or a similar language
     extension to enable explicit-forall syntax: forall <tvs>. <type>
+
+rnfail052.hs:9:14: error:
+    Illegal symbol ‘forall’ in type
+    Perhaps you intended to use RankNTypes or a similar language
+    extension to enable explicit-forall syntax: forall <tvs>. <type>
+
+rnfail052.hs:12:15: error:
+    Illegal symbol ‘forall’ in type
+    Perhaps you intended to use RankNTypes or a similar language
+    extension to enable explicit-forall syntax: forall <tvs>. <type>
index 33cdd81..edd500d 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 33cdd810e4222b92bc22f7f5b7196fc97fd3cea6
+Subproject commit edd500da16e44e3b211cbf3cb354db99a61f021c