-tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
- = case dm_info of
- NoDefMeth -> return Nothing
- GenDefMeth -> return Nothing
- DefMeth dm_name -> do
- { let sel_name = idName sel_id
- ; local_dm_name <- newLocalName sel_name
- -- Base the local_dm_name on the selector name, because
- -- type errors from tcInstanceMethodBody come from here
-
- -- See Note [Silly default-method bind]
- -- (possibly out of date)
-
- ; let meth_bind = findMethodBind sel_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- -- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
- dm_sig_fn _ = sig_fn sel_name
- dm_id = mkDefaultMethodId sel_id dm_name
- local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
- local_dm_id = mkLocalId local_dm_name local_dm_type
- prags = prag_fn sel_name
-
- ; dm_id_w_inline <- addInlinePrags dm_id prags
- ; spec_prags <- tcSpecPrags dm_id prags
-
- ; warnTc (not (null spec_prags))
- (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
- <+> quotes (ppr sel_name))
-
- ; liftM Just $
- tcInstanceMethodBody (ClsSkol clas)
- tyvars
- [this_dict]
- Nothing
- dm_id_w_inline local_dm_id
- dm_sig_fn IsDefaultMethod meth_bind }
+tcDefMeth _ tyvars _ binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+ | NoDefMeth <- dm_info = return emptyBag
+ | otherwise
+ = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info
+ ; let L loc meth_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+ dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) })
+ -- Substitute the meth_name for the binder
+ -- NB: the binding is always a FunBind
+
+ dm_sig_fn _ = Just (clas_tv_names ++ tvs, sig_loc)
+ dm_prag_fn _ = prag_fn sel_name
+
+ ; (binds,_) <- tcExtendIdEnv [dm_id] $
+ tcPolyBinds TopLevel dm_sig_fn dm_prag_fn
+ NonRecursive NonRecursive
+ [dm_bind]
+ ; return binds }
+ where
+ sel_name = idName sel_id
+ clas_tv_names = map getName tyvars
+
+ -- Find the 'generic op :: ty' signature among the sigs
+ -- If dm_info is GenDefMeth, the corresponding signature
+ -- should jolly well exist! Hence the panic
+ genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+ , n == sel_name ] of
+ [lty] -> lty
+ _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
+
+ tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan)
+ -- Make a default-method Id of the appropriate type
+ -- That may entail getting the generic-default signature
+ -- from the type signatures.
+ -- Also return the in-scope tyvars for the default method, and their binding site
+ tc_dm_id NoDefMeth = panic "tc_dm_id"
+ tc_dm_id (DefMeth dm_name)
+ | Just (tvs, loc) <- sig_fn sel_name
+ = return (mkDefaultMethodId sel_id dm_name, tvs, loc)
+ | otherwise
+ = pprPanic "No sig for" (ppr sel_name)
+ tc_dm_id (GenDefMeth dm_name)
+ = setSrcSpan loc $
+ do { tau <- tcHsKindedType genop_lhs_ty
+ ; checkValidType (FunSigCtxt sel_name) tau
+ ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau)
+ , hsExplicitTvs genop_lhs_ty, loc ) }
+ where
+ loc = getLoc genop_lhs_ty