Commit 5424857f authored by sof's avatar sof

[project @ 1997-08-25 22:30:14 by sof]

fix for handling of default methods
parent 49ccdd84
......@@ -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 )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
......@@ -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(..)
)
......@@ -396,7 +396,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
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) ->
......@@ -453,47 +453,43 @@ 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))
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, _) ->
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
......
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