2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcInstUtil]{Utilities for typechecking instance declarations}
6 The bits common to TcInstDcls and TcDeriv.
9 #include "HsVersions.h"
19 import HsSyn ( MonoBinds, Fake, InPat, Sig )
20 import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
21 RenamedInstancePragmas(..) )
24 import Inst ( InstanceMapper(..) )
26 import Bag ( bagToList )
27 import Class ( GenClass, GenClassOp, ClassInstEnv(..),
28 getClassBigSig, getClassOps, getClassOpLocalType )
29 import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
30 import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
31 import MatchEnv ( nullMEnv, insertMEnv )
32 import Maybes ( MaybeErr(..), mkLookupFunDef )
33 import Name ( getSrcLoc )
34 import PprType ( GenClass, GenType, GenTyVar )
36 import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
37 import SrcLoc ( SrcLoc )
38 import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
39 splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
40 import TyVar ( GenTyVar )
41 import Unique ( Unique )
42 import Util ( equivClasses, zipWithEqual, panic )
45 import IdInfo ( noIdInfo )
46 --import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
49 instance c => k (t tvs) where b
55 [TyVar] -- Type variables, tvs
56 Type -- The type at which the class is being instantiated
57 ThetaType -- inst_decl_theta: the original context, c, from the
58 -- instance declaration. It constrains (some of)
60 ThetaType -- dfun_theta: the inst_decl_theta, plus one
61 -- element for each superclass; the "Mark
62 -- Jones optimisation"
64 [Id] -- Constant methods (either all or none)
65 RenamedMonoBinds -- Bindings, b
66 Bool -- True <=> local instance decl
67 (Maybe Module) -- Name of module where this instance defined; Nothing => Prelude
68 SrcLoc -- Source location assoc'd with this instance's defn
69 [RenamedSig] -- User pragmas recorded for generating specialised instances
72 %************************************************************************
74 \subsection{Creating instance related Ids}
76 %************************************************************************
79 mkInstanceRelatedIds :: Bool
81 -> RenamedInstancePragmas
87 -> TcM s (Id, ThetaType, [Id])
89 mkInstanceRelatedIds from_here inst_mod inst_pragmas
90 clas inst_tyvars inst_ty inst_decl_theta uprags
93 dfun_theta = case inst_decl_theta of
94 [] -> [] -- If inst_decl_theta is empty, then we don't
95 -- want to have any dict arguments, so that we can
96 -- expose the constant methods.
98 other -> inst_decl_theta ++ super_class_theta
99 -- Otherwise we pass the superclass dictionaries to
100 -- the dictionary function; the Mark Jones optimisation.
102 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
104 tcGetUnique `thenNF_Tc` \ dfun_uniq ->
105 fixTc ( \ rec_dfun_id ->
108 tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
109 `thenNF_Tc` \ dfun_pragma_info ->
111 dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
112 dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
115 let dfun_id_info = noIdInfo in -- For now
117 returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info)
118 ) `thenTc` \ dfun_id ->
120 -- MAKE THE CONSTANT-METHOD IDS
121 -- if there are no type variables involved
122 (if not (null inst_decl_theta)
126 mapTc mk_const_meth_id class_ops
127 ) `thenTc` \ const_meth_ids ->
129 returnTc (dfun_id, dfun_theta, const_meth_ids)
131 (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
132 tenv = [(class_tyvar, inst_ty)]
134 super_class_theta = super_classes `zip` (repeat inst_ty)
137 = tcGetUnique `thenNF_Tc` \ uniq ->
138 fixTc (\ rec_const_meth_id ->
141 -- Figure out the IdInfo from the pragmas
142 (case assocMaybe opname_prag_pairs (getName op) of
143 Nothing -> returnTc inline_info
144 Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
145 ) `thenNF_Tc` \ id_info ->
147 let id_info = noIdInfo -- For now
149 returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
150 from_here inst_mod id_info)
153 op_ty = getClassOpLocalType op
154 meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
156 inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
157 inline_info = if inline_me
158 then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
161 opname_prag_pairs = case inst_pragmas of
162 ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
163 other_inst_pragmas -> []
165 ops_to_inline = [op | (InlineSig op _) <- uprags]
170 %************************************************************************
172 \subsection{Converting instance info into suitable InstEnvs}
174 %************************************************************************
177 buildInstanceEnvs :: Bag InstInfo
178 -> TcM s InstanceMapper
180 buildInstanceEnvs info
182 icmp :: InstInfo -> InstInfo -> TAG_
183 (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
186 info_by_class = equivClasses icmp (bagToList info)
188 mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
190 class_lookup_fn = mkLookupFunDef (==) inst_env_entries
191 (nullMEnv, \ o -> nullSpecEnv)
193 returnTc class_lookup_fn
197 buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
198 -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
200 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
201 = foldlTc addClassInstance
202 (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas])
204 `thenTc` \ (class_inst_env, op_inst_envs) ->
205 returnTc (clas, (class_inst_env,
206 mkLookupFunDef (==) op_inst_envs
207 (panic "buildInstanceEnv")))
210 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
211 based on information from a single instance declaration. It complains
212 about any overlap with an existing instance.
216 :: (ClassInstEnv, [(ClassOp,SpecEnv)])
218 -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
221 (class_inst_env, op_spec_envs)
222 (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
223 dfun_id const_meth_ids _ _ _ src_loc _)
226 -- We only add specialised/overlapped instances
227 -- if we are specialising the overloading
228 -- ToDo ... This causes getConstMethodId errors!
230 -- if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
232 -- -- Drop this specialised/overlapped instance
233 -- returnTc (class_inst_env, op_spec_envs)
236 -- Add the instance to the class's instance environment
237 case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
238 Failed (ty', dfun_id') -> failTc (dupInstErr clas (inst_ty, src_loc)
239 (ty', getSrcLoc dfun_id'));
240 Succeeded class_inst_env' ->
242 -- If there are any constant methods, then add them to
243 -- the SpecEnv of each class op (ie selector)
245 -- Example. class Foo a where { op :: Baz b => a -> b }
246 -- instance Foo (p,q) where { op (x,y) = ... }
248 -- The constant method from the instance decl will be:
249 -- op_Pair :: forall p q b. Baz b => (p,q) -> b
251 -- What we put in op's SpecEnv is
252 -- (p,q) b |--> (\d::Foo (p,q) -> op_Pair p q b)
254 -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
255 -- purpose is to cancel with the dict to which op is applied.
257 -- NOTE THAT this correctly deals with the case where there are
258 -- constant methods even though there are type variables in the
259 -- instance declaration.
261 tcGetUnique `thenNF_Tc` \ uniq ->
263 dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
264 -- Slightly disgusting, but it's only a placeholder for
265 -- a dictionary to be chucked away.
267 op_spec_envs' | null const_meth_ids = op_spec_envs
268 | otherwise = zipWithEqual add_const_meth op_spec_envs const_meth_ids
270 add_const_meth (op,spec_env) meth_id
271 = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
272 Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
273 Succeeded spec_env' -> spec_env' )
275 (local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
276 local_tyvar_tys = mkTyVarTys local_tyvars
277 rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
278 (mkTyVarTys inst_tyvars))
281 returnTc (class_inst_env', op_spec_envs')
286 dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
287 -- Overlapping/duplicate instances for given class; msg could be more glamourous
288 = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
289 4 (showOverlap sty info1 info2)
291 showOverlap sty (ty1,loc1) (ty2,loc2)
292 = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
293 ppBesides [ppStr "at ", ppr sty loc1],
294 ppBesides [ppStr "and ", ppr sty loc2]]