Fix warnings and fatal parsing errorswip/parse-errors

1 files changed, 19 insertions, 17 deletions

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9a4dd4aafe..5bc0f38eca 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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,
@@ -1022,7 +1027,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
@@ -1088,7 +1093,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"
 
@@ -1759,7 +1764,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))
@@ -1793,11 +1798,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)