+ }}
+
+-- | Desugar a typechecked module.
+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
+desugarModule tcm = do
+ let ms = modSummary tcm
+ let (tcg, _) = tm_internals tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
+ return $
+ DesugaredModule {
+ dm_typechecked_module = tcm,
+ dm_core_module = guts
+ }
+
+-- | Load a module. Input doesn't need to be desugared.
+--
+-- A module must be loaded before dependent modules can be typechecked. This
+-- always includes generating a 'ModIface' and, depending on the
+-- 'DynFlags.hscTarget', may also include code generation.
+--
+-- This function will always cause recompilation and will always overwrite
+-- previous compilation results (potentially files on disk).
+--
+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
+loadModule tcm = do
+ let ms = modSummary tcm
+ let mod = ms_mod_name ms
+ let loc = ms_location ms
+ let (tcg, _details) = tm_internals tcm
+
+ mb_linkable <- case ms_obj_date ms of
+ Just t | t > ms_hs_date ms -> do
+ l <- liftIO $ findObjectLinkable (ms_mod ms)
+ (ml_obj_file loc) t
+ return (Just l)
+ _otherwise -> return Nothing
+
+ -- compile doesn't change the session
+ hsc_env <- getSession
+ mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg,
+ hscInteractiveBackendOnly tcg,
+ hscBatchBackendOnly tcg)
+ hsc_env ms 1 1 Nothing mb_linkable
+
+ modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
+ return tcm
+
+-- -----------------------------------------------------------------------------
+-- Operations dealing with Core
+
+-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
+-- the 'GHC.compileToCoreModule' interface.
+data CoreModule
+ = CoreModule {
+ -- | Module name
+ cm_module :: !Module,
+ -- | Type environment for types declared in this module
+ cm_types :: !TypeEnv,
+ -- | Declarations
+ cm_binds :: [CoreBind],
+ -- | Imports
+ cm_imports :: ![Module]
+ }
+
+instance Outputable CoreModule where
+ ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
+ text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
+
+-- | 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.
+-- 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
+ 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
+ }
+
+ hsc_env <- getSession
+ liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)
+
+
+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`
+ -- TODO: space leaky: call hsc* directly?
+ (desugarModule =<< typecheckModule =<< parseModule modSummary)
+ liftM gutsToCoreModule $
+ if simplify
+ then do
+ -- If simplify is true: simplify (hscSimplify), then tidy
+ -- (tidyProgram).
+ hsc_env <- getSession
+ simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
+ 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
+ }