(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
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)
(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
-- 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 $
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
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
-----------------------------------------------------------------------------
-- 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)
-----------------------------------------------------------------------------
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