----------------
-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