+ ; warnTc (not (null spec_prags))
+ (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+ <+> quotes (ppr sel_name))
+
+ ; liftM Just $
+ tcInstanceMethodBody (instLoc this_dict)
+ tyvars [this_dict]
+ ([], emptyBag)
+ dm_id_w_inline local_dm_id
+ dm_sig_fn IsDefaultMethod meth_bind }
+
+---------------
+tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
+ -> ([Inst], LHsBinds Id) -> Id -> Id
+ -> TcSigFun -> TcSpecPrags -> LHsBind Name
+ -> TcM (LHsBind Id)
+tcInstanceMethodBody inst_loc tyvars dfun_dicts
+ (this_dict, this_bind) meth_id local_meth_id
+ meth_sig_fn spec_prags bind@(L loc _)
+ = 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
+ ; ((tc_bind, _), lie) <- getLIE $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel meth_sig_fn no_prag_fn
+ NonRecursive NonRecursive
+ (unitBag bind)
+
+ ; let avails = this_dict ++ dfun_dicts
+ -- Only need the this_dict stuff if there are type
+ -- variables involved; otherwise overlap is not possible
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- in TcInstDcls
+ ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
+
+ ; let full_bind = AbsBinds tyvars dfun_lam_vars
+ [(tyvars, meth_id, local_meth_id, spec_prags)]
+ (this_bind `unionBags` lie_binds
+ `unionBags` tc_bind)
+
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+
+ ; 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