[project @ 2002-03-08 15:50:53 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 81614cb..d04eaea 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -35,7 +35,7 @@ import TcPat          ( badFieldCon )
 import TcSimplify      ( tcSimplifyIPs )
 import TcMType         ( tcInstTyVars, tcInstType, newHoleTyVarTy,
                          newTyVarTy, newTyVarTys, zonkTcType )
-import TcType          ( TcType, TcSigmaType, TcPhiType,
+import TcType          ( TcType, TcSigmaType, TcPhiType, TyVarDetails(VanillaTv),
                          tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
                          isSigmaTy, mkFunTy, mkAppTy, mkTyConTy,
                          mkTyConApp, mkClassPred, tcFunArgTy,
@@ -52,7 +52,7 @@ import DataCon                ( dataConFieldLabels, dataConSig,
 import Name            ( Name )
 import TyCon           ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons )
 import Subst           ( mkTopTyVarSubst, substTheta, substTy )
-import VarSet          ( elemVarSet )
+import VarSet          ( emptyVarSet, elemVarSet )
 import TysWiredIn      ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
 import PrelNames       ( cCallableClassName, 
                          cReturnableClassName, 
@@ -85,7 +85,9 @@ tcExpr expr expected_ty
   = tcMonoExpr expr expected_ty
 
   | otherwise
-  = tcGen expected_ty (tcMonoExpr expr)                `thenTc` \ (gen_fn, expr', lie) ->
+  = tcGen expected_ty emptyVarSet (
+       tcMonoExpr expr
+    )                                  `thenTc` \ (gen_fn, expr', lie) ->
     returnTc (gen_fn <$> expr', lie)
 \end{code}
 
@@ -129,12 +131,12 @@ tcMonoExpr (HsIPVar ip) res_ty
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = tcHsSigType ExprSigCtxt poly_ty     `thenTc` \ sig_tc_ty ->
-   tcAddErrCtxt (exprSigCtxt in_expr)  $
    tcExpr expr sig_tc_ty               `thenTc` \ (expr', lie1) ->
 
        -- Must instantiate the outer for-alls of sig_tc_ty
        -- else we risk instantiating a ? res_ty to a forall-type
        -- which breaks the invariant that tcMonoExpr only returns phi-types
+   tcAddErrCtxt (exprSigCtxt in_expr)  $
    tcInstCall SignatureOrigin sig_tc_ty        `thenNF_Tc` \ (inst_fn, lie2, inst_sig_ty) ->
    tcSub res_ty inst_sig_ty            `thenTc` \ (co_fn, lie3) ->
 
@@ -442,7 +444,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
        data_cons                   = tyConDataCons tycon
        (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
     in
-    tcInstTyVars con_tyvars                    `thenNF_Tc` \ (_, result_inst_tys, _) ->
+    tcInstTyVars VanillaTv con_tyvars          `thenNF_Tc` \ (_, result_inst_tys, _) ->
 
        -- STEP 2
        -- Check that at least one constructor has all the named fields
@@ -480,7 +482,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 
        mk_inst_ty (tyvar, result_inst_ty) 
          | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
-         | otherwise                               = newTyVarTy liftedTypeKind -- Fresh type
+         | otherwise                        = newTyVarTy liftedTypeKind        -- Fresh type
     in
     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)       `thenNF_Tc` \ inst_tys ->
 
@@ -740,7 +742,7 @@ tcId name   -- Look up the Id and instantiate its type
   where
     loop orig (HsVar fun_id) lie fun_ty
        | want_method_inst fun_ty
-       = tcInstType fun_ty                     `thenNF_Tc` \ (tyvars, theta, tau) ->
+       = tcInstType VanillaTv fun_ty           `thenNF_Tc` \ (tyvars, theta, tau) ->
          newMethodWithGivenTy orig fun_id 
                (mkTyVarTys tyvars) theta tau   `thenNF_Tc` \ meth ->
          loop orig (HsVar (instToId meth)) 
@@ -1011,7 +1013,7 @@ caseScrutCtxt expr
   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 
 exprSigCtxt expr
-  = hang (ptext SLIT("In an expression with a type signature:"))
+  = hang (ptext SLIT("When checking the type signature of the expression:"))
         4 (ppr expr)
 
 listCtxt expr