From ab8b931625e6594506dfc894cfdb521a96ad4fa1 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Mon, 10 Nov 1997 14:35:37 +0000
Subject: [PATCH] [project @ 1997-11-10 14:35:18 by simonm] Check for
declarations of non-existant methods (bug:
typecheck/should_fail/tcfail077.hs)
---
ghc/compiler/typecheck/TcClassDcl.lhs | 44 ++++++++++++++++++---------
ghc/compiler/typecheck/TcInstDcls.lhs | 14 ++++-----
ghc/compiler/types/Class.lhs | 10 ------
3 files changed, 37 insertions(+), 31 deletions(-)
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index e2e65d594a6b..284f1ce0d160 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 e0d5866b49ee..1057e4997dd0 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 5347b01b0562..3f0520f30734 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
--
GitLab