+ let
+ TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig
+ in
+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
+ let
+ 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` \ all_tyvars' ->
+
+ let
+ -- Attach inline pragmas as appropriate
+ (final_meth_id, inlines)
+ | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+ = (meth_id `setInlinePragma` phase,
+ if inl then unitNameSet (idName meth_id) else emptyNameSet)
+ | otherwise
+ = (meth_id, emptyNameSet)
+
+ is_inline (InlineSig _ name _ _) = name == idName sel_id
+ is_inline other = False
+
+ meth_tvs' = take (length meth_tvs) all_tyvars'
+ poly_meth_bind = AbsBinds meth_tvs'
+ (map instToId meth_dicts)
+ [(meth_tvs', final_meth_id, local_meth_id)]
+ inlines
+ (lie_binds `andMonoBinds` meth_bind)
+ in
+ returnM poly_meth_bind
+
+
+mkMethodBind :: InstOrigin
+ -> Class -> [TcType] -- Class and instance types
+ -> RenamedMonoBinds -- 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
+ getSrcLocM `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 ->
+ returnM (FunMonoBind meth_name False -- Not infix decl
+ [mkSimpleMatch [] rhs placeHolderType loc] loc)
+ ) `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 ->
+ getSrcLocM `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 dm_name)
+ = -- An polymorphic default method
+ traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
+ returnM (HsVar 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 = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
+ simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
+ (HsLit (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 = [WildPat placeHolderType | 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
+
+ checkTc (isJust maybe_tycon)
+ (badGenericInstance sel_id (notSimple inst_tys)) `thenM_`
+ checkTc (isJust (tyConGenInfo tycon))
+ (badGenericInstance sel_id (notGeneric tycon)) `thenM_`
+
+ ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_`
+ returnM rhs
+ where
+ rhs = mkGenericRhs sel_id clas_tyvar tycon
+
+ stuff = vcat [ppr clas <+> ppr inst_tys,
+ nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
+
+ -- 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 InstanceDeclOrigin = True
+isInstDecl ClassDeclOrigin = False
+\end{code}