- -- Inline pragmas
- -- We'll have an inline pragma on the local binding, made by tcMethodBind
- -- but that's not enough; we want one on the global default method too
- -- Specialisations, on the other hand, belong on the thing inside only, I think
- ; let sel_name = idName sel_id
- inline_prags = filter isInlineLSig (prag_fn sel_name)
- ; prags <- tcPrags meth_id inline_prags
-
- ; let full_bind = AbsBinds tyvars
- [instToId this_dict]
- [(tyvars, local_dm_id, meth_id, prags)]
- (dict_binds `unionBags` defm_bind)
- ; return (noLoc full_bind, [local_dm_id]) }}
-
-mkDefMethRdrName :: Id -> RdrName
-mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
+tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
+ -> TcSigFun -> TcPragFun -> Id
+ -> TcM (Id, LHsBind Id)
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
+ = do { let sel_name = idName sel_id
+ ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
+ ; local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, becuase
+ -- type errors from tcInstanceMethodBody come from here
+
+ -- See Note [Silly default-method bind]
+ -- (possibly out of date)
+
+ ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+ -- We only call tcDefMeth on selectors for which
+ -- there is a binding in binds_in
+
+ dm_sig_fn _ = sig_fn sel_name
+ dm_ty = idType sel_id
+ dm_id = mkDefaultMethodId dm_name dm_ty
+ local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
+ local_dm_id = mkLocalId local_dm_name local_dm_type
+
+ ; (dm_id_w_inline, spec_prags)
+ <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
+
+ ; tcInstanceMethodBody (instLoc this_dict)
+ tyvars [this_dict]
+ ([], emptyBag)
+ dm_id_w_inline local_dm_id
+ dm_sig_fn spec_prags meth_bind }
+
+---------------
+tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
+ -> ([Inst], LHsBinds Id) -> Id -> Id
+ -> TcSigFun -> [LSpecPrag] -> LHsBind Name
+ -> TcM (Id, LHsBind Id)
+tcInstanceMethodBody inst_loc tyvars dfun_dicts
+ (this_dict, this_bind) meth_id local_meth_id
+ meth_sig_fn spec_prags bind@(L loc _)
+ = do { -- Typecheck the binding, first extending the envt
+ -- so that when tcInstSig looks up the local_meth_id to find
+ -- its signature, we'll find it in the environment
+ ; ((tc_bind, _), lie) <- getLIE $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel meth_sig_fn no_prag_fn
+ NonRecursive NonRecursive
+ (unitBag bind)
+
+ ; let avails = this_dict ++ dfun_dicts
+ -- Only need the this_dict stuff if there are type
+ -- variables involved; otherwise overlap is not possible
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- in TcInstDcls
+ ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
+
+ ; let full_bind = AbsBinds tyvars dfun_lam_vars
+ [(tyvars, meth_id, local_meth_id, spec_prags)]
+ (this_bind `unionBags` lie_binds
+ `unionBags` tc_bind)
+
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+
+ ; return (meth_id, L loc full_bind) }
+ where
+ no_prag_fn _ = [] -- No pragmas for local_meth_id;
+ -- they are all for meth_id