[project @ 1997-11-10 14:35:18 by simonm]

Check for declarations of non-existant methods
	(bug: typecheck/should_fail/tcfail077.hs)

3 files changed, 37 insertions, 31 deletions

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index e2e65d594a..284f1ce0d1 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -6,7 +6,9 @@
 \begin{code}
 #include "HsVersions.h"
 
-module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2, 
+		    badMethodErr, tcMethodBind
+		  ) where
 
 IMP_Ubiq()
 
@@ -40,7 +42,7 @@ import PragmaInfo	( PragmaInfo(..) )
 import Bag		( bagToList, unionManyBags )
 import Class		( GenClass, mkClass, classBigSig, 
 			  classDefaultMethodId,
-			  classOpTagByOccName, SYN_IE(Class)
+			  SYN_IE(Class)
 			)
 import CmdLineOpts      ( opt_PprUserLength )
 import Id		( GenId, mkSuperDictSelId, mkMethodSelId, 
@@ -49,7 +51,8 @@ import Id		( GenId, mkSuperDictSelId, mkMethodSelId,
 			)
 import CoreUnfold	( getUnfoldingTemplate )
 import IdInfo
-import Name		( Name, isLocallyDefined, moduleString, getSrcLoc, nameOccName,
+import Name		( Name, isLocallyDefined, moduleString, getSrcLoc, 
+			  OccName, nameOccName,
 			  nameString, NamedThing(..) )
 import Outputable
 import Pretty
@@ -63,6 +66,7 @@ import TysWiredIn	( stringTy )
 import TyVar		( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
 import Unique		( Unique, Uniquable(..) )
 import Util
+import Maybes		( assocMaybe, maybeToBool )
 
 
 -- import TcPragmas	( tcGenPragmas, tcClassOpPragmas )
@@ -402,18 +406,27 @@ tcDefaultMethodBinds clas default_binds
 	clas_tyvar_set = unitTyVarSet clas_tyvar
 
 	tc_dm meth_bind
-	  = let
-		bndr_name  = case meth_bind of
-				FunMonoBind name _ _ _		-> name
-				PatMonoBind (VarPatIn name) _ _ -> name
-				
-		idx    	   = classOpTagByOccName clas (nameOccName bndr_name) - 1
-		sel_id 	   = op_sel_ids !! idx
-		Just dm_id = defm_ids !! idx
-	    in
+	  | not (maybeToBool maybe_stuff)
+	  =	-- Binding for something that isn't in the class signature
+	    failTc (badMethodErr bndr_name clas)
+
+	  | otherwise
+	  =	-- Normal case
 	    tcMethodBind clas origin inst_ty sel_id meth_bind
 						`thenTc` \ (bind, insts, (_, local_dm_id)) ->
 	    returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id))
+	  where
+	    bndr_name  = case meth_bind of
+				FunMonoBind name _ _ _		-> name
+				PatMonoBind (VarPatIn name) _ _ -> name
+				
+	    maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
+	    assoc_list  = [ (getOccName sel_id, pair) 
+			  | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
+			  ]
+	    Just (sel_id, Just dm_id) = maybe_stuff
+		 -- We're looking at a default-method binding, so the dm_id
+		 -- is sure to be there!  Hence the inner "Just".
     in	   
     tcExtendGlobalTyVars clas_tyvar_set (
 	mapAndUnzip3Tc tc_dm (flatten default_binds [])
@@ -479,9 +492,12 @@ tcMethodBind clas origin inst_ty sel_id meth_bind
 				PatMonoBind (VarPatIn name) _ loc -> (name, loc)
 \end{code}
 
-Contexts
-~~~~~~~~
+Contexts and errors
+~~~~~~~~~~~~~~~~~~~
 \begin{code}
+badMethodErr bndr clas sty
+  = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
+
 classDeclCtxt class_name sty
   = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index e0d5866b49..1057e4997d 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -34,7 +34,7 @@ import TcHsSyn		( SYN_IE(TcHsBinds),
 			  mkHsDictLam, mkHsDictApp )
 
 import TcBinds		( tcPragmaSigs )
-import TcClassDcl	( tcMethodBind )
+import TcClassDcl	( tcMethodBind, badMethodErr )
 import TcMonad
 import RnMonad		( SYN_IE(RnNameSupply) )
 import Inst		( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
@@ -381,23 +381,26 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 	-- ...[NB May 97; all ignored except INLINE]
     tcPragmaSigs uprags		`thenTc` \ (prag_fn, spec_binds, spec_lie) ->
 
-	 -- Check the method bindings
+	 -- Check that all the method bindings come from this class
     let
 	inst_tyvars_set' = mkTyVarSet inst_tyvars'
 	check_from_this_class (bndr, loc)
 	  | nameOccName bndr `elem` sel_names = returnTc ()
 	  | otherwise			      = recoverTc (returnTc ()) $
 						tcAddSrcLoc loc $
-						failTc (instBndrErr bndr clas)
+						failTc (badMethodErr bndr clas)
 	sel_names = map getOccName op_sel_ids
     in
     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))	`thenTc_`
+
+	  -- Type check the method bindings themselves
     tcExtendGlobalTyVars inst_tyvars_set' (
         tcExtendGlobalValEnv (catMaybes defm_ids) $
 		-- Default-method Ids may be mentioned in synthesised RHSs 
+
 	mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds) 
 		       (op_sel_ids `zip` defm_ids)
-    )				 	`thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
+    )		 	`thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 
 	-- Check the overloading constraints of the methods and superclasses
     let
@@ -742,9 +745,6 @@ instTypeErr ty sty
   where
     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 
-instBndrErr bndr clas sty
-  = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
-
 derivingWhenInstanceExistsErr clas tycon sty
   = hang (hsep [ptext SLIT("Deriving class"), 
 		       ppr sty clas, 
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 5347b01b05..3f0520f307 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -14,7 +14,6 @@ module Class (
 	classSuperDictSelId, classDefaultMethodId,
 	classBigSig, classInstEnv,
 	isSuperClassOf,
-	classOpTagByOccName,
 
 	SYN_IE(ClassInstEnv)
     ) where
@@ -154,15 +153,6 @@ classDictArgTys (Class _ _ _ _ sc_sel_ids meth_sel_ids _ _ _) ty
     mk_arg_ty id = case splitRhoTy (applyTy (idType id) ty) of
 			(sel_theta, meth_ty) -> ASSERT( length sel_theta == 1 )
 		   				meth_ty
-
-classOpTagByOccName clas occ
-  = go (classSelIds clas) 1
-  where
-    go (sel_id : sel_ids) tag 
-	    | getOccName (idName sel_id) == occ = tag
-	    | otherwise		                = go sel_ids (tag+1)
-    go [] _ = pprPanic "classOpTagByOccName"
-		(hsep [ppr PprDebug (getName clas), ppr PprDebug occ])
 \end{code}
 
 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of