X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=1057e4997dd0adcd918910b3a7cff33e98bdd82b;hb=ab8b931625e6594506dfc894cfdb521a96ad4fa1;hp=1dd90a37797c7d97aa232f7d519b933febf2b1a4;hpb=83e6048ff3de02c5fd59e00ba6426e956ffb7f94;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 1dd90a3..1057e49 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -8,8 +8,7 @@ module TcInstDcls ( tcInstDecls1, - tcInstDecls2, - tcMethodBind + tcInstDecls2 ) where @@ -34,7 +33,8 @@ import TcHsSyn ( SYN_IE(TcHsBinds), mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) -import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars ) +import TcBinds ( tcPragmaSigs ) +import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad import RnMonad ( SYN_IE(RnNameSupply) ) import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), @@ -61,9 +61,9 @@ import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, concatBag, foldBag, bagToList, listToBag, Bag ) -import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals, - opt_OmitDefaultInstanceMethods, opt_PprUserLength, - opt_SpecialiseOverloaded +import CmdLineOpts ( opt_GlasgowExts, + opt_PprUserLength, opt_SpecialiseOverloaded, + opt_WarnMissingMethods ) import Class ( GenClass, classBigSig, @@ -73,7 +73,7 @@ import Id ( GenId, idType, replacePragmaInfo, isNullaryDataCon, dataConArgTys, SYN_IE(Id) ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes ) -import Name ( nameOccName, getOccString, occNameString, moduleString, getSrcLoc, +import Name ( nameOccName, getSrcLoc, mkLocalName, isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module), NamedThing(..) ) @@ -193,8 +193,7 @@ tcInstDecls1 unf_env decls mod_name rn_name_supply in -- Handle "derived" instances; note that we only do derivings -- for things in this module; we ignore deriving decls from - -- interfaces! We pass fixities, because they may be used - -- in deriving Read and Show. + -- interfaces! tcDeriving mod_name rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> @@ -382,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 (tcMethodBind clas inst_ty' monobinds) + + 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 @@ -453,47 +455,45 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty %************************************************************************ \begin{code} -tcMethodBind +tcInstMethodBind :: Class -> TcType s -- Instance type -> RenamedMonoBinds -- Method binding -> (Id, Maybe Id) -- Selector id and default-method id -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) - = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) -> - tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> +tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ uniq -> let - meth_name = getName local_meth_id - - maybe_meth_bind = go (getOccName sel_id) meth_binds - (bndr_name, op_bind) = case maybe_meth_bind of + meth_occ = getOccName sel_id + default_meth_name = mkLocalName uniq meth_occ loc + maybe_meth_bind = find meth_occ meth_binds + the_meth_bind = case maybe_meth_bind of Just stuff -> stuff - Nothing -> (meth_name, mk_default_bind meth_name) - - (theta', tau') = splitRhoTy rho_ty' - sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc + Nothing -> mk_default_bind default_meth_name in - -- Warn if no method binding - warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id)) - (omittedMethodWarn sel_id clas) `thenNF_Tc_` - - tcBindWithSigs [bndr_name] op_bind [sig_info] - nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) -> + -- Warn if no method binding, only if -fwarn-missing-methods + + warnTc (opt_WarnMissingMethods && + not (maybeToBool maybe_meth_bind) && + not (maybeToBool maybe_dm_id)) + (omittedMethodWarn sel_id clas) `thenNF_Tc_` - returnTc (binds, insts, meth) + -- Typecheck the method binding + tcMethodBind clas origin inst_ty sel_id the_meth_bind where origin = InstanceDeclOrigin -- Poor - go occ EmptyMonoBinds = Nothing - go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2 + find occ EmptyMonoBinds = Nothing + find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2 - go occ b@(FunMonoBind op_name _ _ locn) | nameOccName op_name == occ = Just (op_name, b) - | otherwise = Nothing - go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b) - | otherwise = Nothing - go occ other = panic "Urk! Bad instance method binding" + find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b + | otherwise = Nothing + find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b + | otherwise = Nothing + find occ other = panic "Urk! Bad instance method binding" mk_default_bind local_meth_name @@ -745,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, @@ -760,7 +757,7 @@ nonBoxedPrimCCallErr clas inst_ty sty ppr sty inst_ty]) omittedMethodWarn sel_id clas sty - = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id, + = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> ppr sty sel_id, ptext SLIT("in an instance declaration for") <+> ppr sty clas] instMethodNotInClassErr occ clas sty