X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=ec550fa69f239989be92ca7387216fca4fe69ad2;hb=c464eda3010831d8e5fb97c950aef953a1217db6;hp=74377185b4345194860a52d7ae1b356cd7ae96a0;hpb=210766f3c06c727d7f23929266ea807bfa7c5703;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 7437718..ec550fa 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -6,9 +6,12 @@
 
 \begin{code}
 module HscMain ( 
-	HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
+	HscResult(..),
+	hscMain, newHscEnv, hscCmmFile, 
+	hscBufferCheck, hscFileCheck,
 #ifdef GHCI
-	, hscStmt, hscTcExpr, hscKcType, hscThing, 
+	, hscStmt, hscTcExpr, hscKcType
+	, hscGetInfo, GetInfoResult
 	, compileExpr
 #endif
 	) where
@@ -17,31 +20,36 @@ module HscMain (
 
 #ifdef GHCI
 import HsSyn		( Stmt(..), LStmt, LHsExpr, LHsType )
-import IfaceSyn		( IfaceDecl )
+import IfaceSyn		( IfaceDecl, IfaceInst )
 import CodeOutput	( outputForeignStubs )
 import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
 import Linker		( HValue, linkExpr )
 import TidyPgm		( tidyCoreExpr )
 import CorePrep		( corePrepExpr )
 import Flattening	( flattenExpr )
-import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnThing, tcRnType ) 
-import RdrName		( RdrName )
+import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType ) 
+import RdrName		( rdrNameOcc )
+import OccName		( occNameUserString )
 import Type		( Type )
 import PrelNames	( iNTERACTIVE )
 import StringBuffer	( stringToStringBuffer )
-import SrcLoc		( noSrcLoc, Located(..) )
 import Kind		( Kind )
 import Var		( Id )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
 import BasicTypes	( Fixity )
+import SrcLoc		( SrcLoc, noSrcLoc )
 #endif
 
+import RdrName		( RdrName )
+import HsSyn		( HsModule )
+import SrcLoc		( Located(..) )
 import StringBuffer	( hGetStringBuffer )
 import Parser
 import Lexer		( P(..), ParseResult(..), mkPState )
 import SrcLoc		( mkSrcLoc )
 import TcRnDriver	( tcRnModule, tcRnExtCore )
+import TcRnTypes	( TcGblEnv )
 import TcIface		( typecheckIface )
 import IfaceEnv		( initNameCache )
 import LoadIface	( ifaceStats, initExternalPackageState )
@@ -57,6 +65,7 @@ import CoreToStg	( coreToStg )
 import Name		( Name, NamedThing(..) )
 import SimplStg		( stg2stg )
 import CodeGen		( codeGen )
+import CmmParse		( parseCmmFile )
 import CodeOutput	( codeOutput )
 
 import CmdLineOpts
@@ -124,7 +133,7 @@ data HscResult
    = HscFail
 
    -- In IDE mode: we just do the static/dynamic checks
-   | HscChecked
+   | HscChecked (Located (HsModule RdrName)) (Maybe TcGblEnv)
 
    -- Concluded that it wasn't necessary
    | HscNoRecomp ModDetails  	         -- new details (HomeSymbolTable additions)
@@ -176,10 +185,10 @@ hscMain hsc_env msg_act mod location
 -- hscNoRecomp definitely expects to have the old interface available
 hscNoRecomp hsc_env msg_act have_object 
 	    mod location (Just old_iface)
