parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
+ getModSummary,
-- * Parsing Haddock comments
parseHaddockComment,
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
- GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
+ GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
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
- 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
+ ghandle (\exception -> liftIO $ 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
local_opts = getOptions dflags buf src_fn
--
(dflags', leftovers, warns)
- <- parseDynamicFlags dflags local_opts
+ <- parseDynamicNoPackageFlags dflags local_opts
liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
getHistorySpan h = withSession $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
-obtainTerm :: GhcMonad m => Bool -> Id -> m Term
-obtainTerm force id = withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTerm hsc_env force id
-
-obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term
-obtainTerm1 force mb_ty a =
+obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a =
withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
+ liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
-obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermB bound force id =
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id =
withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermB hsc_env bound force id
+ liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
projects / ghc-hetmet.git / blobdiff