From f7fd7fce1c50ea0014ab88f52313058d402d346e Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Fri, 21 Nov 2008 14:13:39 +0000 Subject: [PATCH] Throw SourceErrors instead of ProgramErrors in main/HeaderInfo. Parse errors during dependency analysis or options parsing really shouldn't kill GHC; this is particularly annoying for GHC API clients. --- compiler/main/DriverPipeline.hs | 6 ++-- compiler/main/GHC.hs | 4 +-- compiler/main/HeaderInfo.hs | 59 ++++++++++++++++++++++++--------------- 3 files changed, 41 insertions(+), 28 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c65941c..2bf19b9 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -667,7 +667,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts liftIO $ handleFlagWarnings dflags warns -- XXX: may exit the program - liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error + checkProcessArgsResult unhandled_flags if not (dopt Opt_Cpp dflags) then -- no need to preprocess CPP, just pass input file along @@ -726,8 +726,8 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma m <- liftIO $ getCoreModuleName input_fn return (Nothing, mkModuleName m, [], []) - _ -> liftIO $ do - buf <- hGetStringBuffer input_fn + _ -> do + buf <- liftIO $ hGetStringBuffer input_fn (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) return (Just buf, mod_name, imps, src_imps) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1d745a2..d45109f 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -2029,7 +2029,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf (dflags', hspp_fn, buf) <- preprocessFile hsc_env file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- liftIO $ mkHomeModLocation dflags mod_name file @@ -2161,7 +2161,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ throwOneError $ mkPlainErrMsg mod_loc $ diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index daa66c7..21e6437 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -37,26 +37,39 @@ import ErrUtils import Util import Outputable import Pretty () -import Panic import Maybes -import Bag ( emptyBag, listToBag ) +import Bag ( emptyBag, listToBag, unitBag ) +import MonadUtils ( MonadIO ) import Exception import Control.Monad -import System.Exit import System.IO import Data.List -getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath - -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName) +------------------------------------------------------------------------------ + +-- | Parse the imports of a source file. +-- +-- Throws a 'SourceError' if parsing fails. +getImports :: GhcMonad m => + DynFlags + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> m ([Located ModuleName], [Located ModuleName], Located ModuleName) + -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do let loc = mkSrcLoc (mkFastString filename) 1 0 case unP parseHeader (mkPState buf loc dflags) of - PFailed span err -> parseError span err - POk pst rdr_module -> do - let ms = getMessages pst - printErrorsAndWarnings dflags ms - when (errorsFound dflags ms) $ exitWith (ExitFailure 1) + PFailed span err -> parseError span err + POk pst rdr_module -> do + let ms@(warns, errs) = getMessages pst + logWarnings warns + if errorsFound dflags ms + then liftIO $ throwIO $ mkSrcErr errs + else case rdr_module of L _ (HsModule mb_mod _ imps _ _ _ _) -> let @@ -71,7 +84,7 @@ getImports dflags buf filename source_filename = do in return (source_imps, ordinary_imps, mod) -parseError :: SrcSpan -> Message -> IO a +parseError :: GhcMonad m => SrcSpan -> Message -> m a parseError span err = throwOneError $ mkPlainErrMsg span err -- we aren't interested in package imports here, filter them out @@ -186,14 +199,14 @@ getOptions' dflags buf filename ----------------------------------------------------------------------------- -- Complain about non-dynamic flags in OPTIONS pragmas -checkProcessArgsResult :: [Located String] -> IO () +checkProcessArgsResult :: MonadIO m => [Located String] -> m () checkProcessArgsResult flags = when (notNull flags) $ - ghcError $ ProgramError $ showSDoc $ vcat $ map f flags - where f (L loc flag) - = hang (ppr loc <> char ':') 4 - (text "unknown flag in {-# OPTIONS #-} pragma:" <+> - text flag) + liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags + where mkMsg (L loc flag) + = mkPlainErrMsg loc $ + (text "unknown flag in {-# OPTIONS #-} pragma:" <+> + text flag) ----------------------------------------------------------------------------- @@ -209,15 +222,15 @@ checkExtension (L l ext) languagePragParseError :: SrcSpan -> a languagePragParseError loc = - pgmError - (showSDoc (mkLocMessage loc ( - text "cannot parse LANGUAGE pragma: comma-separated list expected"))) + throw $ mkSrcErr $ unitBag $ + (mkPlainErrMsg loc $ + text "cannot parse LANGUAGE pragma: comma-separated list expected") unsupportedExtnError :: SrcSpan -> String -> a unsupportedExtnError loc unsup = - pgmError (showSDoc (mkLocMessage loc ( - text "unsupported extension: " <> - text unsup))) + throw $ mkSrcErr $ unitBag $ + mkPlainErrMsg loc $ + text "unsupported extension: " <> text unsup optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages -- 1.7.10.4