-
--- | This is the way to get access to parsed and typechecked source code
--- for a module. 'checkModule' loads all the dependencies of the specified
--- module in the Session, and then attempts to typecheck the module. If
--- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
-checkModule session@(Session ref) mod = do
- -- load up the dependencies first
- r <- load session (LoadDependenciesOf mod)
- if (failed r) then return Nothing else do
-
- -- now parse & typecheck the module
- hsc_env <- readIORef ref
- let mg = hsc_mod_graph hsc_env
- case [ ms | ms <- mg, ms_mod_name ms == mod ] of
- [] -> return Nothing
- (ms:_) -> do
- mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
- case mbChecked of
- Nothing -> return Nothing
- Just (HscChecked parsed renamed Nothing) ->
- return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
- typecheckedSource = Nothing,
- checkedModuleInfo = Nothing }))
- Just (HscChecked parsed renamed
- (Just (tc_binds, rdr_env, details))) -> do
- let minf = ModuleInfo {
- minf_type_env = md_types details,
- minf_exports = availsToNameSet $
- md_exports details,
- minf_rdr_env = Just rdr_env,
- minf_instances = md_insts details
- }
- return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
- typecheckedSource = Just tc_binds,
- checkedModuleInfo = Just minf }))
+-- | 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, not (isBootSummary ms) ] of
+ [] -> throw $ mkApiErr (text "Module not part of module graph")
+ [ms] -> return ms
+ multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
+
+-- | Parse a module.
+--
+-- Throws a 'SourceError' on parse error.
+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
+ return (ParsedModule ms rdr_module)
+
+-- | Typecheck and rename a parsed module.
+--
+-- Throws a 'SourceError' if either fails.
+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
+typecheckModule pmod = do
+ let ms = modSummary pmod
+ hsc_env0 <- getSession
+ let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
+ (tc_gbl_env, rn_info)
+ <- typecheckRenameModule hsc_env ms (parsedSource pmod)
+ details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env
+ return $
+ TypecheckedModule {
+ tm_internals_ = (tc_gbl_env, details),
+ tm_parsed_module = pmod,
+ tm_renamed_source = rn_info,
+ tm_typechecked_source = tcg_binds tc_gbl_env,
+ tm_checked_module_info =
+ ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = availsToNameSet $ md_exports details,
+ minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
+ minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = emptyModBreaks
+#endif
+ }}
+
+-- | Desugar a typechecked module.
+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
+desugarModule tcm = do
+ let ms = modSummary tcm
+ hsc_env0 <- getSession
+ let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
+ let (tcg, _) = tm_internals tcm
+ guts <- deSugarModule hsc_env ms tcg
+ return $
+ DesugaredModule {
+ dm_typechecked_module = tcm,
+ dm_core_module = guts
+ }
+
+-- | Load a module. Input doesn't need to be desugared.
+--
+-- XXX: Describe usage.
+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
+loadModule tcm = do
+ let ms = modSummary tcm
+ let mod = ms_mod_name ms
+ hsc_env0 <- getSession
+ let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
+ let (tcg, details) = tm_internals tcm
+ (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details
+ let mod_info = HomeModInfo {
+ hm_iface = iface,
+ hm_details = details,
+ hm_linkable = Nothing }
+ let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
+ modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new }
+ return tcm
+
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' parses, typechecks, and
+-- desugars the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreSimplified = compileCore True
+{-
+-- | Provided for backwards-compatibility: compileToCore returns just the Core
+-- bindings, but for most purposes, you probably want to call
+-- compileToCoreModule.
+compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
+compileToCore fn = do
+ mod <- compileToCoreModule session fn
+ return $ cm_binds mod
+-}
+-- | Takes a CoreModule and compiles the bindings therein
+-- to object code. The first argument is a bool flag indicating
+-- whether to run the simplifier.
+-- The resulting .o, .hi, and executable files, if any, are stored in the
+-- current directory, and named according to the module name.
+-- Returns True iff compilation succeeded.
+-- This has only so far been tested with a single self-contained module.
+compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
+compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
+ hscEnv <- getSession
+ dflags <- getSessionDynFlags
+ currentTime <- liftIO $ getClockTime
+ cwd <- liftIO $ getCurrentDirectory
+ modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
+ ((moduleNameSlashes . moduleName) mName)
+
+ let modSummary = ModSummary { ms_mod = mName,
+ ms_hsc_src = ExtCoreFile,
+ ms_location = modLocation,
+ -- By setting the object file timestamp to Nothing,
+ -- we always force recompilation, which is what we
+ -- want. (Thus it doesn't matter what the timestamp
+ -- for the (nonexistent) source file is.)
+ ms_hs_date = currentTime,
+ ms_obj_date = Nothing,
+ -- Only handling the single-module case for now, so no imports.
+ ms_srcimps = [],
+ ms_imps = [],
+ -- No source file
+ ms_hspp_file = "",
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing
+ }
+
+ ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing}) $
+ let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
+ | otherwise = return mod_guts
+ in maybe_simplify (mkModGuts cm)
+ >>= hscNormalIface
+ >>= hscWriteIface
+ >>= hscOneShot
+ return ()
+
+-- Makes a "vanilla" ModGuts.
+mkModGuts :: CoreModule -> ModGuts
+mkModGuts coreModule = ModGuts {
+ mg_module = cm_module coreModule,
+ mg_boot = False,
+ mg_exports = [],
+ mg_deps = noDependencies,
+ mg_dir_imps = emptyModuleEnv,
+ mg_used_names = emptyNameSet,
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_types = emptyTypeEnv,
+ mg_insts = [],
+ mg_fam_insts = [],
+ mg_rules = [],
+ mg_binds = cm_binds coreModule,
+ mg_foreign = NoStubs,
+ mg_warns = NoWarnings,
+ mg_anns = [],
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo,
+ mg_inst_env = emptyInstEnv,
+ mg_fam_inst_env = emptyFamInstEnv
+}
+
+compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
+compileCore simplify fn = do
+ -- First, set the target to the desired filename
+ target <- guessTarget fn Nothing
+ addTarget target
+ load LoadAllTargets
+ -- Then find dependencies
+ modGraph <- depanal [] True
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- Now we have the module name;
+ -- parse, typecheck and desugar the module
+ mod_guts <- coreModule `fmap`
+ (desugarModule =<< typecheckModule =<< parseModule modSummary)
+ liftM gutsToCoreModule $
+ if simplify
+ then do
+ -- If simplify is true: simplify (hscSimplify), then tidy
+ -- (tidyProgram).
+ hsc_env <- getSession
+ simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts)
+ (CompState{
+ compHscEnv = hsc_env,
+ compModSummary = modSummary,
+ compOldIface = Nothing})
+ tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
+ return $ Left tidy_guts
+ else
+ return $ Right mod_guts
+
+ Nothing -> panic "compileToCoreModule: target FilePath not found in\
+ module dependency graph"
+ where -- two versions, based on whether we simplify (thus run tidyProgram,
+ -- which returns a (CgGuts, ModDetails) pair, or not (in which case
+ -- we just have a ModGuts.
+ gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
+ gutsToCoreModule (Left (cg, md)) = CoreModule {
+ cm_module = cg_module cg, cm_types = md_types md,
+ cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+ }
+ gutsToCoreModule (Right mg) = CoreModule {
+ cm_module = mg_module mg, cm_types = mg_types mg,
+ cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
+ }