Commit f7fd7fce authored by Thomas Schilling's avatar Thomas Schilling

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.
parent 51e6b90f
......@@ -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)
......
......@@ -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 $
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment