From 246dab8d62eaeb3e239c49b69ab3ad95299c1b38 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 28 Dec 2001 17:20:36 +0000
Subject: [PATCH] [project @ 2001-12-28 17:20:36 by simonpj]
 ----------------------------- 	Buglet in rank-N
 polymorphism 	-----------------------------

Fix a bug in the way result type signatures are handled; they
hadn't been brought into the rank-N polymorphism world.
---
 ghc/compiler/typecheck/TcMatches.lhs |   60 ++++++++++++++++------------------
 1 file changed, 29 insertions(+), 31 deletions(-)

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index fbc20af..ffee339 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -26,10 +26,10 @@ import Inst		( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
 import TcEnv		( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars )
 import TcPat		( tcPat, tcMonoPatBndr, polyPatSig )
 import TcMType		( newTyVarTy )
-import TcType		( TcType, TcTyVar, tyVarsOfType, isTauTy,  
+import TcType		( TcType, TcTyVar, tyVarsOfType,
 			  mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind  )
 import TcBinds		( tcBindsAndThen )
-import TcUnify		( subFunTy, unifyTauTy, checkSigTyVars, sigPatCtxt )
+import TcUnify		( subFunTy, checkSigTyVars, tcSub, isIdCoercion, (<$>), sigPatCtxt )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
 import Name		( Name )
 import TysWiredIn	( boolTy )
@@ -143,38 +143,39 @@ tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
 
   where
     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` \_ -> 
+	= tcExtendLocalValEnv xve1 			$
 
 		-- Deal with the result signature
-		-- 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)
-
-    tc_result_sig Nothing rhs_ty thing_inside
-	= 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 sig_ty rhs_ty			`thenTc_`
-	  thing_inside
-
-
-	-- glue_on just avoids stupid dross
+	  case maybe_rhs_sig of
+	    Nothing ->  tcGRHSs ctxt grhss rhs_ty	`thenTc` \ (grhss', lie) ->
+		        returnTc ((pats', grhss'), lie)
+
+	    Just sig ->	 tcAddScopedTyVars [sig]	$
+				-- Bring into scope the type variables in the signature
+			 tcHsSigType ResSigCtxt sig	`thenTc` \ sig_ty ->
+			 tcGRHSs ctxt grhss sig_ty	`thenTc` \ (grhss', lie1) ->
+			 tcSub rhs_ty sig_ty		`thenTc` \ (co_fn, lie2)  ->
+			 returnTc ((pats', lift_grhss co_fn rhs_ty grhss'), 
+				   lie1 `plusLIE` lie2)
+
+-- lift_grhss pushes the coercion down to the right hand sides,
+-- because there is no convenient place to hang it otherwise.
+lift_grhss co_fn rhs_ty grhss 
+  | isIdCoercion co_fn = grhss
+lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
+  = GRHSs (map lift_grhs grhss) binds rhs_ty	-- Change the type, since we
+  where
+    lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
+	      
+    lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
+    lift_stmt stmt	       = stmt
+   
+-- glue_on just avoids stupid dross
 glue_on _ EmptyMonoBinds grhss = grhss		-- The common case
 glue_on is_rec mbinds (GRHSs grhss binds ty)
   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 
+
 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
 	-> TcType
 	-> TcM (TcGRHSs, LIE)
@@ -451,7 +452,4 @@ stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 
 varyingArgsErr name matches
   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-
-lurkingRank2SigErr
-  = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 \end{code}
-- 
1.7.10.4