-\begin{code}
-mkInstanceRelatedIds :: Bool
- -> SrcLoc
- -> Module
- -> RenamedInstancePragmas
- -> Class
- -> [TyVar]
- -> Type
- -> ThetaType
- -> [RenamedSig]
- -> TcM s (Id, ThetaType, [Id])
-
-mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
- clas inst_tyvars inst_ty inst_decl_theta uprags
- = -- MAKE THE DFUN ID
- let
- dfun_theta = case inst_decl_theta of
- [] -> [] -- If inst_decl_theta is empty, then we don't
- -- want to have any dict arguments, so that we can
- -- expose the constant methods.
-
- other -> inst_decl_theta ++ super_class_theta
- -- Otherwise we pass the superclass dictionaries to
- -- the dictionary function; the Mark Jones optimisation.
-
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
- in
- tcGetUnique `thenNF_Tc` \ dfun_uniq ->
- fixTc ( \ rec_dfun_id ->
-
-{- LATER
- tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
- `thenNF_Tc` \ dfun_pragma_info ->
- let
- dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
- dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
- in
--}
- let dfun_id_info = noIdInfo in -- For now
-
- returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
- ) `thenTc` \ dfun_id ->
-
- -- MAKE THE CONSTANT-METHOD IDS
- -- if there are no type variables involved
- (if (null inst_decl_theta)
- then
- mapTc mk_const_meth_id class_ops
- else
- returnTc []
- ) `thenTc` \ const_meth_ids ->
-
- returnTc (dfun_id, dfun_theta, const_meth_ids)
- where
- (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
- tenv = [(class_tyvar, inst_ty)]
-
- super_class_theta = super_classes `zip` repeat inst_ty
-
- mk_const_meth_id op
- = tcGetUnique `thenNF_Tc` \ uniq ->
- fixTc (\ rec_const_meth_id ->
-
-{- LATER
- -- Figure out the IdInfo from the pragmas
- (case assocMaybe opname_prag_pairs (getName op) of
- Nothing -> returnTc inline_info
- Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
- ) `thenNF_Tc` \ id_info ->
--}
- let id_info = noIdInfo -- For now
- in
- returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
- from_here src_loc inst_mod id_info)
- )
- where
- op_ty = classOpLocalType op
- meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
-{- LATER
- inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
- inline_info = if inline_me
- then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
- else noIdInfo
-
- opname_prag_pairs = case inst_pragmas of
- ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
- other_inst_pragmas -> []
-
- ops_to_inline = [op | (InlineSig op _) <- uprags]
--}
-\end{code}