- addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictBndrs loc (sig_theta sig) `thenM` \ meth_dicts ->
- let
- meth_tvs = sig_tvs sig
- all_tyvars = meth_tvs ++ inst_tyvars
- all_insts = avail_insts ++ meth_dicts
- in
- tcSimplifyCheck
- loc all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
-
- checkSigTyVars all_tyvars `thenM_`
-
- tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
- let
- poly_meth_bind = noLoc $ AbsBinds meth_tvs
- (map instToId meth_dicts)
- [(meth_tvs, meth_id, local_meth_id, prags)]
- (lie_binds `unionBags` meth_bind)
- in
- returnM (unitBag poly_meth_bind)
-
-
-mkMethodBind :: InstOrigin
- -> Class -> [TcType] -- Class and instance types
- -> LHsBinds Name -- Method binding (pick the right one from in here)
- -> ClassOpItem
- -> TcM (Maybe Inst, -- Method inst
- MethodSpec)
--- Find the binding for the specified method, or make
--- up a suitable default method if it isn't there
-
-mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
- = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
- let
- meth_name = idName meth_id
- in
- -- Figure out what method binding to use
- -- If the user suppplied one, use it, else construct a default one
- getSrcSpanM `thenM` \ loc ->
- (case find_bind (idName sel_id) meth_name meth_binds of
- Just user_bind -> returnM user_bind
- Nothing ->
- mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
- -- Not infix decl
- returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
- ) `thenM` \ meth_bind ->
-
- returnM (mb_inst, (sel_id, meth_id, meth_bind))
-
-mkMethId :: InstOrigin -> Class
- -> Id -> [TcType] -- Selector, and instance types
- -> TcM (Maybe Inst, Id)
-
--- mkMethId instantiates the selector Id at the specified types
-mkMethId origin clas sel_id inst_tys
- = let
- (tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length tyvars == length inst_tys )
- substTyWith tyvars inst_tys rho
- (preds,tau) = tcSplitPhiTy rho_ty
- first_pred = ASSERT( not (null preds)) head preds
- in
- -- The first predicate should be of form (C a b)
- -- where C is the class in question
- ASSERT( not (null preds) &&
- case getClassPredTys_maybe first_pred of
- { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
- )
- if isSingleton preds then
- -- If it's the only one, make a 'method'
- getInstLoc origin `thenM` \ inst_loc ->
- newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
- returnM (Just meth_inst, instToId meth_inst)
- else
- -- If it's not the only one we need to be careful
- -- For example, given 'op' defined thus:
- -- class Foo a where
- -- op :: (?x :: String) => a -> a
- -- (mkMethId op T) should return an Inst with type
- -- (?x :: String) => T -> T
- -- That is, the class-op's context is still there.
- -- BUT: it can't be a Method any more, because it breaks
- -- INVARIANT 2 of methods. (See the data decl for Inst.)
- newUnique `thenM` \ uniq ->
- getSrcSpanM `thenM` \ loc ->
- let
- real_tau = mkPhiTy (tail preds) tau
- meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
- in
- returnM (Nothing, meth_id)
-
- -- The user didn't supply a method binding,
- -- so we have to make up a default binding
- -- The RHS of a default method depends on the default-method info
-mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
- = -- An polymorphic default method
- lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
- -- Might not be imported, but will be an OrigName
- traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
- returnM (nlHsVar dm_name)
-
-mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
- = -- No default method
- -- Warn only if -fwarn-missing-methods
- doptM Opt_WarnMissingMethods `thenM` \ warn ->
- warnTc (isInstDecl origin
- && warn
- && reportIfUnused (getOccName sel_id))
- (omittedMethodWarn sel_id) `thenM_`
- returnM error_rhs
+tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
+
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
+ -> SigFun -> PragFun -> ClassOpItem
+ -> TcM (Maybe (LHsBind Id))
+-- 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 -> 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
+
+ ; (dm_id_w_inline, spec_prags)
+ <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
+
+ ; 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 }
+
+---------------
+tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
+ -> Maybe EvBind
+ -> Id -> Id
+ -> SigFun -> TcSpecPrags -> LHsBind Name
+ -> TcM (LHsBind Id)
+tcInstanceMethodBody skol_info tyvars dfun_ev_vars
+ this_dict 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 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) }