X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=a95c36c72f16f908ae8a967bc8aab5bceb626aaa;hb=fcd7ba21a64c12b6e0f1053892d2698ae7d29f81;hp=55c1e5f5e24b3869fd62ca5eb11bcc45543aa53a;hpb=940524aec90652b5ef81789c9a453c57c0e42cc9;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 55c1e5f..a95c36c 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,
@@ -83,7 +84,7 @@ module GHC (
         resume,
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
                resumeHistory, resumeHistoryIx),
-        History(historyBreakInfo), getHistorySpan,
+        History(historyBreakInfo), getHistorySpan, getHistoryModule,
         getResumeContext,
         abandon, abandonAll,
         InteractiveEval.back,
@@ -110,7 +111,7 @@ module GHC (
 
 	-- ** Names
 	Name, 
-	nameModule, pprParenSymName, nameSrcSpan,
+	isExternalName, nameModule, pprParenSymName, nameSrcSpan,
 	NamedThing(..),
 	RdrName(Qual,Unqual),
 	
@@ -172,10 +173,10 @@ module GHC (
 
 	-- ** Source locations
 	SrcLoc, pprDefnLoc,
-        mkSrcLoc, isGoodSrcLoc,
+        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
 	srcLocFile, srcLocLine, srcLocCol,
         SrcSpan,
-        mkSrcSpan, srcLocSpan, isGoodSrcSpan,
+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
         srcSpanStart, srcSpanEnd,
 	srcSpanFile, 
         srcSpanStartLine, srcSpanEndLine, 
@@ -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(..) )
@@ -267,14 +271,9 @@ import System.Time	( ClockTime )
 import Control.Exception as Exception hiding (handle)
 import Data.IORef
 import System.IO
-import System.IO.Error	( isDoesNotExistError )
+import System.IO.Error	( try, isDoesNotExistError )
 import Prelude hiding (init)
 
-#if __GLASGOW_HASKELL__ < 600
-import System.IO as System.IO.Error ( try )
-#else
-import System.IO.Error	( try )
-#endif
 
 -- -----------------------------------------------------------------------------
 -- Exception handlers
@@ -763,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,
@@ -790,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 $
@@ -830,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 ()