- ; ((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) }
+ let full_given = case this_dict of
+ Nothing -> dfun_ev_vars
+ Just (EvBind dict _) -> dict : dfun_ev_vars
+ lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+ -- Substitue the local_meth_name for the binder
+ -- NB: the binding is always a FunBind
+
+ ; (ev_binds, (tc_bind, _))
+ <- checkConstraints skol_info emptyVarSet tyvars full_given $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel meth_sig_fn no_prag_fn
+ NonRecursive NonRecursive
+ [lm_bind]
+
+ -- Add the binding for this_dict, if we have one
+ ; ev_binds' <- case this_dict of
+ Nothing -> return ev_binds
+ Just (EvBind self rhs) -> extendTcEvBinds ev_binds self rhs
+
+ ; 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}
+
+\begin{code}
+instantiateMethod :: Class -> Id -> [TcType] -> TcType
+-- Take a class operation, say
+-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
+-- Instantiate it at [ty1,ty2]
+-- Return the "local method type":
+-- forall c. Ix x => (ty2,c) -> ty1
+instantiateMethod clas sel_id inst_tys
+ = ASSERT( ok_first_pred ) local_meth_ty
+ where
+ (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)
+
+ ok_first_pred = case getClassPredTys_maybe first_pred of
+ Just (clas1, _tys) -> clas == clas1
+ Nothing -> False
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+
+
+---------------------------
+findMethodBind :: Name -- Selector name
+ -> LHsBinds Name -- A group of bindings
+ -> Maybe (LHsBind Name) -- The binding
+findMethodBind sel_name binds
+ = foldlBag mplus Nothing (mapBag f binds)
+ where
+ f bind@(L _ (FunBind { fun_id = L _ op_name }))
+ | op_name == sel_name
+ = Just bind
+ f _other = Nothing