Make downsweep return all errors per-module instead of throwing some

This enables API clients to handle such errors instead of immideately
crashing in the face of some kinds of user errors, which is arguably quite
bad UX.

Fixes #10887

5 files changed, 28 insertions, 29 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index c8a1a9f704..9ac973cbc4 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1032,8 +1032,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
         (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
           do
             buf <- hGetStringBuffer input_fn
-            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
-            return (Just buf, mod_name, imps, src_imps)
+            eimps <- getImports dflags buf input_fn (basename <.> suff)
+            case eimps of
+              Left errs -> throwErrors errs
+              Right (src_imps,imps,L _ mod_name) -> return
+                  (Just buf, mod_name, imps, src_imps)
 
   -- Take -o into account if present
   -- Very like -ohi, but we must *only* do this if we aren't linking
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index bfbeb55c75..341356f775 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -82,6 +82,7 @@ import Control.Concurrent.MVar
 import Control.Concurrent.QSem
 import Control.Exception
 import Control.Monad
+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
 import Data.IORef
 import Data.List
 import qualified Data.List as List
@@ -2237,7 +2238,7 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
                            Nothing    -> liftIO $ getModificationUTCTime src_fn
                         -- getModificationUTCTime may fail
 
-    new_summary src_fn src_timestamp = fmap Right $ do
+    new_summary src_fn src_timestamp = runExceptT $ do
         preimps@PreprocessedImports {..}
             <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
 
@@ -2249,7 +2250,7 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
         -- to findModule will find it, even if it's not on any search path
         mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location
 
-        makeNewModSummary hsc_env $ MakeNewModSummary
+        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
             { nms_src_fn = src_fn
             , nms_src_timestamp = src_timestamp
             , nms_is_boot = NotBoot
@@ -2272,9 +2273,9 @@ findSummaryBySourceFile summaries file
 
 checkSummaryTimestamp
     :: HscEnv -> DynFlags -> Bool -> IsBoot
-    -> (UTCTime -> IO (Either a ModSummary))
+    -> (UTCTime -> IO (Either e ModSummary))
     -> ModSummary -> ModLocation -> UTCTime
-    -> IO (Either a ModSummary)
+    -> IO (Either e ModSummary)
 checkSummaryTimestamp
   hsc_env dflags obj_allowed is_boot new_summary
   old_summary location src_timestamp
@@ -2381,9 +2382,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
           Nothing -> return $ Left $ noHsFileErr dflags loc src_fn
           Just t  -> new_summary location' mod src_fn t
 
-
     new_summary location mod src_fn src_timestamp
-      = fmap Right $ do
+      = runExceptT $ do
         preimps@PreprocessedImports {..}
             <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
 
@@ -2400,7 +2400,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                   | otherwise -> HsSrcFile
 
         when (pi_mod_name /= wanted_mod) $
-                throwOneError $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
+                throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
                               text "File name does not match module name:"
                               $$ text "Saw:" <+> quotes (ppr pi_mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -2412,7 +2412,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                         | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
                                 : thisUnitIdInsts dflags)
                         ])
-            in throwOneError $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
+            in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
                 text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
                 $$ if gopt Opt_BuildingCabalPackage dflags
                     then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
@@ -2423,7 +2423,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                                  suggested_instantiated_with <> text "\"" $$
                                 text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")
 
-        makeNewModSummary hsc_env $ MakeNewModSummary
+        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
             { nms_src_fn = src_fn
             , nms_src_timestamp = src_timestamp
             , nms_is_boot = is_boot
@@ -2520,13 +2520,13 @@ getPreprocessedImports
     -> FilePath
     -> Maybe Phase
     -> Maybe (StringBuffer, UTCTime)
-    -> IO PreprocessedImports
+    -> ExceptT ErrorMessages IO PreprocessedImports
 getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
   (pi_local_dflags, pi_hspp_fn)
-      <- preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
-  pi_hscpp_buf <- hGetStringBuffer pi_hspp_fn
+      <- liftIO $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
+  pi_hscpp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
   (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
-      <- getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+      <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
   return PreprocessedImports {..}
 
 
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index e5e5efd753..d5b3f90737 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -59,17 +59,19 @@ getImports :: DynFlags
                            --   reporting parse error locations.
            -> FilePath     -- ^ The original source filename (used for locations
                            --   in the function result)
-           -> IO ([(Maybe FastString, Located ModuleName)],
-                  [(Maybe FastString, Located ModuleName)],
-                  Located ModuleName)
+           -> IO (Either
+               ErrorMessages
+               ([(Maybe FastString, Located ModuleName)],
+                [(Maybe FastString, Located ModuleName)],
+                Located ModuleName))
               -- ^ The source imports, normal imports, and the module name.
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
   case unP parseHeader (mkPState dflags buf loc) of
-    PFailed pst -> do
+    PFailed pst ->
         -- assuming we're not logging warnings here as per below
-      throwErrors (getErrorMessages pst dflags)
-    POk pst rdr_module -> do
+      return $ Left $ getErrorMessages pst dflags
+    POk pst rdr_module -> fmap Right $ do
       let _ms@(_warns, errs) = getMessages pst dflags
       -- don't log warnings: they'll be reported when we parse the file
       -- for real.  See #2500.
diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
index 2c01c922ed..11fd4b73c8 100644
--- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
+++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
@@ -1,8 +1,3 @@
 == Parse error in export list
-PartialDownsweep: panic! (the 'impossible' happened)
-  (GHC version 8.9.0.20190523:
-	parse error on input ‘!’
-
-
-Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug
-
+== Parse error in import list
+== Parse error in export list with bypass module
diff --git a/testsuite/tests/ghc-api/downsweep/all.T b/testsuite/tests/ghc-api/downsweep/all.T
index b3797113bc..d7ed778f8e 100644
--- a/testsuite/tests/ghc-api/downsweep/all.T
+++ b/testsuite/tests/ghc-api/downsweep/all.T
@@ -1,6 +1,5 @@
 test('PartialDownsweep',
      [ extra_run_opts('"' + config.libdir + '"')
-     , exit_code(1)
      ],
      compile_and_run,
      ['-package ghc'])