X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=933adb8888b135764c243f2fd3a0b1bdff96e2e0;hb=e68a891932d615590d9b1ab5752ada8142db5053;hp=6cb177ed54044994ed4f878637eb83d368a7a582;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 6cb177e..933adb8 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -279,7 +279,9 @@ tc_lpat :: LPat Name
 tc_lpat (L span pat) pat_ty pstate thing_inside
   = setSrcSpan span		  $
     maybeAddErrCtxt (patCtxt pat) $
-    do	{ let (coercion, pat_ty') = refineType (pat_reft pstate) pat_ty
+    do	{ let mb_reft = refineType (pat_reft pstate) pat_ty
+	      pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty }
+
 		-- Make sure the result type reflects the current refinement
 		-- We must do this here, so that it correctly ``sees'' all
 		-- the refinements to the left.  Example:
@@ -289,7 +291,10 @@ tc_lpat (L span pat) pat_ty pstate thing_inside
 		-- pattern had better see it.
 
 	; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
-	; return (mkCoPat coercion (L span pat') pat_ty, tvs, res) }
+	; let final_pat = case mb_reft of
+				Nothing     -> pat'
+				Just (co,_) -> CoPat (WpCo co) pat' pat_ty
+	; return (L span final_pat, tvs, res) }
 
 --------------------
 tc_pat	:: PatState
@@ -526,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
@@ -548,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
 
@@ -562,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.
     --
@@ -800,7 +804,8 @@ newLitInst orig lit res_ty	-- Make a LitInst
 	; res_tau <- zapToMonotype res_ty
 	; new_uniq <- newUnique
 	; let	lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
-		lit_inst = LitInst lit_nm lit res_tau loc
+		lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, 
+				    tci_ty = res_tau, tci_loc = loc}
 	; extendLIE lit_inst
 	; return (HsVar (instToId lit_inst)) }
 \end{code}