Check for declarations of non-existant methods
(bug: typecheck/should_fail/tcfail077.hs)
\begin{code}
#include "HsVersions.h"
\begin{code}
#include "HsVersions.h"
-module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2,
+ badMethodErr, tcMethodBind
+ ) where
import Bag ( bagToList, unionManyBags )
import Class ( GenClass, mkClass, classBigSig,
classDefaultMethodId,
import Bag ( bagToList, unionManyBags )
import Class ( GenClass, mkClass, classBigSig,
classDefaultMethodId,
- classOpTagByOccName, SYN_IE(Class)
)
import CmdLineOpts ( opt_PprUserLength )
import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
)
import CmdLineOpts ( opt_PprUserLength )
import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
)
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
nameString, NamedThing(..) )
import Outputable
import Pretty
import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
import Unique ( Unique, Uniquable(..) )
import Util
import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
import Unique ( Unique, Uniquable(..) )
import Util
+import Maybes ( assocMaybe, maybeToBool )
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
clas_tyvar_set = unitTyVarSet clas_tyvar
tc_dm meth_bind
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))
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 [])
in
tcExtendGlobalTyVars clas_tyvar_set (
mapAndUnzip3Tc tc_dm (flatten default_binds [])
PatMonoBind (VarPatIn name) _ loc -> (name, loc)
\end{code}
PatMonoBind (VarPatIn name) _ loc -> (name, loc)
\end{code}
+Contexts and errors
+~~~~~~~~~~~~~~~~~~~
+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}
classDeclCtxt class_name sty
= hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
\end{code}
mkHsDictLam, mkHsDictApp )
import TcBinds ( tcPragmaSigs )
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),
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
-- ...[NB May 97; all ignored except INLINE]
tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
-- ...[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 $
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_`
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
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)
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
-- Check the overloading constraints of the methods and superclasses
let
where
rest_of_msg = ptext SLIT("cannot be used as an instance type")
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,
derivingWhenInstanceExistsErr clas tycon sty
= hang (hsep [ptext SLIT("Deriving class"),
ppr sty clas,
classSuperDictSelId, classDefaultMethodId,
classBigSig, classInstEnv,
isSuperClassOf,
classSuperDictSelId, classDefaultMethodId,
classBigSig, classInstEnv,
isSuperClassOf,
SYN_IE(ClassInstEnv)
) where
SYN_IE(ClassInstEnv)
) where
mk_arg_ty id = case splitRhoTy (applyTy (idType id) ty) of
(sel_theta, meth_ty) -> ASSERT( length sel_theta == 1 )
meth_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
\end{code}
@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of