X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=a5d420930dd7adf7d8b1aa4816a2a849b0db18f3;hb=5adfdfb259415ca99d67d3c8b9e5df68cb736326;hp=c9b5d6e6503cb226a9af402ff3bba4af37e21245;hpb=1166c7d62f3fa9acd2084c90df6585cbbf868ceb;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index c9b5d6e..a5d4209 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -132,7 +132,7 @@ tcCheckExistentialPat pats [] pat_tys body_ty
   = return ()	-- Short cut for case when there are no existentials
 
 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
-  = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty)	$
+  = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty)	$
     checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
 
 data PatState = PS {
@@ -531,14 +531,14 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
 	 -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
 	 -> TcM (Pat TcId, [TcTyVar], a)
 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do	{ span <- getSrcSpanM	-- Span for the whole pattern
-	; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
-	      skol_info = PatSkol data_con span
+  = do	{ let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+	      skol_info = PatSkol data_con
 	      origin    = SigOrigin skol_info
 
 	  -- Instantiate the constructor type variables [a->ty]
 	; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty
-	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	-- Get location from monad,
+							-- not from ex_tvs
 	; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
 				      (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 	      eq_spec' = substEqSpec tenv eq_spec
@@ -553,7 +553,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 
 	; loc <- getInstLoc origin
 	; dicts <- newDictBndrs loc theta'
-	; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
+	; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate') 
+					   ex_tvs' dicts lie_req
 
 	; addDataConStupidTheta data_con ctxt_res_tys
 
@@ -567,8 +568,6 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	     ex_tvs' ++ inner_tvs, res)
 	}
   where
-    doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
-
     -- Split against the family tycon if the pattern constructor belongs to a
     -- representation tycon.
     --
@@ -895,7 +894,7 @@ existentialExplode pat
 		text "In the binding group for"])
 	4 (ppr pat)
 
-sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env 
+sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env 
   = do	{ pat_tys' <- mapM zonkTcType pat_tys
 	; body_ty' <- zonkTcType body_ty
 	; let (env1,  tidy_tys)    = tidyOpenTypes tidy_env (map idType show_ids)
@@ -905,9 +904,11 @@ sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env
 		 sep [ptext SLIT("When checking an existential match that binds"),
 		      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 		      ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
-		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty,
+		      ppr pats
 		]) }
   where
+    bound_ids = collectPatsBinders pats
     show_ids = filter is_interesting bound_ids
     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs