X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=39594f0d47fc86bdf5f72800c4e89c4cca48ac5d;hp=7cb16debf9b157ab71797aff0fdd89e9debb691a;hb=3bb700d515de2405fa5db3326482e529f332d508;hpb=b10d7d079ec9c3fc22d4700fe484dd297bddb805

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 7cb16de..39594f0 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
@@ -375,16 +374,6 @@ tc_pat penv (VarPat name) pat_ty thing_inside
     	; res <- tcExtendIdEnv1 name id thing_inside
         ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
 
-{- Need this if we re-add Method constraints 
-	; (res, binds) <- bindInstsOfPatId id $
-			  tcExtendIdEnv1 name id $
-			  (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
-			   >> thing_inside)
-	; let pat' | isEmptyTcEvBinds binds = VarPat id
-		   | otherwise		    = VarPatOut id binds
-	; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
--}
-
 tc_pat penv (ParPat pat) pat_ty thing_inside
   = do	{ (pat', res) <- tc_lpat pat pat_ty penv thing_inside
 	; return (ParPat pat', res) }
@@ -558,7 +547,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
 	; res <- tcExtendIdEnv1 name bndr_id thing_inside
 	; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
 
-tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut
 
 ----------------
 unifyPatType :: TcType -> TcType -> TcM CoercionI
@@ -679,10 +668,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 	; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
 
 	; checkExistentials ex_tvs penv 
-        ; let skol_info = case pe_ctxt penv of
-                            LamPat mc -> PatSkol data_con mc
-                            LetPat {} -> UnkSkol -- Doesn't matter
-	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	
+        ; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs
                      -- Get location from monad, not from ex_tvs
 
         ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
@@ -714,14 +700,17 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
                            -- order is *important* as we generate the list of
                            -- dictionary binders from theta'
 	      no_equalities = not (any isEqPred theta')
-
+              skol_info = case pe_ctxt penv of
+                            LamPat mc -> PatSkol data_con mc
+                            LetPat {} -> UnkSkol -- Doesn't matter
+ 
         ; gadts_on <- xoptM Opt_GADTs
 	; checkTc (no_equalities || gadts_on)
 	  	  (ptext (sLit "A pattern match on a GADT requires -XGADTs"))
 		  -- Trac #2905 decided that a *pattern-match* of a GADT
 		  -- should require the GADT language flag
 
-	; given <- newEvVars theta'
+        ; given <- newEvVars theta'
         ; (ev_binds, (arg_pats', res))
 	     <- checkConstraints skol_info ex_tvs' given $
                 tcConArgs data_con arg_tys' arg_pats penv thing_inside
@@ -784,7 +773,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
@@ -1016,12 +1004,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 ()