diff options
author | Daniel Gröber <dxld@darkboxed.org> | 2019-05-25 11:27:22 +0200 |
---|---|---|
committer | Ben Gamari <ben@well-typed.com> | 2019-06-03 23:42:11 -0400 |
commit | 23f8525f4171fc220787e121e54f2a2705703047 (patch) | |
tree | bb546d73c32d8a7b22861947a0f5cad23b289541 | |
parent | 01bb7ec351563afbba5bdd8d3153b454e19eb1c5 (diff) | |
download | haskell-23f8525f4171fc220787e121e54f2a2705703047.tar.gz |
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
-rw-r--r-- | compiler/main/DriverPipeline.hs | 7 | ||||
-rw-r--r-- | compiler/main/GhcMake.hs | 26 | ||||
-rw-r--r-- | compiler/main/HeaderInfo.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr | 9 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/all.T | 1 |
5 files changed, 27 insertions, 31 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 8dd71d8317..887d8f5799 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1029,8 +1029,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 5dbf84afee..89399cf64a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -81,6 +81,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 @@ -2187,7 +2188,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 @@ -2199,7 +2200,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 @@ -2222,9 +2223,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 @@ -2331,9 +2332,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 @@ -2350,7 +2350,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) @@ -2362,7 +2362,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) @@ -2373,7 +2373,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 @@ -2470,13 +2470,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_hspp_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 3fd510bb86..b5079c184a 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 _ span err -> do -- assuming we're not logging warnings here as per below - parseError dflags span err - POk pst rdr_module -> do + return $ Left $ unitBag $ mkPlainErrMsg dflags span err + 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. @@ -136,9 +138,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 -------------------------------------------------------------- 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']) |