From: simonpj <unknown>
Date: Wed, 22 Aug 2001 15:35:06 +0000 (+0000)
Subject: [project @ 2001-08-22 15:35:06 by simonpj]
X-Git-Tag: Approximately_9120_patches~1124
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cd5abca9d4be624f0c4759d3ef126e4392b81ac7;p=ghc-hetmet.git

[project @ 2001-08-22 15:35:06 by simonpj]
Fix bug in result type sigs, carelessly introduced by a recent change on my part
---

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index eaaf80c..66a6816 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -142,27 +142,28 @@ tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty
     tc_grhss pats' rhs_ty 
 	=	-- Check that the remaining "expected type" is not a rank-2 type
 		-- If it is it'll mess up the unifier when checking the RHS
-	  checkTc (isTauTy rhs_ty) lurkingRank2SigErr 		`thenTc_`
+	  checkTc (isTauTy rhs_ty) lurkingRank2SigErr 	`thenTc` \_ -> 
 
 		-- Deal with the result signature
-	  tc_result_sig maybe_rhs_sig	( 
+		-- It "wraps" the rest of the body typecheck because it may
+		-- bring into scope the type variables in the signature
+	  tc_result_sig maybe_rhs_sig rhs_ty 		$
 
 		-- Typecheck the body
-		tcExtendLocalValEnv xve1 	$
-		tcGRHSs ctxt grhss rhs_ty	`thenTc` \ (grhss', lie) ->
-		returnTc ((pats', grhss'), lie)
-	  )
+	  tcExtendLocalValEnv xve1 			$
+	  tcGRHSs ctxt grhss rhs_ty			`thenTc` \ (grhss', lie) ->
+	  returnTc ((pats', grhss'), lie)
 
-    tc_result_sig Nothing thing_inside
+    tc_result_sig Nothing rhs_ty thing_inside
 	= thing_inside
-    tc_result_sig (Just sig) thing_inside
+    tc_result_sig (Just sig) rhs_ty thing_inside
 	= tcAddScopedTyVars [sig]			$
 	  tcHsSigType ResSigCtxt sig			`thenTc` \ sig_ty ->
 
 		-- Check that the signature isn't a polymorphic one, which
 		-- we don't permit (at present, anyway)
 	  checkTc (isTauTy sig_ty) (polyPatSig sig_ty)	`thenTc_`
-	  unifyTauTy expected_ty sig_ty			`thenTc_`
+	  unifyTauTy sig_ty rhs_ty			`thenTc_`
 	  thing_inside