X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=59fbb31a4c3f05b692e8f8f39bc35a3d41f64ae8;hb=8655d6ca41df4aa77a559d4067ad3815797b9803;hp=b6e94aaba7d85a35ea31beb7dce9834f61a886e2;hpb=d28ba8c800901bea01f70c4719278c2a364cf9fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index b6e94aa..59fbb31 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -6,11 +6,11 @@
 \begin{code}
 module TcRnDriver (
 #ifdef GHCI
-	mkGlobalContext, getModuleContents,
+	mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
 #endif
 	tcRnModule, checkOldIface, 
 	importSupportingDecls, tcTopSrcDecls,
-	tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
+	tcRnIface, tcRnExtCore
     ) where
 
 #include "HsVersions.h"
@@ -32,9 +32,9 @@ import HsSyn		( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
 import RdrHsSyn		( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
 			  emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
 
-import PrelNames	( iNTERACTIVE, ioTyConName, printName,
-			  returnIOName, bindIOName, failIOName, thenIOName, runIOName, 
-			  dollarMainName, itName, mAIN_Name
+import PrelNames	( iNTERACTIVE, ioTyConName, printName, monadNames,
+			  returnIOName, runIOName, 
+			  dollarMainName, itName, mAIN_Name, unsafeCoerceName
 			)
 import MkId		( unsafeCoerceId )
 import RdrName		( RdrName, getRdrName, mkRdrUnqual, 
@@ -47,15 +47,15 @@ import TcHsSyn		( TypecheckedHsExpr, TypecheckedRuleDecl,
 			  zonkTopExpr, zonkTopBndrs
 			)
 
-import TcExpr 		( tcInferRho )
+import TcExpr 		( tcInferRho, tcCheckRho )
 import TcRnMonad
 import TcMType		( newTyVarTy, zonkTcType )
 import TcType		( Type, liftedTypeKind, 
 			  tyVarsOfType, tcFunResultTy, tidyTopType,
 			  mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
 			)
-import TcMatches	( tcStmtsAndThen )
-import Inst		( showLIE )
+import TcMatches	( tcStmtsAndThen, TcStmtCtxt(..) )
+import Inst		( showLIE, tcStdSyntaxName )
 import TcBinds		( tcTopBinds )
 import TcClassDcl	( tcClassDecls2 )
 import TcDefaults	( tcDefaults )
@@ -260,6 +260,7 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
 %************************************************************************
 
 \begin{code}
+#ifdef GHCI
 tcRnStmt :: HscEnv -> PersistentCompilerState
 	 -> InteractiveContext
 	 -> RdrNameStmt
@@ -381,33 +382,41 @@ tcUserStmt stmt = tc_stmts [stmt]
 
 ---------------------------
 tc_stmts stmts
- = do { io_ids <- mappM tcLookupId 
-			[returnIOName, failIOName, bindIOName, thenIOName] ;
-	ioTyCon <- tcLookupTyCon ioTyConName ;
-	res_ty  <- newTyVarTy liftedTypeKind ;
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 	let {
-	    names      = collectStmtsBinders stmts ;
-	    return_id  = head io_ids ;	-- Rather gruesome
+	    ret_ty = mkListTy unitTy ;
+	    names  = collectStmtsBinders stmts ;
+
+	    stmt_ctxt = SC { sc_what = DoExpr, 
+			     sc_rhs  = check_rhs,
+			     sc_body = check_body,
+			     sc_ty   = ret_ty } ;
 
-	    io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
+	    check_rhs rhs rhs_ty = tcCheckRho rhs  (mkTyConApp ioTyCon [rhs_ty]) ;
+	    check_body body      = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ;
 
-		-- mk_return builds the expression
-		--	returnIO @ [()] [coerce () x, ..,  coerce () z]
-	    mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) 
-			          (ExplicitList unitTy (map mk_item ids)) ;
+		-- ret_expr is the expression
+		--	returnIO [coerce () x, ..,  coerce () z]
+	    ret_stmt = ResultStmt ret_expr noSrcLoc ;
+	    ret_expr = HsApp (HsVar returnIOName) 
+			     (ExplicitList placeHolderType (map mk_item names)) ;
+	    mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
 
-	    mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
-		    	       (HsVar id) } ;
+	    all_stmts = stmts ++ [ret_stmt] ;
+
+	    io_ty = mkTyConApp ioTyCon []
+	 } ;
 
 	-- OK, we're ready to typecheck the stmts
 	traceTc (text "tcs 2") ;
 	((ids, tc_stmts), lie) <- 
-		getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $ 
+		getLIE 						$ 
+		tcStmtsAndThen combine stmt_ctxt all_stmts	$ 
 		do {
 		    -- Look up the names right in the middle,
 		    -- where they will all be in scope
 		    ids <- mappM tcLookupId names ;
-		    return (ids, [ResultStmt (mk_return ids) noSrcLoc])
+		    return (ids, [])
 		} ;
 
 	-- Simplify the context right here, so that we fail
@@ -420,9 +429,10 @@ tc_stmts stmts
 	const_binds <- tcSimplifyTop lie ;
 
 	-- Build result expression and zonk it
+	io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 	let { expr = mkHsLet const_binds $
 		     HsDo DoExpr tc_stmts io_ids
-		 	  (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
+		 	  (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
 	zonked_expr <- zonkTopExpr expr ;
 	zonked_ids  <- zonkTopBndrs ids ;
 
@@ -523,6 +533,7 @@ initRnInteractive ictxt rn_thing
   = initRn CmdLineMode $
     setLocalRdrEnv (ic_rn_local_env ictxt) $
     rn_thing
+#endif
 \end{code}
 
 %************************************************************************