- let
- (tyvars, _, _, op_items) = classBigSig clas
- rigid_info = ClsSkol clas
- origin = SigOrigin rigid_info
- prag_fn = mkPragFun sigs
- sig_fn = mkTcSigFun sigs
- clas_tyvars = tcSkolSigTyVars rigid_info tyvars
- tc_dm = tcDefMeth origin clas clas_tyvars
- default_binds sig_fn prag_fn
-
- dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
- -- Generate code for polymorphic default methods only
- -- (Generic default methods have turned into instance decls by now.)
- -- This is incompatible with Hugs, which expects a polymorphic
- -- default method for every class op, regardless of whether or not
- -- the programmer supplied an explicit default decl for the class.
- -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-
- (defm_binds, dm_ids_s) <- mapAndUnzipM tc_dm dm_sel_ids
- return (listToBag defm_binds, concat dm_ids_s)
-tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-
-tcDefMeth :: InstOrigin -> Class -> [TyVar] -> LHsBinds Name
- -> TcSigFun -> TcPragFun -> Id
- -> TcM (LHsBindLR Id Var, [Id])
-tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
- = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
- ; let inst_tys = mkTyVarTys tyvars
- dm_ty = idType sel_id -- Same as dict selector!
- cls_pred = mkClassPred clas inst_tys
- local_dm_id = mkDefaultMethodId dm_name dm_ty
-
- ; loc <- getInstLoc origin
- ; this_dict <- newDictBndr loc cls_pred
- ; (_, meth_id) <- mkMethId origin clas sel_id inst_tys
- ; (defm_bind, insts_needed) <- getLIE $
- tcMethodBind origin tyvars [cls_pred] this_dict []
- sig_fn prag_fn binds_in
- (sel_id, DefMeth) meth_id
-
- ; addErrCtxt (defltMethCtxt clas) $ do
-
- -- Check the context
- { dict_binds <- tcSimplifyCheck
- loc
- tyvars
- [this_dict]
- insts_needed
-
- -- Simplification can do unification
- ; checkSigTyVars tyvars
-
- -- Inline pragmas
- -- We'll have an inline pragma on the local binding, made by tcMethodBind
- -- but that's not enough; we want one on the global default method too
- -- Specialisations, on the other hand, belong on the thing inside only, I think
- ; let sel_name = idName sel_id
- inline_prags = filter isInlineLSig (prag_fn sel_name)
- ; prags <- tcPrags meth_id inline_prags
-
- ; let full_bind = AbsBinds tyvars
- [instToId this_dict]
- [(tyvars, local_dm_id, meth_id, prags)]
- (dict_binds `unionBags` defm_bind)
- ; return (noLoc full_bind, [local_dm_id]) }}
-
-mkDefMethRdrName :: Id -> RdrName
-mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
-\end{code}