X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=7d725d70201e6d45bb87a39056001345c8ee9882;hb=cbebca1c9164a5e5ae9b117d0dcf5ad217defc6d;hp=250122529b197c0bdfb8a65353d6b54cbcd321da;hpb=fdf8656855d26105ff36bdd24d41827b05037b91;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 2501225..7d725d7 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -36,7 +36,6 @@ import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
 import DynFlags
 import SrcLoc
-import ErrUtils
 import Util
 import Outputable
 import FastString
@@ -348,9 +347,9 @@ tc_lpat :: LPat Name
 	-> TcM a
 	-> TcM (LPat TcId, a)
 tc_lpat (L span pat) pat_ty penv thing_inside
-  = setSrcSpan span		  $
-    maybeAddErrCtxt (patCtxt pat) $
-    do	{ (pat', res) <- tc_pat penv pat pat_ty thing_inside
+  = setSrcSpan span $
+    do	{ (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+                                          thing_inside
 	; return (L span pat', res) }
 
 tc_lpats :: PatEnv
@@ -695,8 +694,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 
 	  else do   -- The general case, with existential, 
                     -- and local equality constraints
-	{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
-	      theta'   = substTheta tenv (eq_preds ++ theta)
+	{ let theta'   = substTheta tenv (eqSpecPreds eq_spec ++ theta)
                            -- order is *important* as we generate the list of
                            -- dictionary binders from theta'
 	      no_equalities = not (any isEqPred theta')
@@ -773,7 +771,6 @@ matchExpectedConTy data_tc pat_ty
        	     -- coi : T tys ~ pat_ty
 \end{code}
 
-Noate [
 Note [Matching constructor patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
@@ -1005,12 +1002,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 -}
 
 \begin{code}
-patCtxt :: Pat Name -> Maybe Message	-- Not all patterns are worth pushing a context
-patCtxt (VarPat _)  = Nothing
-patCtxt (ParPat _)  = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat 	    = Just (hang (ptext (sLit "In the pattern:")) 
-                         2 (ppr pat))
+maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside 
+  | not (worth_wrapping pat) = tcm thing_inside
+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+    			       -- Remember to pop before doing thing_inside
+  where
+   worth_wrapping (VarPat {}) = False
+   worth_wrapping (ParPat {}) = False
+   worth_wrapping (AsPat {})  = False
+   worth_wrapping _  	      = True
+   msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
 
 -----------------------------------------------
 checkExistentials :: [TyVar] -> PatEnv -> TcM ()