-
----------------
-tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst]
- -> TcThetaType -> [TcType]
- -> Maybe (Inst, LHsBind Id) -> Id
- -> Name -- The local method name
- -> TcSigFun -> TcPragFun -> LHsBind Name
- -> TcM (Id, LHsBinds Id)
-tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys
- mb_this_bind sel_id local_meth_name
- sig_fn prag_fn bind@(L loc _)
- = do { 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, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
- `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
-
- local_meth_id = mkLocalId local_meth_name local_meth_ty
- meth_ty = mkSigmaTy tyvars theta local_meth_ty
- sel_name = idName sel_id
-
- -- 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 } )
-
- -- 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 sig_fn prag_fn
- NonRecursive NonRecursive
- (unitBag bind)
-
- ; meth_id <- case rigid_info of
- ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
- ; return (mkDefaultMethodId dm_name meth_ty) }
- _other -> do { meth_name <- newLocalName sel_name
- ; return (mkLocalId meth_name meth_ty) }
-
- ; let (avails, this_dict_bind)
- = case mb_this_bind of
- Nothing -> (dfun_dicts, emptyBag)
- Just (this, bind) -> (this : dfun_dicts, unitBag bind)
-
- ; inst_loc <- getInstLoc (SigOrigin rigid_info)
- ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
-
- ; let full_bind = L loc $
- AbsBinds tyvars dfun_lam_vars
- [(tyvars, meth_id, local_meth_id, [])]
- (this_dict_bind `unionBags` lie_binds
- `unionBags` tc_bind)
-
- dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
-
- ; return (meth_id, unitBag full_bind) }