From: Tim Chevalier Date: Sat, 27 Oct 2007 10:05:30 +0000 (+0000) Subject: Make compileToCore return the module name and type environment along with bindings X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8102af4eac807ae4956a79b27f03fd890f8294c6 Make compileToCore return the module name and type environment along with bindings compileToCore returned just a list of CoreBind, which isn't enough, since to do anything with the resulting Core code, you probably also want the type declarations. I left compileToCore as it is, but added a function compileToCoreModule that returns a complete Core module (with module name, type environment, and bindings). I'm not sure that returning the type environment is the best way to represent the type declarations for the given module, but I don't want to reinvent the External Core wheel for this. --- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 2403e07..bf1bd77 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -41,7 +41,7 @@ module GHC ( workingDirectoryChanged, checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, + compileToCore, compileToCoreModule, -- * Parsing Haddock comments parseHaddockComment, @@ -771,7 +771,7 @@ data CheckedModule = renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo, - coreBinds :: Maybe [CoreBind] + coreModule :: Maybe CoreModule } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -821,7 +821,7 @@ checkModule (Session ref) mod compileToCore = do renamedSource = renamed, typecheckedSource = Nothing, checkedModuleInfo = Nothing, - coreBinds = Nothing })) + coreModule = Nothing })) Just (HscChecked parsed renamed (Just (tc_binds, rdr_env, details)) maybeCoreBinds) -> do @@ -840,14 +840,15 @@ checkModule (Session ref) mod compileToCore = do renamedSource = renamed, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf, - coreBinds = maybeCoreBinds})) + coreModule = maybeCoreBinds})) -- | This is the way to get access to the Core bindings corresponding -- 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 fn = do +-- desugar the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreModule session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -857,16 +858,26 @@ compileToCore session fn = do case maybeModGraph of Nothing -> return Nothing Just modGraph -> do - let modSummary = expectJust "compileToCore" $ - find ((== fn) . msHsFilePath) modGraph - -- 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 + 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 - -- --------------------------------------------------------------------------- + Just checkedMod -> return $ coreModule checkedMod + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + maybeCoreModule <- compileToCoreModule session fn + return $ fmap cm_binds maybeCoreModule +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 9a7a255..73d699c 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -193,7 +193,7 @@ data HscChecked -- typechecked (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- desugared - (Maybe [CoreBind]) + (Maybe CoreModule) -- Status of a compilation to hard-code or nothing. data HscStatus @@ -689,7 +689,11 @@ hscFileCheck hsc_env mod_summary compileToCore = do { (Just (tcg_binds tc_result, tcg_rdr_env tc_result, md)) - (fmap mg_binds maybeModGuts))) + (fmap (\ mg -> + (CoreModule { cm_module = mg_module mg, + cm_types = mg_types mg, + cm_binds = mg_binds mg})) + maybeModGuts))) }}}} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index abebd14..7aacf95 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -13,7 +13,7 @@ module HscTypes ( ModuleGraph, emptyMG, ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..), + ModGuts(..), CoreModule(..), CgGuts(..), ModImports(..), ForeignStubs(..), ModSummary(..), ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, @@ -548,6 +548,22 @@ data ModGuts -- this one); c.f. tcg_fam_inst_env } +-- A CoreModule consists of just the fields of a ModGuts that are needed for +-- the 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] + } + +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) + -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: