From 5424857fe3e011665b5e9e22e21e2228924de51c Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Mon, 25 Aug 1997 22:30:14 +0000
Subject: [PATCH] [project @ 1997-08-25 22:30:14 by sof] fix for handling of
default methods
---
ghc/compiler/typecheck/TcInstDcls.lhs | 54 +++++++++++++--------------
1 file changed, 25 insertions(+), 29 deletions(-)
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 1dd90a37797c..4d82faf16011 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 )
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
--
GitLab