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 (file)
--- 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 (file)
--- 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 (file)
--- 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: