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

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 0e57a0c..9f7dbc0 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -24,7 +24,7 @@ import Name           ( Name )
 import FieldLabel      ( fieldLabelName )
 import TcEnv           ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
 import TcMType                 ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
-import TcType          ( TcType, TcTyVar, TcSigmaType,
+import TcType          ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
                          mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
                          isHoleTyVar, openTypeKind )
 import TcUnify         ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy,
@@ -150,8 +150,9 @@ tcPat tc_bndr WildPatIn pat_ty
 tcPat tc_bndr (ParPatIn parend_pat) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
-tcPat tc_bndr (SigPatIn pat sig) pat_ty
-  = tcHsSigType PatSigCtxt sig         `thenTc` \ sig_ty ->
+tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
+  = tcAddErrCtxt (patCtxt pat_in)      $
+    tcHsSigType PatSigCtxt sig         `thenTc` \ sig_ty ->
     tcSubPat sig_ty pat_ty             `thenTc` \ (co_fn, lie_sig) ->
     tcPat tc_bndr pat sig_ty           `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
     returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
@@ -392,7 +393,7 @@ tcConstructor pat con_name
             -- behave differently when called, not when used for
             -- matching.
     in
-    tcInstTyVars (ex_tvs ++ tvs)       `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+    tcInstTyVars VanillaTv (ex_tvs ++ tvs)     `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
     let
        ex_theta' = substTheta tenv ex_theta
        arg_tys'  = map (substTy tenv) arg_tys
@@ -472,7 +473,7 @@ tcSubPat sig_ty exp_ty
    else
    tcGetUnique                         `thenNF_Tc` \ uniq ->
    let
-       arg_id  = mkSysLocal SLIT("sub") uniq exp_ty
+       arg_id  = mkSysLocal FSLIT("sub") uniq exp_ty
        the_fn  = DictLam [arg_id] (co_fn <$> HsVar arg_id)
        pat_co_fn p = SigPat p exp_ty the_fn
    in
@@ -487,7 +488,7 @@ tcSubPat sig_ty exp_ty
 %************************************************************************
 
 \begin{code}
-patCtxt pat = hang (ptext SLIT("In the pattern:")) 
+patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 
                 4 (ppr pat)
 
 badFieldCon :: Name -> Name -> SDoc