+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
+ let
+ meth_tvs = sig_tvs meth_sig
+ all_tyvars = meth_tvs ++ inst_tyvars
+ all_insts = avail_insts ++ meth_dicts
+ in
+ tcSimplifyCheck
+ (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
+ all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
+
+ checkSigTyVars all_tyvars `thenM_`
+
+ let
+ sel_name = idName sel_id
+ inline_prags = [ (is_inl, phase)
+ | L _ (InlineSig is_inl (L _ name) phase) <- prags,
+ name == sel_name ]
+ spec_prags = [ prag
+ | prag@(L _ (SpecSig (L _ name) _)) <- prags,
+ name == sel_name]
+
+ -- Attach inline pragmas as appropriate
+ (final_meth_id, inlines)
+ | ((is_inline, phase) : _) <- inline_prags
+ = (meth_id `setInlinePragma` phase,
+ if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
+ | otherwise
+ = (meth_id, emptyNameSet)
+
+ [(_,_,local_meth_id)] = mono_bind_infos
+ poly_meth_bind = noLoc $ AbsBinds meth_tvs
+ (map instToId meth_dicts)
+ [(meth_tvs, final_meth_id, local_meth_id)]
+ inlines
+ (lie_binds `unionBags` meth_bind)
+
+ in
+ -- Deal with specialisation pragmas
+ -- The sel_name is what appears in the pragma
+ tcExtendIdEnv2 [(sel_name, final_meth_id)] (
+ getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
+
+ -- The prag_lie for a SPECIALISE pragma will mention the function itself,
+ -- so we have to simplify them away right now lest they float outwards!
+ bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 ->
+ returnM (spec_binds1 `unionBags` spec_binds2)
+ ) `thenM` \ spec_binds ->
+
+ returnM (poly_meth_bind `consBag` spec_binds)
+
+
+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 $ FunBind (noLoc meth_name) False
+ (mkMatchGroup [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 = 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 preds tau `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
+ (srcSpanStart loc) --TODO
+ 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
+ where
+ error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
+ simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
+ (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
+ error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+
+ -- When the type is of form t1 -> t2 -> t3
+ -- make a default method like (\ _ _ -> noMethBind "blah")
+ -- rather than simply (noMethBind "blah")
+ -- Reason: if t1 or t2 are higher-ranked types we get n
+ -- silly ambiguity messages.
+ -- Example: f :: (forall a. Eq a => a -> a) -> Int
+ -- f = error "urk"
+ -- Here, tcSub tries to force (error "urk") to have the right type,
+ -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
+ -- where 't' is fresh ty var. This leads directly to "ambiguous t".
+ --
+ -- NB: technically this changes the meaning of the default-default
+ -- method slightly, because `seq` can see the lambdas. Oh well.
+ (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
+ (_,_,tau2) = tcSplitSigmaTy tau1
+ -- Need two splits because the selector can have a type like
+ -- forall a. Foo a => forall b. Eq b => ...
+ (arg_tys, _) = tcSplitFunTys tau2
+ wild_pats = [nlWildPat | ty <- arg_tys]
+
+mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
+ = -- A generic default method
+ -- If the method is defined generically, we can only do the job if the
+ -- instance declaration is for a single-parameter type class with
+ -- a type constructor applied to type arguments in the instance decl
+ -- (checkTc, so False provokes the error)
+ ASSERT( isInstDecl origin ) -- We never get here from a class decl
+ do { checkTc (isJust maybe_tycon)
+ (badGenericInstance sel_id (notSimple inst_tys))
+ ; checkTc (tyConHasGenerics tycon)
+ (badGenericInstance sel_id (notGeneric tycon))
+
+ ; dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+ (vcat [ppr clas <+> ppr inst_tys,
+ nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+ -- Rename it before returning it
+ ; (rn_rhs, _) <- rnLExpr rhs
+ ; returnM rn_rhs }
+ where
+ rhs = mkGenericRhs sel_id clas_tyvar tycon
+
+ -- The tycon is only used in the generic case, and in that
+ -- case we require that the instance decl is for a single-parameter
+ -- type class with type variable arguments:
+ -- instance (...) => C (T a b)
+ clas_tyvar = head (classTyVars clas)
+ Just tycon = maybe_tycon
+ maybe_tycon = case inst_tys of
+ [ty] -> case tcSplitTyConApp_maybe ty of
+ Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
+ other -> Nothing
+ other -> Nothing
+
+isInstDecl (SigOrigin (InstSkol _)) = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
+\end{code}