From 6ac7eb25f8040d81d96624757fb48df4b536a276 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 5 Sep 2005 15:28:07 +0000
Subject: [PATCH] [project @ 2005-09-05 15:28:07 by simonpj] GHC claims to
 lift the H98 restriction that a class method must not add a
 constraint on the class type variable (manual 7.4.2.1
 "Class method types").  But the validity check was
 incorrect in the case where the class method had a forall. 
 E.g. 	class C a where 	  op :: forall b. (Show b,
 Show a) => ...

This commit fixes the bug.

tcrun037, and tcfail149, test with and without -fglasgow-exts.

	MERGE TO STABLE
---
 ghc/compiler/typecheck/TcTyClsDecls.lhs |   18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 2628afc..6ff39bc 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -32,7 +32,7 @@ import TcHsType		( kcHsTyVars, kcHsLiftedSigType, kcHsType,
 			  kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig )
 import TcMType		( newKindVar, checkValidTheta, checkValidType, checkFreeness, 
 			  UserTypeCtxt(..), SourceTyCtxt(..) ) 
-import TcType		( TcKind, TcType, tyVarsOfType, 
+import TcType		( TcKind, TcType, tyVarsOfType, mkPhiTy,
 			  mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
 			  tcSplitSigmaTy, tcEqType )
 import Type		( splitTyConApp_maybe, pprThetaArrow, pprParendType )
@@ -653,7 +653,7 @@ checkValidClass cls
 	; checkValidTheta (ClassSCCtxt (className cls)) theta
 
 	-- Check the class operations
-	; mappM_ check_op op_stuff
+	; mappM_ (check_op gla_exts) op_stuff
 
   	-- Check that if the class has generic methods, then the
 	-- class has only one parameter.  We can't do generic
@@ -665,7 +665,7 @@ checkValidClass cls
     unary 	= isSingleton tyvars
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 
-    check_op (sel_id, dm) 
+    check_op gla_exts (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
 	{ checkValidTheta SigmaCtxt (tail theta)
 		-- The 'tail' removes the initial (C a) from the
@@ -686,8 +686,16 @@ checkValidClass cls
 	where
 	  op_name = idName sel_id
 	  op_ty   = idType sel_id
-	  (_,theta,tau) = tcSplitSigmaTy op_ty
-
+	  (_,theta1,tau1) = tcSplitSigmaTy op_ty
+	  (_,theta2,tau2)  = tcSplitSigmaTy tau1
+	  (theta,tau) | gla_exts  = (theta1 ++ theta2, tau2)
+		      | otherwise = (theta1, 	       mkPhiTy (tail theta1) tau1)
+		-- Ugh!  The function might have a type like
+		-- 	op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
+		-- With -fglasgow-exts, we want to allow this, even though the inner 
+		-- forall has an (Eq a) constraint.  Whereas in general, each constraint 
+		-- in the context of a for-all must mention at least one quantified
+		-- type variable.  What a mess!
 
 
 ---------------------------------------------------------------------
-- 
1.7.10.4