- meth_name = idName meth_id
- sel_name = idName sel_id
- loc = getSrcSpan meth_id
- (clas, inst_tys) = getDictClassTys this_dict
-
- this_dict_id = instToId this_dict
- error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
- error_id_app = mkLHsWrap (WpTyApp (idType meth_id)) error_id
- error_rhs = mkHsApp error_id_app $ L loc $
- HsLit (HsStringPrim (mkFastString error_msg))
- error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
-
- mk_dm_app dm_id -- dm tys inst_dict
- = mkLHsWrap (WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys)
- (L loc (HsVar dm_id))
+ sel_name = idName sel_id
+ prags = prag_fn sel_name
+ dm_sig_fn _ = sig_fn sel_name
+ dm_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+ -- Eg. class C a where
+ -- op :: forall b. Eq b => a -> [b] -> a
+ -- gen_op :: a -> a
+ -- generic gen_op :: D a => a -> a
+ -- The "local_dm_ty" is precisely the type in the above
+ -- type signatures, ie with no "forall a. C a =>" prefix
+
+ tc_dm dm_name local_dm_ty
+ = do { local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
+ dm_id = mkExportedLocalId dm_name dm_ty
+ local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+ ; dm_id_w_inline <- addInlinePrags dm_id prags
+ ; spec_prags <- tcSpecPrags dm_id prags
+
+ ; warnTc (not (null spec_prags))
+ (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+ <+> quotes (ppr sel_name))
+
+ ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+ dm_id_w_inline local_dm_id dm_sig_fn
+ IsDefaultMethod dm_bind
+
+ ; return (unitBag tc_bind) }
+
+ tc_genop_ty :: LHsType Name -> TcM Type
+ tc_genop_ty hs_ty
+ = setSrcSpan (getLoc hs_ty) $
+ do { tau <- tcHsKindedType hs_ty
+ ; checkValidType (FunSigCtxt sel_name) tau
+ ; return tau }
+
+findGenericSig :: [LSig Name] -> Name -> LHsType Name
+-- Find the 'generic op :: ty' signature among the sigs
+-- If dm_info is GenDefMeth, the corresponding signature
+-- should jolly well exist! Hence the panic
+findGenericSig sigs sel_name
+ = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+ , n == sel_name ] of
+ [lty] -> lty
+ _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
+
+---------------
+tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
+ -> Id -> Id
+ -> SigFun -> TcSpecPrags -> LHsBind Name
+ -> TcM (LHsBind Id)
+tcInstanceMethodBody skol_info tyvars dfun_ev_vars
+ meth_id local_meth_id
+ meth_sig_fn specs
+ (L loc bind)
+ = 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
+ let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+ -- Substitute the local_meth_name for the binder
+ -- NB: the binding is always a FunBind
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
+ ; (ev_binds, (tc_bind, _))
+ <- checkConstraints skol_info tyvars dfun_ev_vars $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel meth_sig_fn no_prag_fn
+ NonRecursive NonRecursive
+ [lm_bind]
+
+ ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+ , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
+ , abs_ev_binds = ev_binds
+ , abs_binds = tc_bind }
+
+ ; return (L loc full_bind) }
+ where
+ no_prag_fn _ = [] -- No pragmas for local_meth_id;
+ -- they are all for meth_id
+\end{code}