-\begin{code}
-type MethodSpec = (Id, -- Global selector Id
- Id, -- Local Id (class tyvars instantiated)
- LHsBind Name) -- Binding for the method
-
-tcMethodBind
- :: [TcTyVar] -- Skolemised type variables for the
- -- enclosing class/instance decl.
- -- They'll be signature tyvars, and we
- -- want to check that they don't get bound
- -- Also they are scoped, so we bring them into scope
- -- Always equal the range of the type envt
- -> TcThetaType -- Available theta; it's just used for the error message
- -> [Inst] -- Available from context, used to simplify constraints
- -- from the method body
- -> TcSigFun -- For scoped tyvars, indexed by sel_name
- -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
- -> MethodSpec -- Details of this method
- -> TcM (LHsBinds Id)
-
-tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
- (sel_id, meth_id, meth_bind)
- = recoverM (return emptyLHsBinds) $ do
- -- If anything fails, recover returning no bindings.
- -- This is particularly useful when checking the default-method binding of
- -- a class decl. If we don't recover, we don't add the default method to
- -- the type enviroment, and we get a tcLookup failure on $dmeth later.
-
- -- Check the bindings; first adding inst_tyvars to the envt
- -- so that we don't quantify over them in nested places
-
- let sel_name = idName sel_id
- meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
- -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
-
- ((meth_bind, mono_bind_infos), meth_lie)
- <- tcExtendTyVarEnv inst_tyvars $
- tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
- addErrCtxt (methodCtxt sel_id) $
- getLIE $
- tcMonoBinds [meth_bind] meth_sig_fn Recursive
-
- -- Now do context reduction. We simplify wrt both the local tyvars
- -- and the ones of the class/instance decl, so that there is
- -- no problem with
- -- class C a where
- -- op :: Eq a => a -> b -> a
- --
- -- We do this for each method independently to localise error messages
-
- let
- [(_, Just sig, local_meth_id)] = mono_bind_infos
- loc = sig_loc sig
-
- addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ do
- meth_dicts <- newDictBndrs loc (sig_theta sig)
- let
- meth_tvs = sig_tvs sig
- all_tyvars = meth_tvs ++ inst_tyvars
- all_insts = avail_insts ++ meth_dicts
-
- lie_binds <- tcSimplifyCheck loc all_tyvars all_insts meth_lie
-
- checkSigTyVars all_tyvars
-
- prags <- tcPrags meth_id (prag_fn sel_name)
- 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)
-
- return (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) = do
- (mb_inst, meth_id) <- mkMethId origin clas sel_id inst_tys
- let
- meth_name = idName meth_id
-
- -- Figure out what method binding to use
- -- If the user suppplied one, use it, else construct a default one
- loc <- getSrcSpanM
- meth_bind
- <- case find_bind (idName sel_id) meth_name meth_binds of
- Just user_bind -> return user_bind
- Nothing -> do
- rhs <- mkDefMethRhs origin clas inst_tys sel_id loc dm_info
- -- Not infix decl
- return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
-
- return (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 do
- -- If it's the only one, make a 'method'
- inst_loc <- getInstLoc origin
- meth_inst <- newMethod inst_loc sel_id inst_tys
- return (Just meth_inst, instToId meth_inst)
- else do
- -- 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.)
- uniq <- newUnique
- loc <- getSrcSpanM
- let
- real_tau = mkPhiTy (tail preds) tau
- meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
-
- return (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 = do
- -- An polymorphic default method
- dm_name <- lookupImportedName (mkDefMethRdrName sel_id)
- -- Might not be imported, but will be an OrigName
- traceRn (text "mkDefMeth" <+> ppr dm_name)
- return (nlHsVar dm_name)
-
-mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth = do
- -- No default method
- -- Warn only if -fwarn-missing-methods
- warn <- doptM Opt_WarnMissingMethods
- warnTc (isInstDecl origin
- && warn
- && reportIfUnused (getOccName sel_id))
- (omittedMethodWarn sel_id)
- return error_rhs