-tcDefMeth :: [TyVar] -> LHsBinds Name
- -> TcSigFun -> TcPragFun -> Id
- -> TcM (LHsBinds Id, Id)
-tcDefMeth tyvars binds_in sig_fn prag_fn sel_id
- = do { let sel_name = idName sel_id
- ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
- ; uniq <- newUnique
- ; let dm_ty = idType sel_id -- Same as dict selector!
- local_dm_name = setNameUnique sel_name uniq
- local_dm_id = mkLocalId local_dm_name dm_ty
- top_dm_id = mkDefaultMethodId dm_name dm_ty
- all_tvs = map tyVarName tyvars ++ (sig_fn sel_name `orElse` [])
- -- Tyvars in scope are *both* the ones from the
- -- class decl *and* ones from the method sig
-
- ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- -- We only call tcDefMeth on selectors for which
- -- there is a binding in binds_in
-
- ; tc_meth_bind <- tcMethodBind all_tvs (prag_fn sel_name)
- local_dm_id meth_bind
-
- -- See Note [Silly default-method bind]
- ; let loc = getLoc meth_bind
- top_bind = L loc $ VarBind top_dm_id $
- L loc $ HsWrap (WpLet tc_meth_bind) $
- HsVar local_dm_id
-
- ; return (unitBag top_bind, top_dm_id) }
-
-mkDefMethRdrName :: Name -> RdrName
-mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
+ -> SigFun -> PragFun -> ClassOpItem
+ -> TcM (LHsBinds TcId)
+-- Generate code for polymorphic default methods only (hence DefMeth)
+-- (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.)
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
+ = case dm_info of
+ NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+ ; return emptyBag }
+ DefMeth dm_name -> tc_dm dm_name
+ GenDefMeth dm_name -> tc_dm dm_name
+ where
+ sel_name = idName sel_id
+ prags = prag_fn sel_name
+ dm_sig_fn _ = sig_fn sel_name
+ dm_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+ -- Eg. class C a where
+ -- op :: forall b. Eq b => a -> [b] -> a
+ -- gen_op :: a -> a
+ -- generic gen_op :: D a => a -> a
+ -- The "local_dm_ty" is precisely the type in the above
+ -- type signatures, ie with no "forall a. C a =>" prefix
+
+ tc_dm dm_name
+ = do { dm_id <- tcLookupId dm_name
+ ; local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+ local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+ ; 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))
+
+ ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+ dm_id_w_inline local_dm_id dm_sig_fn
+ IsDefaultMethod dm_bind
+
+ ; return (unitBag tc_bind) }
+
+---------------
+tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
+ -> Id -> Id
+ -> SigFun -> TcSpecPrags -> LHsBind Name
+ -> TcM (LHsBind Id)
+tcInstanceMethodBody skol_info tyvars dfun_ev_vars
+ meth_id local_meth_id
+ meth_sig_fn specs
+ (L loc bind)
+ = 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
+ let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+ -- Substitute the local_meth_name for the binder
+ -- NB: the binding is always a FunBind
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
+ ; (ev_binds, (tc_bind, _))
+ <- checkConstraints skol_info tyvars dfun_ev_vars $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel meth_sig_fn no_prag_fn
+ NonRecursive NonRecursive
+ [lm_bind]
+
+ ; 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
+