From: simonpj <unknown>
Date: Tue, 22 Apr 2003 09:30:53 +0000 (+0000)
Subject: [project @ 2003-04-22 09:30:52 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~950
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fcda69ed4693ad8491a0f1bb4f4c5c7bd915ab72;p=ghc-hetmet.git

[project @ 2003-04-22 09:30:52 by simonpj]
Stage-2 wibbles to the Expected type changes
---

diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6
index ae8183c..4c6483c 100644
--- a/ghc/compiler/typecheck/TcSplice.hi-boot-6
+++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6
@@ -2,11 +2,11 @@ module TcSplice where
 
 tcSpliceExpr :: Name.Name
 	     -> RnHsSyn.RenamedHsExpr
-	     -> TcType.TcType
+	     -> TcUnify.Expected TcType.TcType
 	     -> TcRnTypes.TcM TcHsSyn.TcExpr
 
 tcBracket :: HsExpr.HsBracket Name.Name 
-	  -> TcType.TcType
+	  -> TcUnify.Expected TcType.TcType
 	  -> TcRnTypes.TcM TcHsSyn.TcExpr
 
 tcSpliceDecls :: RnHsSyn.RenamedHsExpr 
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 6a2c4d7..17ca215 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -21,14 +21,14 @@ import Convert		( convertToHsExpr, convertToHsDecls )
 import RnExpr		( rnExpr )
 import RdrHsSyn		( RdrNameHsExpr, RdrNameHsDecl )
 import RnHsSyn		( RenamedHsExpr )
-import TcExpr		( tcCheckRho )
+import TcExpr		( tcCheckRho, tcMonoExpr )
 import TcHsSyn		( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
 import TcSimplify	( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify		( unifyTauTy )
+import TcUnify		( Expected, unifyTauTy, zapExpectedTo, zapExpectedType )
 import TcType		( TcType, openTypeKind, mkAppTy )
 import TcEnv		( spliceOK, tcMetaTy, tcWithTempInstEnv, bracketOK )
 import TcRnTypes	( TopEnv(..) )
-import TcMType		( newTyVarTy, zapToType, UserTypeCtxt(ExprSigCtxt) )
+import TcMType		( newTyVarTy, UserTypeCtxt(ExprSigCtxt) )
 import TcMonoType	( tcHsSigType )
 import Name		( Name )
 import TcRnMonad
@@ -54,7 +54,7 @@ tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl]
 
 tcSpliceExpr :: Name 
 	     -> RenamedHsExpr
-	     -> TcType
+	     -> Expected TcType
 	     -> TcM TcExpr
 
 #ifndef GHCI
@@ -70,7 +70,7 @@ tcSpliceDecls e     = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
 %************************************************************************
 
 \begin{code}
-tcBracket :: HsBracket Name -> TcType -> TcM TcExpr
+tcBracket :: HsBracket Name -> Expected TcType -> TcM TcExpr
 tcBracket brack res_ty
   = getStage 				`thenM` \ level ->
     case bracketOK level of {
@@ -88,7 +88,8 @@ tcBracket brack res_ty
     )					`thenM` \ (meta_ty, lie) ->
     tcSimplifyBracket lie 		`thenM_`  
 
-    unifyTauTy res_ty meta_ty		`thenM_`
+	-- Make the expected type have the right shape
+    zapExpectedTo res_ty meta_ty	`thenM_`
 
 	-- Return the original expression, not the type-decorated one
     readMutVar pending_splices		`thenM` \ pendings ->
@@ -144,7 +145,7 @@ tcSpliceExpr name expr res_ty
 	-- Here (h 4) :: Q Exp
 	-- but $(h 4) :: forall a.a 	i.e. anything!
 
-    zapToType res_ty				`thenM_`
+    zapExpectedType res_ty			`thenM_`
     tcMetaTy exprTyConName			`thenM` \ meta_exp_ty ->
     setStage (Splice next_level) (
 	setLIEVar lie_var	   $
@@ -162,7 +163,7 @@ tcSpliceExpr name expr res_ty
 -- Note that we do not decrement the level (to -1) before 
 -- typechecking the expression.  For example:
 --	f x = $( ...$(g 3) ... )
--- The recursive call to tcCheckRho will simply expand the 
+-- The recursive call to tcMonoExpr will simply expand the 
 -- inner escape before dealing with the outer one
 
 tcTopSplice expr res_ty
@@ -188,7 +189,7 @@ tcTopSplice expr res_ty
     initRn SourceMode (rnExpr expr2)		`thenM` \ (exp3, fvs) ->
     importSupportingDecls fvs			`thenM` \ env ->
 
-    setGblEnv env (tcCheckRho exp3 res_ty)
+    setGblEnv env (tcMonoExpr exp3 res_ty)
 
 
 tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr