From 823eeb495697765fc4b81e95e3632b09ab64cc0a Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 13 Nov 2003 15:01:53 +0000
Subject: [PATCH] [project @ 2003-11-13 15:01:53 by simonpj] Check for class
 op that omits the class tyvar

---
 ghc/compiler/typecheck/TcTyClsDecls.lhs |   29 ++++++++++++++++++++---------
 1 file changed, 20 insertions(+), 9 deletions(-)

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 33c9cbd..f974252 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -29,18 +29,19 @@ import TcHsType		( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType,
 import TcMType		( newKindVar, checkValidTheta, checkValidType, checkFreeness, 
 			  UserTypeCtxt(..), SourceTyCtxt(..) ) 
 import TcUnify		( unifyKind )
-import TcType		( TcKind, ThetaType, TcType,
+import TcType		( TcKind, ThetaType, TcType, tyVarsOfType,
 			  mkArrowKind, liftedTypeKind, 
 			  tcSplitSigmaTy, tcEqType )
 import Type		( splitTyConApp_maybe, pprThetaArrow, pprParendType )
 import FieldLabel	( fieldLabelName, fieldLabelType )
 import Generics		( validGenericMethodType, canDoGenerics )
-import Class		( Class, className, classTyCon, DefMeth(..), classBigSig )
+import Class		( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
 import TyCon		( TyCon, ArgVrcs, DataConDetails(..), 
 			  tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
 			  tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
 import DataCon		( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
 import Var		( TyVar, idType, idName )
+import VarSet		( elemVarSet )
 import Name		( Name, getSrcLoc )
 import Outputable
 import Util		( zipLazy, isSingleton, notNull )
@@ -505,18 +506,23 @@ checkValidClass cls
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 
     check_op (sel_id, dm) 
-	= addErrCtxt (classOpCtxt sel_id) (
-	  checkValidTheta SigmaCtxt (tail theta) 	`thenM_`
+      = addErrCtxt (classOpCtxt sel_id tau) $ do
+	{ checkValidTheta SigmaCtxt (tail theta)
 		-- The 'tail' removes the initial (C a) from the
 		-- class itself, leaving just the method type
 
-	  checkValidType (FunSigCtxt op_name) tau	`thenM_`
+	; checkValidType (FunSigCtxt op_name) tau
+
+		-- Check that the type mentions at least one of
+		-- the class type variables
+	; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
+	          (noClassTyVarErr cls sel_id)
 
 		-- Check that for a generic method, the type of 
 		-- the method is sufficiently simple
-	  checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
+	; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
 		  (badGenericMethodType op_name op_ty)
-	)
+	}
 	where
 	  op_name = idName sel_id
 	  op_ty   = idType sel_id
@@ -544,8 +550,8 @@ dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
 			     [ ppr n <+> dcolon <+> ppr ty 
 			     | (n,ty) <- fields `zip` arg_tys]))
 
-classOpCtxt sel_id = sep [ptext SLIT("When checking the class method:"),
-			  nest 2 (ppr sel_id <+> dcolon <+> ppr (idType sel_id))]
+classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
+			      nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
 
 nullaryClassErr cls
   = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
@@ -554,6 +560,11 @@ classArityErr cls
   = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
 	  parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 
+noClassTyVarErr clas op
+  = sep [ptext SLIT("The class method") <+> quotes (ppr op),
+	 ptext SLIT("mentions none of the type variables of the class") <+> 
+		ppr clas <+> hsep (map ppr (classTyVars clas))]
+
 genericMultiParamErr clas
   = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> 
     ptext SLIT("cannot have generic methods")
-- 
1.7.10.4