From e1a4f2a5be6e4cd06d96b601fefd519c2569ba99 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 29 Nov 1999 17:34:33 +0000 Subject: [PATCH] [project @ 1999-11-29 17:34:14 by simonpj] Make it so that a class decl generates default method decls for every method, not just for the ones that the user supplies default-methods for. GHC will never call these default-default methods, because when it finds an instance decl with no defn for a method, *and* the class decl doesn't have a user-programmed default method, it whips up a new default method for that instance decl so that the error message is more informative than the default-default method would be. But Hugs isn't so smart, and wants to call something from the class decl. This change required fiddling with more than I expected. Sigh. Simon --- ghc/compiler/basicTypes/MkId.lhs | 8 ++-- ghc/compiler/hsSyn/HsBinds.lhs | 12 +++-- ghc/compiler/main/Main.lhs | 12 ++--- ghc/compiler/main/MkIface.lhs | 14 +++--- ghc/compiler/parser/RdrHsSyn.lhs | 7 +-- ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/rename/RnBinds.lhs | 2 +- ghc/compiler/rename/RnIfaces.lhs | 2 +- ghc/compiler/rename/RnMonad.lhs | 2 +- ghc/compiler/rename/RnSource.lhs | 40 ++++++---------- ghc/compiler/typecheck/TcClassDcl.lhs | 77 +++++++++++++------------------ ghc/compiler/typecheck/TcInstDcls.lhs | 12 ++--- ghc/compiler/typecheck/TcSimplify.lhs | 4 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 6 +-- ghc/compiler/types/Class.lhs | 70 ++++++++++++++-------------- 15 files changed, 126 insertions(+), 144 deletions(-) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 9da068a..158cc3d 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -50,7 +50,7 @@ import Module ( Module ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Subst ( mkTopTyVarSubst, substTheta ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon ) -import Class ( Class, classBigSig, classTyCon ) +import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) import VarSet ( isEmptyVarSet ) import Const ( Con(..) ) @@ -374,7 +374,7 @@ mkDictSelId name clas ty where sel_id = mkId name ty info field_lbl = mkFieldLabel name ty tag - tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id + tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id info = mkIdInfo (RecordSelId field_lbl) `setUnfoldingInfo` unfolding @@ -384,7 +384,7 @@ mkDictSelId name clas ty unfolding = mkTopUnfolding rhs - (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas + tyvars = classTyVars clas tycon = classTyCon clas [data_con] = tyConDataCons tycon @@ -450,7 +450,7 @@ mkDictFunId :: Name -- Name to use for the dict fun; mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta = mkVanillaId dfun_name dfun_ty where - (class_tyvars, sc_theta, _, _, _) = classBigSig clas + (class_tyvars, sc_theta, _, _) = classBigSig clas sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta dfun_theta = case inst_decl_theta of diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 4d3fe4a..c09ccc3 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -218,7 +218,9 @@ data Sig name SrcLoc | ClassOpSig name -- Selector name - (Maybe name) -- Default-method name (if any) + name -- Default-method name (if any) + Bool -- True <=> there is an explicit, programmer-supplied + -- default declaration in the class decl (HsType name) SrcLoc @@ -250,7 +252,7 @@ sigsForMe f sigs = filter sig_for_me sigs where sig_for_me (Sig n _ _) = f n - sig_for_me (ClassOpSig n _ _ _) = f n + sig_for_me (ClassOpSig n _ _ _ _) = f n sig_for_me (SpecSig n _ _) = f n sig_for_me (InlineSig n _ _) = f n sig_for_me (NoInlineSig n _ _) = f n @@ -262,8 +264,8 @@ isFixitySig (FixSig _) = True isFixitySig _ = False isClassOpSig :: Sig name -> Bool -isClassOpSig (ClassOpSig _ _ _ _) = True -isClassOpSig _ = False +isClassOpSig (ClassOpSig _ _ _ _ _) = True +isClassOpSig _ = False isPragSig :: Sig name -> Bool -- Identifies pragmas @@ -285,7 +287,7 @@ instance Outputable name => Outputable (FixitySig name) where ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (ClassOpSig var _ ty _) +ppr_sig (ClassOpSig var _ _ ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] ppr_sig (SpecSig var ty _) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 432a2f2..a733c0f 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -308,12 +308,12 @@ ppSourceStats short (HsModule name version exports imports decls src_loc) count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - sig_info (Sig _ _ _) = (1,0,0,0) - sig_info (ClassOpSig _ _ _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _ _) = (0,0,0,1) - sig_info (NoInlineSig _ _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) + sig_info (Sig _ _ _) = (1,0,0,0) + sig_info (ClassOpSig _ _ _ _ _) = (0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0) + sig_info (InlineSig _ _ _) = (0,0,0,1) + sig_info (NoInlineSig _ _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) import_info (ImportDecl _ _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 9995ca3..99275c5 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -553,17 +553,17 @@ ifaceClass clas semi ] where - (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas + (clas_tyvars, sc_theta, _, op_stuff) = classBigSig clas - pp_ops | null sel_ids = empty - | otherwise = hsep [ptext SLIT("where"), - braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms))) - ] + pp_ops | null op_stuff = empty + | otherwise = hsep [ptext SLIT("where"), + braces (hsep (punctuate semi (map ppr_classop op_stuff))) + ] - ppr_classop sel_id maybe_defm + ppr_classop (sel_id, dm_id, explicit_dm) = ASSERT( sel_tyvars == clas_tyvars) hsep [ppr (getOccName sel_id), - if maybeToBool maybe_defm then equals else empty, + if explicit_dm then equals else empty, dcolon, ppr op_ty ] diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 74b4da4..6478ba1 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -218,8 +218,7 @@ mkClassDecl cxt cname tyvars sigs mbinds prags loc -- superclasses both called C!) mkClassOpSig has_default_method op ty loc - | not has_default_method = ClassOpSig op Nothing ty loc - | otherwise = ClassOpSig op (Just dm_rn) ty loc + = ClassOpSig op dm_rn has_default_method ty loc where dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) \end{code} @@ -282,7 +281,9 @@ cvValSig sig = sig cvInstDeclSig sig = sig -cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc +cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name") + (panic "cvClassOpSig:dm_present") + poly_ty src_loc cvClassOpSig sig = sig \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index a15d700..8926aeb 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -404,7 +404,7 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) (map getTyVarName tvs) `addOneToNameSet` cls where - get (ClassOpSig n _ ty _) + get (ClassOpSig n _ _ ty _) | n `elemNameSet` source_fvs = extractHsTyNames ty | otherwise = emptyFVs diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ca0f820..0036a53 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -601,7 +601,7 @@ unknownSigErr sig (what_it_is, loc) = sig_doc sig sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) -sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) +sig_doc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc) sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) sig_doc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 26bb665..2e10d79 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -839,7 +839,7 @@ getConFieldNames new_name (ConDecl con _ _ condecl src_loc : rest) getConFieldNames new_name [] = returnRn [] -getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc +getClassOpNames new_name (ClassOpSig op _ _ _ src_loc) = new_name op src_loc \end{code} @getDeclSysBinders@ gets the implicit binders introduced by a decl. diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5fe5d08..3dca987 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -44,7 +44,7 @@ import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, ) import NameSet import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) -import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas, opt_HiMap ) +import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 61dd26b..74d4a07 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -192,7 +192,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas `thenRn` \ (sigs', sig_fvs) -> mapRn_ (unknownSigErr) non_sigs `thenRn_` let - binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] + binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ] in renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) -> @@ -221,11 +221,11 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas sig_doc = text "the signatures for class" <+> ppr cname meth_doc = text "the default-methods for class" <+> ppr cname - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] + sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs] meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) meth_rdr_names = map fst meth_rdr_names_w_locs - rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn) + rn_op clas clas_tyvars sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn) = pushSrcLocRn locn $ lookupBndrRn op `thenRn` \ op_name -> @@ -240,32 +240,22 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas -- Make the default-method name getModeRn `thenRn` \ mode -> - (case (mode, maybe_dm) of - (SourceMode, _) - | op `elem` meth_rdr_names - -> -- Source class decl with an explicit method decl - newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn - `thenRn` \ dm_name -> - returnRn (Just dm_name, emptyFVs) - - | otherwise - -> -- Source class dec, no explicit method decl - returnRn (Nothing, emptyFVs) - - (InterfaceMode, Just dm_rdr_name) + (case mode of + SourceMode -> -- Source class decl + newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name -> + returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs) + + InterfaceMode -> -- Imported class that has a default method decl -- See comments with tname, snames, above lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just dm_name, unitFV dm_name) - -- An imported class decl mentions, rather than defines, - -- the default method, so we must arrange to pull it in - - (InterfaceMode, Nothing) - -- Imported class with no default metho - -> returnRn (Nothing, emptyFVs) - ) `thenRn` \ (maybe_dm_name, dm_fvs) -> + returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs) + -- An imported class decl for a class decl that had an explicit default + -- method, mentions, rather than defines, + -- the default method, so we must arrange to pull it in + ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) -> - returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs) + returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs) \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index ec003b4..6c0568c 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -40,7 +40,7 @@ import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import FieldLabel ( firstFieldLabelTag ) import Bag ( unionManyBags, bagToList ) -import Class ( mkClass, classBigSig, Class ) +import Class ( mkClass, classBigSig, classSelIds, Class, ClassOpItem ) import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) @@ -125,7 +125,7 @@ kcClassDecl (ClassDecl context class_name where the_class_sigs = filter isClassOpSig class_sigs - kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty) + kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty) \end{code} @@ -158,10 +158,10 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs -- MAKE THE CLASS OBJECT ITSELF let - (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff + (op_tys, op_items) = unzip sig_stuff rec_class_inst_env = rec_inst_mapper rec_class clas = mkClass class_name tyvars - sc_theta sc_sel_ids op_sel_ids defm_ids + sc_theta sc_sel_ids op_items tycon rec_class_inst_env @@ -250,13 +250,12 @@ tcClassSig :: ValueEnv -- Knot tying only! -> [TyVar] -- The class type variable, used for error check only -> RenamedClassOpSig -> TcM s (Type, -- Type of the method - Id, -- selector id - Maybe Id) -- default-method ids + ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding + tcClassSig rec_env rec_clas rec_clas_tyvars - (ClassOpSig op_name maybe_dm_name - op_ty - src_loc) + (ClassOpSig op_name dm_name explicit_dm + op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* @@ -273,15 +272,11 @@ tcClassSig rec_env rec_clas rec_clas_tyvars -- Build the selector id and default method id sel_id = mkDictSelId op_name rec_clas global_ty - maybe_dm_id = case maybe_dm_name of - Nothing -> Nothing - Just dm_name -> let - dm_id = mkDefaultMethodId dm_name rec_clas global_ty - in - Just (tcAddImportedIdInfo rec_env dm_id) + dm_id = mkDefaultMethodId dm_name rec_clas global_ty + final_dm_id = tcAddImportedIdInfo rec_env dm_id in -- traceTc (text "tcClassSig done" <+> ppr op_name) `thenTc_` - returnTc (local_ty, sel_id, maybe_dm_id) + returnTc (local_ty, (sel_id, final_dm_id, explicit_dm)) \end{code} @@ -341,11 +336,9 @@ tcClassDecl2 (ClassDecl context class_name -- Get the relevant class tcLookupClass class_name `thenNF_Tc` \ clas -> let - (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas - -- The selector binds are already in the selector Id's unfoldings sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id)) - | sel_id <- sc_sel_ids ++ op_sel_ids + | sel_id <- classSelIds clas ] in -- Generate bindings for the default methods @@ -425,20 +418,21 @@ tcDefaultMethodBinds tcDefaultMethodBinds clas default_binds sigs = -- Check that the default bindings come from this class - checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_` + checkFromThisClass clas op_items default_binds `thenNF_Tc_` -- Do each default method separately - mapAndUnzipTc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, const_lies) -> + -- For Hugs compatibility we make a default-method for every + -- class op, regardless of whether or not the programmer supplied an + -- explicit default decl for the class. GHC will actually never + -- call the default method for such operations, because it'll whip up + -- a more-informative default method at each instance decl. + mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) -> returnTc (plusLIEs const_lies, andMonoBindList defm_binds) where prags = filter isPragSig sigs - (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas - - sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids] - -- Just the ones for which there is an explicit - -- user default declaration + (tyvars, _, _, op_items) = classBigSig clas origin = ClassDeclOrigin @@ -451,7 +445,7 @@ tcDefaultMethodBinds clas default_binds sigs -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each - tc_dm sel_id_w_dm@(_, Just dm_id) + tc_dm op_item@(_, dm_id, _) = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> let theta = [(clas,inst_tys)] @@ -463,7 +457,7 @@ tcDefaultMethodBinds clas default_binds sigs tcExtendTyVarEnvForMeths tyvars clas_tyvars ( tcMethodBind clas origin clas_tyvars inst_tys theta default_binds prags False - sel_id_w_dm + op_item ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) -> tcAddErrCtxt (defltMethCtxt clas) $ @@ -492,8 +486,8 @@ tcDefaultMethodBinds clas default_binds sigs \end{code} \begin{code} -checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s () -checkFromThisClass clas op_sel_ids mono_binds +checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s () +checkFromThisClass clas op_items mono_binds = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_` returnNF_Tc () where @@ -501,7 +495,7 @@ checkFromThisClass clas op_sel_ids mono_binds | nameOccName bndr `elem` sel_names = returnNF_Tc () | otherwise = tcAddSrcLoc loc $ addErrTc (badMethodErr bndr clas) - sel_names = map getOccName op_sel_ids + sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items] bndrs = bagToList (collectMonoBinders mono_binds) \end{code} @@ -525,15 +519,13 @@ tcMethodBind -- the caller; here, it's just used for the error message -> RenamedMonoBinds -- Method binding (pick the right one from in here) -> [RenamedSig] -- Pramgas (just for this one) - -> Bool -- True <=> supply default decl if no explicit decl - -- This is true for instance decls, - -- false for class decls - -> (Id, Maybe Id) -- The method selector and default-method Id + -> Bool -- True <=> This method is from an instance declaration + -> ClassOpItem -- The method selector and default-method Id -> TcM s (TcMonoBinds, LIE, (LIE, TcId)) tcMethodBind clas origin inst_tyvars inst_tys inst_theta - meth_binds prags supply_default_bind - (sel_id, maybe_dm_id) + meth_binds prags is_inst_decl + (sel_id, dm_id, explicit_dm) = tcGetSrcLoc `thenNF_Tc` \ loc -> newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) -> @@ -544,7 +536,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta maybe_user_bind = find_bind meth_name meth_binds no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False} - no_user_default = case maybe_dm_id of {Nothing -> True; other -> False} meth_bind = case maybe_user_bind of Just bind -> bind @@ -554,10 +545,7 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta in -- Warn if no method binding, only if -fwarn-missing-methods - if no_user_bind && not supply_default_bind then - pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys) - else - warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default) + warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm) (omittedMethodWarn sel_id clas) `thenNF_Tc_` -- Check the bindings; first add inst_tyvars to the envt @@ -623,9 +611,8 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta loc default_expr loc - = case maybe_dm_id of - Just dm_id -> HsVar (getName dm_id) -- There's a default method - Nothing -> error_expr loc -- No default method + | explicit_dm = HsVar (getName dm_id) -- There's a default method + | otherwise = error_expr loc -- No default method error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) (HsLit (HsString (_PK_ (error_msg loc)))) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 991767a..5bd3471 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -324,9 +324,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys origin = InstanceDeclOrigin - (class_tyvars, - sc_theta, sc_sel_ids, - op_sel_ids, defm_ids) = classBigSig clas + (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas + + dm_ids = [dm_id | (_, dm_id, _) <- op_items] -- Instantiate the theta found in the original instance decl inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) @@ -342,15 +342,15 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> -- Check that all the method bindings come from this class - checkFromThisClass clas op_sel_ids monobinds `thenNF_Tc_` + checkFromThisClass clas op_items monobinds `thenNF_Tc_` tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( - tcExtendGlobalValEnv (catMaybes defm_ids) ( + tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta' monobinds uprags True) - (op_sel_ids `zip` defm_ids) + op_items )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> -- Deal with SPECIALISE instance pragmas by making them diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index ccae6cb..1b55034 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -711,7 +711,7 @@ addSuperClasses avails dict where (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas + (tyvars, sc_theta, sc_sels, _) = classBigSig clas sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta add_sc avails ((super_clas, super_tys), sc_sel) @@ -856,7 +856,7 @@ addNonIrred givens ct addSCs givens ct@(clas,tys) = foldl add givens sc_theta where - (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas + (tyvars, sc_theta_tmpl, _, _) = classBigSig clas sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl add givens ct = case lookupFM givens ct of diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index d3b82d6..5240d83 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -31,7 +31,7 @@ import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind import Type ( mkArrowKind, boxedTypeKind, mkDictTy ) -import Class ( Class, classBigSig ) +import Class ( Class ) import Var ( TyVar, tyVarKind ) import FiniteMap import Bag @@ -345,8 +345,8 @@ get_tys tys get_sigs sigs = unionManyUniqSets (map get_sig sigs) where - get_sig (ClassOpSig _ _ ty _) = get_ty ty - get_sig (FixSig _) = emptyUniqSet + get_sig (ClassOpSig _ _ _ ty _) = get_ty ty + get_sig (FixSig _) = emptyUniqSet get_sig other = panic "TcTyClsDecls:get_sig" ---------------------------------------------------- diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index be82f23..78661b1 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -5,11 +5,10 @@ \begin{code} module Class ( - Class, + Class, ClassOpItem, - mkClass, + mkClass, classTyVars, classKey, classSelIds, classTyCon, - classSuperClassTheta, classBigSig, classInstEnv ) where @@ -36,26 +35,28 @@ A @Class@ corresponds to a Greek kappa in the static semantics: \begin{code} data Class - = Class - Unique -- Key for fast comparison - Name + = Class { + classKey :: Unique, -- Key for fast comparison + className :: Name, + + classTyVars :: [TyVar], -- The class type variables - [TyVar] -- The class type variables + classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the + classSCSels :: [Id], -- corresponding selector functions to + -- extract them from a dictionary of this + -- class - [(Class,[Type])] -- Immediate superclasses, and the - [Id] -- corresponding selector functions to - -- extract them from a dictionary of this - -- class + classOpStuff :: [ClassOpItem], -- Ordered by tag - [Id] -- * selector functions - [Maybe Id] -- * default methods - -- They are all ordered by tag. The - -- selector ids contain unfoldings. + classInstEnv :: InstEnv, -- All the instances of this class - InstEnv -- All the instances of this class + classTyCon :: TyCon -- The data type constructor for dictionaries + } -- of this class - TyCon -- The data type constructor for dictionaries - -- of this class +type ClassOpItem = (Id, -- Selector function; contains unfolding + Id, -- Default methods + Bool) -- True <=> an explicit default method was + -- supplied in the class decl \end{code} The @mkClass@ function fills in the indirect superclasses. @@ -63,18 +64,21 @@ The @mkClass@ function fills in the indirect superclasses. \begin{code} mkClass :: Name -> [TyVar] -> [(Class,[Type])] -> [Id] - -> [Id] -> [Maybe Id] + -> [(Id, Id, Bool)] -> TyCon -> InstEnv -> Class mkClass name tyvars super_classes superdict_sels - dict_sels defms tycon class_insts - = Class (getUnique name) name tyvars - super_classes superdict_sels - dict_sels defms - class_insts - tycon + op_stuff tycon class_insts + = Class { classKey = getUnique name, + className = name, + classTyVars = tyvars, + classSCTheta = super_classes, + classSCSels = superdict_sels, + classOpStuff = op_stuff, + classInstEnv = class_insts, + classTyCon = tycon } \end{code} %************************************************************************ @@ -86,14 +90,12 @@ mkClass name tyvars super_classes superdict_sels The rest of these functions are just simple selectors. \begin{code} -classKey (Class key _ _ _ _ _ _ _ _) = key -classSuperClassTheta (Class _ _ _ scs _ _ _ _ _) = scs -classSelIds (Class _ _ _ _ sc_sels op_sels _ _ _) = sc_sels ++ op_sels -classTyCon (Class _ _ _ _ _ _ _ _ tc) = tc -classInstEnv (Class _ _ _ _ _ _ _ env _) = env - -classBigSig (Class _ _ tyvars super_classes sdsels sels defms _ _) - = (tyvars, super_classes, sdsels, sels, defms) +classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff}) + = sc_sels ++ [op_sel | (op_sel, _, _) <- op_stuff] + +classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, + classSCSels = sc_sels, classOpStuff = op_stuff}) + = (tyvars, sc_theta, sc_sels, op_stuff) \end{code} @@ -123,7 +125,7 @@ instance Uniquable Class where getUnique c = classKey c instance NamedThing Class where - getName (Class _ n _ _ _ _ _ _ _) = n + getName clas = className clas instance Outputable Class where ppr c = ppr (getName c) -- 1.7.10.4