Commit e1a4f2a5 authored by simonpj's avatar simonpj
Browse files

[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
parent 0f2ca589
......@@ -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
......
......@@ -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 _)
......
......@@ -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)
......
......@@ -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
]
......
......@@ -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}
......
......@@ -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
......
......@@ -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)
......
......@@ -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.
......
......@@ -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 )
......
......@@ -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}
......
......@@ -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))))
......
......@@ -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
......
......@@ -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
......
......@@ -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"
----------------------------------------------------
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment