+ dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
+
+ omitted_meth_warn :: SDoc
+ omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
+ <+> quotes (ppr sel_id)
+
+---------------
+tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
+ -> TcThetaType -> [TcType]
+ -> Id -> Id -> Id
+ -> [LSig Name] -> Name -> LHsBind Name
+ -> TcM (HsExpr Id, LHsBinds Id)
+tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
+ this_dict_id dfun_id sel_id
+ prags local_meth_name bind@(L loc _)
+ = do { uniq <- newUnique
+ ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
+ rho_ty = ASSERT( length sel_tyvars == length inst_tys )
+ substTyWith sel_tyvars inst_tys sel_rho
+
+ (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
+ `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+ meth_name = mkInternalName uniq (getOccName local_meth_name) loc
+ meth_ty = mkSigmaTy tyvars theta meth_tau
+ meth_id = mkLocalId meth_name meth_ty
+
+ local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
+ local_meth_id = mkLocalId local_meth_name local_meth_ty
+
+ tv_names = map tyVarName tyvars
+
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+ ; MASSERT( case getClassPredTys_maybe first_pred of
+ { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
+
+ ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind
+
+ ; let full_bind = unitBag $ L loc $
+ VarBind meth_id $ L loc $
+ mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
+ HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $
+ mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
+ wrapId meth_wrapper local_meth_id
+ this_dict_bind = unitBag $ L loc $
+ VarBind this_dict_id $ L loc $
+ wrapId meth_wrapper dfun_id
+
+ ; return (wrapId meth_wrapper meth_id, full_bind) }
+ where
+ meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)