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

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 55c1e5f..1fc21c9 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,
@@ -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
@@ -832,7 +831,34 @@ checkModule session@(Session ref) mod = do
 					typecheckedSource = Just tc_binds,
 					checkedModuleInfo = Just minf }))
 
--- ---------------------------------------------------------------------------
+-- | 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.
+compileToCore :: Session -> ModuleName -> FilePath -> IO (Maybe [CoreBind])
+compileToCore session@(Session ref) mod fn = do
+   hsc_env <- readIORef ref
+   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
+       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 
+           location <- mkHomeModLocation dflags mod fn
+           maybeModGuts <- deSugar hsc_env location tcgEnv
+           case maybeModGuts of
+             Nothing -> return Nothing
+             Just mg -> return $ Just $ mg_binds mg
+ -- ---------------------------------------------------------------------------
 -- Unloading
 
 unload :: HscEnv -> [Linkable] -> IO ()