[project @ 2003-06-27 21:17:24 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSplice.lhs

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 5f05962..a63f6bd 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -21,20 +21,20 @@ import Convert              ( convertToHsExpr, convertToHsDecls )
 import RnExpr          ( rnExpr )
 import RdrHsSyn                ( RdrNameHsExpr, RdrNameHsDecl )
 import RnHsSyn         ( RenamedHsExpr )
-import TcExpr          ( tcMonoExpr )
+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
 
 import TysWiredIn      ( mkListTy )
-import DsMeta          ( exprTyConName, declTyConName, typeTyConName, decTyConName, qTyConName )
+import DsMeta          ( expQTyConName, decQTyConName, typeQTyConName, decTyConName, qTyConName )
 import ErrUtils (Message)
 import Outputable
 import Panic           ( showException )
@@ -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 ->
@@ -97,14 +98,14 @@ tcBracket brack res_ty
 
 tc_bracket :: HsBracket Name -> TcM TcType
 tc_bracket (ExpBr expr) 
-  = newTyVarTy openTypeKind            `thenM` \ any_ty ->
-    tcMonoExpr expr any_ty             `thenM_`
-    tcMetaTy exprTyConName
+  = newTyVarTy openTypeKind    `thenM` \ any_ty ->
+    tcCheckRho expr any_ty     `thenM_`
+    tcMetaTy expQTyConName
        -- Result type is Expr (= Q Exp)
 
 tc_bracket (TypBr typ) 
   = tcHsSigType ExprSigCtxt typ                `thenM_`
-    tcMetaTy typeTyConName
+    tcMetaTy typeQTyConName
        -- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)
@@ -144,11 +145,11 @@ tcSpliceExpr name expr res_ty
        -- Here (h 4) :: Q Exp
        -- but $(h 4) :: forall a.a     i.e. anything!
 
-    zapToType res_ty                           `thenM_`
-    tcMetaTy exprTyConName                     `thenM` \ meta_exp_ty ->
+    zapExpectedType res_ty                     `thenM_`
+    tcMetaTy expQTyConName                     `thenM` \ meta_exp_ty ->
     setStage (Splice next_level) (
        setLIEVar lie_var          $
-       tcMonoExpr expr meta_exp_ty
+       tcCheckRho expr meta_exp_ty
     )                                          `thenM` \ expr' ->
 
        -- Write the pending splice into the bucket
@@ -166,7 +167,7 @@ tcSpliceExpr name expr res_ty
 -- inner escape before dealing with the outer one
 
 tcTopSplice expr res_ty
-  = tcMetaTy exprTyConName             `thenM` \ meta_exp_ty ->
+  = tcMetaTy expQTyConName             `thenM` \ meta_exp_ty ->
 
        -- Typecheck the expression
     tcTopSpliceExpr expr meta_exp_ty   `thenM` \ zonked_q_expr ->
@@ -201,7 +202,7 @@ tcTopSpliceExpr expr meta_ty
     setStage topSpliceStage $
 
        -- Typecheck the expression
-    getLIE (tcMonoExpr expr meta_ty)   `thenM` \ (expr', lie) ->
+    getLIE (tcCheckRho expr meta_ty)   `thenM` \ (expr', lie) ->
 
        -- Solve the constraints
     tcSimplifyTop lie                  `thenM` \ const_binds ->