- | hsc_mode hsc_env == OneShot
+ | isOneShot (hsc_mode hsc_env)
  = do {
-      when (verbosity (hsc_dflags hsc_env) > 0) $
-	  hPutStrLn stderr "compilation IS NOT required";
+      compilationProgressMsg (hsc_dflags hsc_env) $
+	"compilation IS NOT required";
       dumpIfaceStats hsc_env ;
 
       let { bomb = panic "hscNoRecomp:OneShot" };
@@ -187,9 +196,8 @@ hscNoRecomp hsc_env msg_act have_object
       }
  | otherwise
  = do {
-      when (verbosity (hsc_dflags hsc_env) >= 1) $
-		hPutStrLn stderr ("Skipping  " ++ 
-			showModMsg have_object mod location);
+      compilationProgressMsg (hsc_dflags hsc_env) $
+	("Skipping  " ++ showModMsg have_object mod location);
 
       new_details <- _scc_ "tcRnIface"
 		     typecheckIface hsc_env old_iface ;
@@ -202,20 +210,21 @@ hscRecomp hsc_env msg_act have_object
 	  mod location maybe_checked_iface
  = do	{
       	  -- what target are we shooting for?
-	; let one_shot  = hsc_mode hsc_env == OneShot
+	; let one_shot  = isOneShot (hsc_mode hsc_env)
       	; let dflags    = hsc_dflags hsc_env
 	; let toInterp  = dopt_HscLang dflags == HscInterpreted
 	; let toCore    = isJust (ml_hs_file location) &&
 			  isExtCoreFilename (fromJust (ml_hs_file location))
 
-      	; when (not one_shot && verbosity dflags >= 1) $
-		hPutStrLn stderr ("Compiling " ++ 
-			showModMsg (not toInterp) mod location);
+      	; when (not one_shot) $
+		compilationProgressMsg dflags $
+		  ("Compiling " ++ showModMsg (not toInterp) mod location);
 			
+	; let hspp_file = expectJust "hscFrontEnd:hspp" (ml_hspp_file location)
 	; front_res <- if toCore then 
-			  hscCoreFrontEnd hsc_env msg_act location
+			  hscCoreFrontEnd hsc_env msg_act hspp_file
 		       else 
-			  hscFileFrontEnd hsc_env msg_act location
+			  hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location)
 
 	; case front_res of
 	    Left flure -> return flure;
@@ -319,13 +328,13 @@ hscRecomp hsc_env msg_act have_object
       			    maybe_bcos)
       	 }}
 
-hscCoreFrontEnd hsc_env msg_act location = do {
+hscCoreFrontEnd hsc_env msg_act hspp_file = do {
  	    -------------------
  	    -- PARSE
  	    -------------------
-	; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
+	; inp <- readFile hspp_file
 	; case parseCore inp 1 of
-	    FailP s        -> hPutStrLn stderr s >> return (Left HscFail)
+	    FailP s        -> putMsg s{-ToDo: wrong-} >> return (Left HscFail)
 	    OkP rdr_module -> do {
     
  	    -------------------
@@ -341,40 +350,18 @@ hscCoreFrontEnd hsc_env msg_act location = do {
 	}}}
 	 
 
-hscFileFrontEnd hsc_env msg_act location = do {
+hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do {
  	    -------------------
  	    -- PARSE
  	    -------------------
-	; maybe_parsed <- myParseModule (hsc_dflags hsc_env) 
-                             (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
+	; maybe_parsed <- myParseModule (hsc_dflags hsc_env)  hspp_file hspp_buf
 
 	; case maybe_parsed of {
       	     Left err -> do { msg_act (unitBag err, emptyBag) ;
 			    ; return (Left HscFail) ;
 			    };
-      	     Right rdr_module -> hscFrontEnd hsc_env msg_act rdr_module
-    }}
-
--- Perform static/dynamic checks on the source code in a StringBuffer
--- This is a temporary solution: it'll read in interface files lazily, whereas
--- we probably want to use the compilation manager to load in all the modules
--- in a project.
-hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
-hscBufferFrontEnd hsc_env buffer msg_act = do
-	let loc  = mkSrcLoc (mkFastString "*edit*") 1 0
-	case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
-		PFailed span err -> do
-			msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
-			return HscFail
-		POk _ rdr_module -> do 
-			r <- hscFrontEnd hsc_env msg_act rdr_module
-			case r of
-			   Left r -> return r
-			   Right _ -> return HscChecked
-		
+      	     Right rdr_module -> do {
 
-
-hscFrontEnd hsc_env msg_act rdr_module  = do {
  	    -------------------
  	    -- RENAME and TYPECHECK
  	    -------------------
@@ -394,7 +381,47 @@ hscFrontEnd hsc_env msg_act rdr_module  = do {
 	; case maybe_ds_result of
 	    Nothing        -> return (Left HscFail);
 	    Just ds_result -> return (Right ds_result);
-	}}}
+	}}}}}
+
+
+hscFileCheck hsc_env msg_act hspp_file = do {
+ 	    -------------------
+ 	    -- PARSE
+ 	    -------------------
+	; maybe_parsed <- myParseModule (hsc_dflags hsc_env)  hspp_file Nothing
+
+	; case maybe_parsed of {
+      	     Left err -> do { msg_act (unitBag err, emptyBag) ;
+			    ; return HscFail ;
+			    };
+      	     Right rdr_module -> hscBufferTypecheck hsc_env rdr_module msg_act
+	}}
+
+
+-- Perform static/dynamic checks on the source code in a StringBuffer
+-- This is a temporary solution: it'll read in interface files lazily, whereas
+-- we probably want to use the compilation manager to load in all the modules
+-- in a project.
+hscBufferCheck :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
+hscBufferCheck hsc_env buffer msg_act = do
+	let loc  = mkSrcLoc (mkFastString "*edit*") 1 0
+        showPass (hsc_dflags hsc_env) "Parser"
+	case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
+		PFailed span err -> do
+		   msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
+		   return HscFail
+		POk _ rdr_module -> do
+		   hscBufferTypecheck hsc_env rdr_module msg_act
+
+hscBufferTypecheck hsc_env rdr_module msg_act = do
+	(tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename" 
+					tcRnModule hsc_env rdr_module
+	msg_act tc_msgs
+	case maybe_tc_result of
+	    Nothing  -> return (HscChecked rdr_module Nothing)
+				-- space leak on rdr_module!
+	    Just r -> return (HscChecked rdr_module (Just r))
+
 
 hscBackEnd dflags 
     ModGuts{  -- This is the last use of the ModGuts in a compilation.
@@ -449,11 +476,29 @@ hscBackEnd dflags
    }
 
 
-myParseModule dflags src_filename
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+  maybe_cmm <- parseCmmFile dflags filename
+  case maybe_cmm of
+    Nothing -> return False
+    Just cmm -> do
+	codeOutput dflags no_mod NoStubs noDependencies [cmm]
+	return True
+  where
+	no_mod = panic "hscCmmFile: no_mod"
+
+
+myParseModule dflags src_filename maybe_src_buf
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
       _scc_  "Parser" do
-      buf <- hGetStringBuffer src_filename
+
+	-- sometimes we already have the buffer in memory, perhaps
+	-- because we needed to parse the imports out of it, or get the 
+	-- module name.
+      buf <- case maybe_src_buf of
+		Just b  -> return b
+		Nothing -> hGetStringBuffer src_filename
 
       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 
@@ -561,7 +606,7 @@ hscTcExpr hsc_env icontext expr
 	     Nothing      -> return Nothing ;	-- Parse error
 	     Just (Just (L _ (ExprStmt expr _)))
 			-> tcRnExpr hsc_env icontext expr ;
-	     Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
+	     Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
 			        return Nothing } ;
       	     } }
 
@@ -575,7 +620,7 @@ hscKcType hsc_env icontext str
   = do	{ maybe_type <- hscParseType (hsc_dflags hsc_env) str
 	; case maybe_type of {
 	     Just ty	-> tcRnType hsc_env icontext ty ;
-	     Just other -> do { hPutStrLn stderr ("not an type: `" ++ str ++ "'") ;
+	     Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
 			        return Nothing } ;
       	     Nothing    -> return Nothing } }
 \end{code}
@@ -627,23 +672,29 @@ hscParseThing parser dflags str
 
 \begin{code}
 #ifdef GHCI
-hscThing -- like hscStmt, but deals with a single identifier
+type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
+
+hscGetInfo -- like hscStmt, but deals with a single identifier
   :: HscEnv
   -> InteractiveContext		-- Context for compiling
   -> String			-- The identifier
-  -> IO [(IfaceDecl, Fixity)]
+  -> IO [GetInfoResult]
 
-hscThing hsc_env ic str
+hscGetInfo hsc_env ic str
    = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 	case maybe_rdr_name of {
 	  Nothing -> return [];
 	  Just (L _ rdr_name) -> do
 
-	maybe_tc_result <- tcRnThing hsc_env ic rdr_name
+	maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
+
+	let 	-- str' is the the naked occurrence name
+		-- after stripping off qualification and parens (+)
+	   str' = occNameUserString (rdrNameOcc rdr_name)
 
 	case maybe_tc_result of {
 	     Nothing     -> return [] ;
-	     Just things -> return things
+	     Just things -> return [(str', t) | t <- things]
  	}}
 #endif
 \end{code}