summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DriverPipeline.hs7
-rw-r--r--compiler/main/GhcMake.hs26
-rw-r--r--compiler/main/HeaderInfo.hs14
-rw-r--r--testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr9
-rw-r--r--testsuite/tests/ghc-api/downsweep/all.T1
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'])
View Lorry Controller Status