X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=1fc21c94a6e42dd2f1a01c6397fcfaa0b9c05587;hb=d7230e532eb485db85d4e446d7fba4192507b3ba;hp=35e4d9db1c4ddde6593c424db3c554e0d4797224;hpb=86bec4298d582ef1d8f0a201d6a81145e1be9498;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 35e4d9d..1fc21c9 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -15,10 +15,11 @@ module GHC (
 
 	-- * Flags and settings
 	DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
-        GhcMode(..), GhcLink(..),
+        GhcMode(..), GhcLink(..), defaultObjectTarget,
 	parseDynamicFlags,
 	getSessionDynFlags,
 	setSessionDynFlags,
+        parseStaticFlags,
 
 	-- * Targets
 	Target(..), TargetId(..), Phase,
@@ -40,6 +41,7 @@ module GHC (
 	workingDirectoryChanged,
 	checkModule, CheckedModule(..),
 	TypecheckedSource, ParsedSource, RenamedSource,
+        compileToCore,
 
 	-- * Parsing Haddock comments
 	parseHaddockComment,
@@ -78,11 +80,15 @@ module GHC (
 	typeKind,
 	parseName,
 	RunResult(..),  
-	runStmt, stepStmt, -- traceStmt,
-        resume,  stepResume, -- traceResume,
-        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan),
+	runStmt, SingleStep(..),
+        resume,
+        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+               resumeHistory, resumeHistoryIx),
+        History(historyBreakInfo), getHistorySpan,
         getResumeContext,
         abandon, abandonAll,
+        InteractiveEval.back,
+        InteractiveEval.forward,
 	showModule,
         isModuleInterpreted,
 	compileExpr, HValue, dynCompileExpr,
@@ -105,7 +111,7 @@ module GHC (
 
 	-- ** Names
 	Name, 
-	nameModule, pprParenSymName, nameSrcLoc,
+	isExternalName, nameModule, pprParenSymName, nameSrcSpan,
 	NamedThing(..),
 	RdrName(Qual,Unqual),
 	
@@ -167,10 +173,10 @@ module GHC (
 
 	-- ** Source locations
 	SrcLoc, pprDefnLoc,
-        mkSrcLoc, isGoodSrcLoc,
+        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
 	srcLocFile, srcLocLine, srcLocCol,
         SrcSpan,
-        mkSrcSpan, srcLocSpan,
+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
         srcSpanStart, srcSpanEnd,
 	srcSpanFile, 
         srcSpanStartLine, srcSpanEndLine, 
@@ -220,17 +226,23 @@ 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(..) )
 import HscTypes
 import DynFlags
+import StaticFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM
+import UniqSet
+import Unique
 import PackageConfig
 import FiniteMap
 import Panic
@@ -259,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
@@ -332,6 +339,7 @@ newSession mb_top_dir = do
   modifyMVar_ interruptTargetThread (return . (main_thread :))
   installSignalHandlers
 
+  initStaticOpts
   dflags0 <- initSysTools mb_top_dir defaultDynFlags
   dflags  <- initDynFlags dflags0
   env <- newHscEnv dflags
@@ -823,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 ()
@@ -1748,10 +1783,14 @@ getBindings s = withSession s $ \hsc_env ->
    -- we have to implement the shadowing behaviour of ic_tmp_ids here
    -- (see InteractiveContext) and the quickest way is to use an OccEnv.
    let 
-       tmp_ids = reverse (ic_tmp_ids (hsc_IC hsc_env))
-       env = mkOccEnv [ (nameOccName (idName id), id) | id <- tmp_ids ]
+       tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
+       filtered = foldr f (const []) tmp_ids emptyUniqSet
+       f id rest set 
+           | uniq `elementOfUniqSet` set = rest set
+           | otherwise  = AnId id : rest (addOneToUniqSet set uniq)
+           where uniq = getUnique (nameOccName (idName id))
    in
-   return (map AnId (occEnvElts env))
+   return filtered
 
 getPrintUnqual :: Session -> IO PrintUnqualified
 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)