Further compileToCore improvements

Per suggestions from Simon M:

* Changed GHC.checkModule so that it doesn't call depanal.
* Changed GHC.checkModule to optionally return Core bindings
as a component of the CheckedModule that it returns (and 
resulting changes to HscMain.hscFileCheck).
* As a result, simplified GHC.compileToCore and changed it
to load the given file so that the caller doesn't have to.
parent 4975f4a6
......@@ -865,7 +865,7 @@ checkModule :: String -> GHCi ()
checkModule m = do
let modl = GHC.mkModuleName m
session <- getSession
result <- io (GHC.checkModule session modl)
result <- io (GHC.checkModule session modl False)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
......
......@@ -762,7 +762,8 @@ data CheckedModule =
CheckedModule { parsedSource :: ParsedSource,
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo
checkedModuleInfo :: Maybe ModuleInfo,
coreBinds :: Maybe [CoreBind]
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
......@@ -789,32 +790,33 @@ type TypecheckedSource = LHsBinds Id
-- | 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
-- for a module. 'checkModule' 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
-- If compileToCore is true, it also desugars the module and returns the
-- resulting Core bindings as a component of the CheckedModule.
checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule)
checkModule session@(Session ref) mod compileToCore = do
-- 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
mbChecked <- hscFileCheck
hsc_env{hsc_dflags=ms_hspp_opts ms}
ms compileToCore
case mbChecked of
Nothing -> return Nothing
Just (HscChecked parsed renamed Nothing) ->
Just (HscChecked parsed renamed Nothing _) ->
return (Just (CheckedModule {
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Nothing,
checkedModuleInfo = Nothing }))
checkedModuleInfo = Nothing,
coreBinds = Nothing }))
Just (HscChecked parsed renamed
(Just (tc_binds, rdr_env, details))) -> do
(Just (tc_binds, rdr_env, details))
maybeCoreBinds) -> do
let minf = ModuleInfo {
minf_type_env = md_types details,
minf_exports = availsToNameSet $
......@@ -829,41 +831,34 @@ checkModule session@(Session ref) mod = do
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf }))
checkedModuleInfo = Just minf,
coreBinds = maybeCoreBinds}))
-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' first invokes 'checkModule' to parse and
-- typecheck the module, then desugars it and returns the resulting list
-- of Core bindings if successful. It is assumed that the given filename
-- has already been loaded.
-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
-- desugar the module, then returns the resulting list of Core bindings if
-- successful.
compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
compileToCore session@(Session ref) fn = do
hsc_env <- readIORef ref
-- First, determine the module name.
modSummary <- summariseFile hsc_env [] fn Nothing Nothing
let mod = moduleName $ ms_mod modSummary
-- Next, parse and typecheck the module
maybeCheckedModule <- checkModule session mod
case maybeCheckedModule of
Nothing -> return Nothing
Just checkedMod -> do
let parsedMod = parsedSource checkedMod
-- Note: this typechecks the module twice (because checkModule
-- also calls tcRnModule), but arranging for checkModule to
-- return the type env would require changing a lot of data
-- structures, so I'm leaving it like that for now.
(_, maybe_tc_result) <- tcRnModule hsc_env HsSrcFile False parsedMod
-- Get the type environment from the typechecking result
case maybe_tc_result of
-- TODO: this ignores the type error messages and just returns Nothing
Nothing -> return Nothing
Just tcgEnv -> do
let dflags = hsc_dflags hsc_env
-- Finally, compile to Core and return the resulting bindings
maybeModGuts <- deSugar hsc_env (ms_location modSummary) tcgEnv
case maybeModGuts of
Nothing -> return Nothing
Just mg -> return $ Just $ mg_binds mg
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget session target
load session LoadAllTargets
-- Then find dependencies
maybeModGraph <- depanal session [] True
case maybeModGraph of
Nothing -> return Nothing
Just modGraph -> do
case find ((== fn) . msHsFilePath) modGraph of
Just modSummary -> do
-- Now we have the module name;
-- parse, typecheck and desugar the module
let mod = ms_mod_name modSummary
maybeCheckedModule <- checkModule session mod True
case maybeCheckedModule of
Nothing -> return Nothing
Just checkedMod -> return $ coreBinds checkedMod
-- ---------------------------------------------------------------------------
-- Unloading
......
......@@ -51,6 +51,7 @@ import Module ( emptyModuleEnv, ModLocation(..) )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
import CoreSyn
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
import Parser
......@@ -183,7 +184,8 @@ data HscChecked
Maybe (HsDoc Name), HaddockModInfo Name))
-- typechecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
-- desugared
(Maybe [CoreBind])
-- Status of a compilation to hard-code or nothing.
data HscStatus
......@@ -646,8 +648,8 @@ hscInteractive (iface, details, cgguts)
------------------------------
hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
hscFileCheck hsc_env mod_summary = do {
hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
hscFileCheck hsc_env mod_summary compileToCore = do {
-------------------
-- PARSE
-------------------
......@@ -673,7 +675,7 @@ hscFileCheck hsc_env mod_summary = do {
; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
Just tc_result -> do
let type_env = tcg_type_env tc_result
md = ModDetails {
......@@ -696,11 +698,17 @@ hscFileCheck hsc_env mod_summary = do {
let doc = tcg_doc tc_result
hmi = tcg_hmi tc_result
return (decl,imports,exports,doc,hmi)
return (Just (HscChecked rdr_module
maybeModGuts <-
if compileToCore then
deSugar hsc_env (ms_location mod_summary) tc_result
else
return Nothing
return (Just (HscChecked rdr_module
rnInfo
(Just (tcg_binds tc_result,
tcg_rdr_env tc_result,
md))))
md))
(fmap mg_binds maybeModGuts)))
}}}}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment