Make downsweep return all errors per-module instead of throwing some
authorDaniel Gröber <dxld@darkboxed.org>
Sat, 25 May 2019 09:27:22 +0000 (11:27 +0200)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Thu, 30 May 2019 20:44:08 +0000 (16:44 -0400)
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

compiler/main/DriverPipeline.hs
compiler/main/GhcMake.hs
compiler/main/HeaderInfo.hs
testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
testsuite/tests/ghc-api/downsweep/all.T

index c8a1a9f..9ac973c 100644 (file)
@@ -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
index bfbeb55..341356f 100644 (file)
@@ -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 {..}
 
 
index e5e5efd..d5b3f90 100644 (file)
@@ -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.
index 2c01c92..11fd4b7 100644 (file)
@@ -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
index b379711..d7ed778 100644 (file)
@@ -1,6 +1,5 @@
 test('PartialDownsweep',
      [ extra_run_opts('"' + config.libdir + '"')
-     , exit_code(1)
      ],
      compile_and_run,
      ['-package ghc'])