parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
+ getModSummary,
-- * Parsing Haddock comments
parseHaddockComment,
import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
-#if __GLASGOW_HASKELL__ >= 609
-import Data.Typeable (cast)
-#endif
import Prelude hiding (init)
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: DynFlags -> IO a -> IO a
+defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
-#if __GLASGOW_HASKELL__ < 609
- handle (\exception -> do
+ ghandle (\exception -> liftIO $ do
hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ ->
- fatalErrorMsg dflags (text (show exception))
- AsyncException StackOverflow ->
- fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- ExitException _ -> throw exception
- _ ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
- ) $
-#else
- handle (\(SomeException exception) -> do
- hFlush stdout
- case cast exception of
+ case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
Just (ioe :: IOException) ->
fatalErrorMsg dflags (text (show ioe))
- _ -> case cast exception of
+ _ -> case fromException exception of
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _ -> case cast exception of
+ _ -> case fromException exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg dflags
(text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
-#endif
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
handleErrMsg
- (\em -> do printBagOfErrors dflags (unitBag em)
- exitWith (ExitFailure 1)) $
+ (\em -> liftIO $ do
+ printBagOfErrors dflags (unitBag em)
+ exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions
handleGhcException
- (\ge -> do
+ (\ge -> liftIO $ do
hFlush stdout
case ge of
PhaseFailed _ code -> exitWith code
-- - default methods are turned into top-level decls.
-- - dictionary bindings
+-- | Return the 'ModSummary' of a module with the given name.
+--
+-- The module must be part of the module graph (see 'hsc_mod_graph' and
+-- 'ModuleGraph'). If this is not the case, this function will throw a
+-- 'GhcApiError'.
+--
+-- This function ignores boot modules and requires that there is only one
+-- non-boot module with the given name.
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
- case [ ms | ms <- mg, ms_mod_name ms == mod ] of
+ case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
[] -> throw $ mkApiErr (text "Module not part of module graph")
- (ms:_) -> return ms
+ [ms] -> return ms
+ multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
-parseModule :: GhcMonad m => ModuleName -> m ParsedModule
-parseModule mod = do
- ms <- getModSummary mod
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
hsc_env0 <- getSession
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
rdr_module <- parseFile hsc_env ms
Just modSummary -> do
-- Now we have the module name;
-- parse, typecheck and desugar the module
- let mod = ms_mod_name modSummary
mod_guts <- coreModule `fmap`
- (desugarModule =<< typecheckModule =<< parseModule mod)
+ (desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM gutsToCoreModule $
if simplify
then do