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

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index e2e65d5..284f1ce 100644 (file)
--- 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 e0d5866..1057e49 100644 (file)
--- 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 5347b01..3f0520f 100644 (file)
--- 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