X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=1b099231bd64e421619afbc41e82b31fe47c7fcc;hp=f0942b152bdaafe08ceef1ae9a7bfda09089eb4b;hb=a27c5f77da8b3b3f00f9902b69a504460f234e8c;hpb=d51f42f602bf9a6d1b356c41228a534c88723f65

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index f0942b1..1b09923 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -58,6 +58,7 @@ import MkIface
 import IfaceSyn
 import TcSimplify
 import TcTyClsDecls
+import TcUnify	( withBox )
 import LoadIface
 import RnNames
 import RnEnv
@@ -74,6 +75,7 @@ import Name
 import NameEnv
 import NameSet
 import TyCon
+import TysWiredIn
 import SrcLoc
 import HscTypes
 import ListSetOps
@@ -85,12 +87,10 @@ import DataCon
 import TcHsType
 import TcMType
 import TcMatches
-import TcGadt
 import RnTypes
 import RnExpr
 import IfaceEnv
 import MkId
-import TysWiredIn
 import IdInfo
 import {- Kind parts of -} Type
 import BasicTypes
@@ -290,10 +290,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
        --          (b) tcExtCoreBindings doesn't need anything
        --              (in fact, it might not even need to be in the scope of
        --               this tcg_env at all)
-   tcg_env  <- importsFromLocalDecls False (mkFakeGroup ldecls) 
-               emptyUFM {- no fixity decls -} ;
+   avails  <- getLocalNonValBinders (mkFakeGroup ldecls) ;
+   tc_envs <- extendGlobalRdrEnvRn False avails 
+			           emptyOccEnv {- no fixity decls -} ;
 
-   setGblEnv tcg_env $ do {
+   setEnvs tc_envs $ do {
 
    rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
 
@@ -773,19 +774,25 @@ check_main dflags tcg_env
 	     Just main_name -> do
 
 	{ traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
-	; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
-		   	-- :Main.main :: IO () = runMainIO main 
-
-	; (main_expr, ty) <- addErrCtxt mainCtxt			$
-   			     setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
-			     tcInferRho rhs
+	; let loc = srcLocSpan (getSrcLoc main_name)
+	; ioTyCon <- tcLookupTyCon ioTyConName
+	; (main_expr, res_ty) 
+		<- addErrCtxt mainCtxt	  $
+		   withBox liftedTypeKind $ \res_ty -> 
+		   tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
 
 		-- See Note [Root-main Id]
+	   	-- Construct the binding
+		-- 	:Main.main :: IO res_ty = runMainIO res_ty main 
+	; run_main_id <- tcLookupId runMainIOName
 	; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
 				   (mkVarOccFS FSLIT("main")) 
 				   (getSrcSpan main_name)
-	      ; root_main_id = Id.mkExportedLocalId root_main_name ty
-	      ; main_bind    = noLoc (VarBind root_main_id main_expr) }
+	      ; root_main_id = Id.mkExportedLocalId root_main_name 
+						    (mkTyConApp ioTyCon [res_ty])
+	      ; co  = mkWpTyApps [res_ty]
+	      ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
+	      ; main_bind = noLoc (VarBind root_main_id rhs) }
 
 	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
 					`snocBag` main_bind,
@@ -1058,8 +1065,7 @@ tcGhciStmts stmts
 	let {
 	    ret_ty    = mkListTy unitTy ;
 	    io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
-	    tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts 
-				        (emptyRefinement, io_ret_ty) ;
+	    tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ;
 
 	    names = map unLoc (collectLStmtsBinders stmts) ;