X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=a918d60bdb4504c07ba4e0d9a5a5e97f38a35ea3;hb=f109a0b2d927a8c7fe5cc9881f0dfdae3e34f399;hp=f53fddc96d7b1d9a0676a9c5c4a4517e9eacbeb2;hpb=9f589efb688f22cb0637f9c1164dd9027b4378a3;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index f53fddc..a918d60 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -41,6 +41,7 @@ module GHC (
 	workingDirectoryChanged,
 	checkModule, CheckedModule(..),
 	TypecheckedSource, ParsedSource, RenamedSource,
+        compileToCore,
 
 	-- * Parsing Haddock comments
 	parseHaddockComment,
@@ -225,8 +226,11 @@ import Name             hiding ( varName )
 import OccName		( parenSymOcc )
 import InstEnv		( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
+import Desugar
+import CoreSyn
+import TcRnDriver       ( tcRnModule )
 import DriverPipeline
-import DriverPhases	( Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases	( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo	( getImports, getOptions )
 import Finder
 import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
@@ -758,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,
@@ -785,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 $
@@ -825,9 +831,35 @@ 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' 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, 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
 
 unload :: HscEnv -> [Linkable] -> IO ()