X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=9747c22a724a1d02960d8965ec3bae1a22b79b40;hb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;hp=a7e73353f41ab99738e487a4756180dd4057e289;hpb=f9f4a02889e327cf013a93d257f4f0311cb42853;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index a7e7335..9747c22 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -48,7 +48,8 @@ import TcRules		( tcRules )
 import TcForeign	( tcForeignImports, tcForeignExports )
 import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
 import TcIface		( tcExtCoreBindings, tcHiBootIface )
-import IfaceSyn		( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) )
+import MkIface		( tyThingToIfaceDecl )
+import IfaceSyn		( checkBootDecl, IfaceExtName(..) )
 import TcSimplify	( tcSimplifyTop )
 import TcTyClsDecls	( tcTyAndClassDecls )
 import LoadIface	( loadOrphanModules )
@@ -87,7 +88,7 @@ import HsSyn		( HsStmtContext(..), Stmt(..), HsExpr(..),
 			  HsLocalBinds(..), HsValBinds(..),
 			  LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
 			  collectLStmtsBinders, collectLStmtBinders, nlVarPat,
-		   	  mkFunBind, placeHolderType, noSyntaxExpr )
+		   	  mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
 import RdrName		( GlobalRdrElt(..), globalRdrEnvElts,
 			  unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
 import RnSource		( addTcgDUs )
@@ -96,6 +97,7 @@ import TcHsType		( kcHsType )
 import TcMType		( zonkTcType, zonkQuantifiedTyVar )
 import TcMatches	( tcStmts, tcDoStmt )
 import TcSimplify	( tcSimplifyInteractive, tcSimplifyInfer )
+import TcGadt		( emptyRefinement )
 import TcType		( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
 			  isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
 import TcEnv		( tcLookupTyCon, tcLookupId, tcLookupGlobal )
@@ -112,7 +114,7 @@ import MkId		( unsafeCoerceId )
 import TyCon		( tyConName )
 import TysWiredIn	( mkListTy, unitTy )
 import IdInfo		( GlobalIdDetails(..) )
-import Kind		( Kind )
+import {- Kind parts of -} Type		( Kind )
 import Var		( globaliseId )
 import Name		( isBuiltInSyntax, isInternalName )
 import OccName		( isTcOcc )
@@ -982,6 +984,8 @@ tcGhciStmts stmts
 	    io_ty     = mkTyConApp ioTyCon [] ;
 	    ret_ty    = mkListTy unitTy ;
 	    io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+	    tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
+				        (emptyRefinement, io_ret_ty) ;
 
 	    names = map unLoc (collectLStmtsBinders stmts) ;
 
@@ -996,17 +1000,16 @@ tcGhciStmts stmts
 		-- then the type checker would instantiate x..z, and we wouldn't
 		-- get their *polymorphic* values.  (And we'd get ambiguity errs
 		-- if they were overloaded, since they aren't applied to anything.)
-	    mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) 
+	    mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
 			 	    (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
-	    mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+	    mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
 		    	         (nlHsVar id) 
 	 } ;
 
 	-- OK, we're ready to typecheck the stmts
 	traceTc (text "tcs 2") ;
-	((tc_stmts, ids), lie) <- getLIE $ 
-				  tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
-				  mappM tcLookupId names ;
+	((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+					   mappM tcLookupId names ;
 					-- Look up the names right in the middle,
 					-- where they will all be in scope