2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcInstUtil]{Utilities for typechecking instance declarations}
6 The bits common to TcInstDcls and TcDeriv.
10 InstInfo(..), pprInstInfo,
11 simpleInstInfoTy, simpleInstInfoTyCon,
13 -- Instance environment
14 InstEnv, emptyInstEnv, extendInstEnv,
15 lookupInstEnv, InstLookupResult(..),
16 classInstEnv, classDataCon
19 #include "HsVersions.h"
21 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
22 import HsTypes ( toHsType )
24 import CmdLineOpts ( DynFlags, dopt_AllowOverlappingInstances )
26 import Bag ( bagToList, Bag )
27 import Class ( Class )
28 import Var ( TyVar, Id, idName )
29 import VarSet ( unionVarSet, mkVarSet )
30 import VarEnv ( TyVarSubstEnv )
31 import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
32 import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
33 import SrcLoc ( SrcLoc )
34 import Type ( Type, ThetaType, splitTyConApp_maybe,
35 mkSigmaTy, splitSigmaTy, mkDictTy, splitDictTy,
37 import PprType ( pprConstraint )
38 import Class ( classTyCon )
39 import DataCon ( DataCon )
40 import TyCon ( TyCon, tyConDataCons )
42 import HscTypes ( InstEnv, ClsInstEnv, DFunId )
43 import Unify ( matchTys, unifyTyListsX )
44 import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM )
46 import ErrUtils ( Message )
51 %************************************************************************
53 \subsection{The InstInfo type}
55 %************************************************************************
57 The InstInfo type summarises the information in an instance declaration
59 instance c => k (t tvs) where b
64 iClass :: Class, -- Class, k
65 iTyVars :: [TyVar], -- Type variables, tvs
66 iTys :: [Type], -- The types at which the class is being instantiated
67 iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
68 -- instance declaration. It constrains (some of)
70 iLocal :: Bool, -- True <=> it's defined in this module
71 iDFunId :: DFunId, -- The dfun id
72 iBinds :: RenamedMonoBinds, -- Bindings, b
73 iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn
74 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
77 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
78 nest 4 (ppr (iBinds info))]
80 simpleInstInfoTy :: InstInfo -> Type
81 simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
83 simpleInstInfoTyCon :: InstInfo -> TyCon
84 -- Gets the type constructor for a simple instance declaration,
85 -- i.e. one of the form instance (...) => C (T a b c) where ...
86 simpleInstInfoTyCon inst
87 = case splitTyConApp_maybe (simpleInstInfoTy inst) of
88 Just (tycon, _) -> tycon
90 isLocalInst :: InstInfo -> Bool
91 isLocalInst info = iLocal info
95 A tiny function which doesn't belong anywhere else.
96 It makes a nasty mutual-recursion knot if you put it in Class.
99 simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
100 simpleDFunClassTyCon dfun
103 (_,_,dict_ty) = splitSigmaTy (idType dfun)
104 (clas, [ty]) = splitDictTy dict_ty
105 tycon = case splitTyConApp_maybe ty of
106 Just (tycon,_) -> tycon
108 classDataCon :: Class -> DataCon
109 classDataCon clas = case tyConDataCons (classTyCon clas) of
110 (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
113 %************************************************************************
115 \subsection{Instance environments: InstEnv and ClsInstEnv}
117 %************************************************************************
119 The actual type declarations are in HscTypes.
122 emptyInstEnv :: InstEnv
123 emptyInstEnv = emptyUFM
125 classInstEnv :: InstEnv -> Class -> ClsInstEnv
126 classInstEnv env cls = lookupWithDefaultUFM env [] cls
129 A @ClsInstEnv@ lives inside a class, and identifies all the instances
130 of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
133 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
135 forall a b, C t1 t2 t3 can be constructed by dfun
137 or, to put it another way, we have
139 instance (...) => C t1 t2 t3, witnessed by dfun
141 There is an important consistency constraint in the elements of a ClsInstEnv:
143 * [a,b] must be a superset of the free vars of [t1,t2,t3]
145 * The dfun must itself be quantified over [a,b]
147 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
148 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
149 The "a" in the pattern must be one of the forall'd variables in
154 Notes on overlapping instances
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
158 In others, overlap is permitted, but only in such a way that one can make
159 a unique choice when looking up. That is, overlap is only permitted if
160 one template matches the other, or vice versa. So this is ok:
168 If overlap is permitted, the list is kept most specific first, so that
169 the first lookup is the right choice.
172 For now we just use association lists.
174 \subsection{Avoiding a problem with overlapping}
176 Consider this little program:
179 class C a where c :: a
180 class C a => D a where d :: a
182 instance C Int where c = 17
183 instance D Int where d = 13
185 instance C a => C [a] where c = [c]
186 instance ({- C [a], -} D a) => D [a] where d = c
188 instance C [Int] where c = [37]
190 main = print (d :: [Int])
193 What do you think `main' prints (assuming we have overlapping instances, and
194 all that turned on)? Well, the instance for `D' at type `[a]' is defined to
195 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
196 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
197 the `C [Int]' instance is more specific).
199 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
200 was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
201 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
202 doesn't even compile! What's going on!?
204 What hugs complains about is the `D [a]' instance decl.
207 ERROR "mj.hs" (line 10): Cannot build superclass instance
209 *** Context supplied : D a
210 *** Required superclass : C [a]
213 You might wonder what hugs is complaining about. It's saying that you
214 need to add `C [a]' to the context of the `D [a]' instance (as appears
215 in comments). But there's that `C [a]' instance decl one line above
216 that says that I can reduce the need for a `C [a]' instance to the
217 need for a `C a' instance, and in this case, I already have the
218 necessary `C a' instance (since we have `D a' explicitly in the
219 context, and `C' is a superclass of `D').
221 Unfortunately, the above reasoning indicates a premature commitment to the
222 generic `C [a]' instance. I.e., it prematurely rules out the more specific
223 instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
224 add the context that hugs suggests (uncomment the `C [a]'), effectively
225 deferring the decision about which instance to use.
227 Now, interestingly enough, 4.04 has this same bug, but it's covered up
228 in this case by a little known `optimization' that was disabled in
229 4.06. Ghc-4.04 silently inserts any missing superclass context into
230 an instance declaration. In this case, it silently inserts the `C
231 [a]', and everything happens to work out.
233 (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
234 `Mark Jones', although Mark claims no credit for the `optimization' in
235 question, and would rather it stopped being called the `Mark Jones
238 So, what's the fix? I think hugs has it right. Here's why. Let's try
239 something else out with ghc-4.04. Let's add the following line:
244 Everyone raise their hand who thinks that `d :: [Int]' should give a
245 different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
246 `optimization' only applies to instance decls, not to regular
247 bindings, giving inconsistent behavior.
249 Old hugs had this same bug. Here's how we fixed it: like GHC, the
250 list of instances for a given class is ordered, so that more specific
251 instances come before more generic ones. For example, the instance
252 list for C might contain:
253 ..., C Int, ..., C a, ...
254 When we go to look for a `C Int' instance we'll get that one first.
255 But what if we go looking for a `C b' (`b' is unconstrained)? We'll
256 pass the `C Int' instance, and keep going. But if `b' is
257 unconstrained, then we don't know yet if the more specific instance
258 will eventually apply. GHC keeps going, and matches on the generic `C
259 a'. The fix is to, at each step, check to see if there's a reverse
260 match, and if so, abort the search. This prevents hugs from
261 prematurely chosing a generic instance when a more specific one
267 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
268 the env is kept ordered, the first match must be the only one. The
269 thing we are looking up can have an arbitrary "flexi" part.
272 lookupInstEnv :: InstEnv -- The envt
273 -> Class -> [Type] -- Key
276 data InstLookupResult
277 = FoundInst -- There is a (template,substitution) pair
278 -- that makes the template match the key,
279 -- and no template is an instance of the key
282 | NoMatch Bool -- Boolean is true iff there is at least one
283 -- template that matches the key.
284 -- (but there are other template(s) that are
285 -- instances of the key, so we don't report
287 -- The NoMatch True case happens when we look up
289 -- in an InstEnv that has entries for
292 -- Then which we choose would depend on the way in which 'a'
293 -- is instantiated. So we say there is no match, but identify
294 -- it as ambiguous case in the hope of giving a better error msg.
295 -- See the notes above from Jeff Lewis
297 lookupInstEnv env key_cls key_tys
298 = find (classInstEnv env key_cls)
300 key_vars = tyVarsOfTypes key_tys
302 find [] = NoMatch False
303 find ((tpl_tyvars, tpl, val) : rest)
304 = case matchTys tpl_tyvars tpl key_tys of
306 case matchTys key_vars key_tys tpl of
308 Just (_, _) -> NoMatch (any_match rest)
309 Just (subst, leftovers) -> ASSERT( null leftovers )
312 any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
313 | (tvs,tpl,_) <- rest
317 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
319 A boolean flag controls overlap reporting.
321 True => overlap is permitted, but only if one template matches the other;
322 not if they unify but neither is
325 extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message])
326 -- Similar, but all we have is the DFuns
327 extendInstEnv dflags env infos
330 go env msgs [] = (env, msgs)
331 go env msgs (dfun:dfuns) = case addToInstEnv dflags env dfun of
332 Succeeded new_env -> go new_env msgs dfuns
333 Failed dfun' -> go env (msg:msgs) infos
335 msg = dupInstErr dfun dfun'
338 dupInstErr dfun1 dfun2
339 -- Overlapping/duplicate instances for given class; msg could be more glamourous
340 = hang (ptext SLIT("Duplicate or overlapping instance declarations:"))
341 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
343 ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau
345 (_,_,tau) = splitSigmaTy (idType dfun)
347 addToInstEnv :: DynFlags
349 -> MaybeErr InstEnv -- Success...
350 DFunId -- Failure: Offending overlap
352 addToInstEnv dflags inst_env dfun_id
353 = case insert_into (classInstEnv inst_env clas) of
354 Failed stuff -> Failed stuff
355 Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
358 (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id)
359 (clas, ins_tys) = splitDictTy dict_ty
361 ins_tv_set = mkVarSet ins_tvs
362 ins_item = (ins_tv_set, ins_tys, dfun_id)
364 insert_into [] = returnMaB [ins_item]
365 insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
368 -- (a) they are the same, or
369 -- (b) they unify, and any sort of overlap is prohibited,
370 -- (c) they unify but neither is more specific than t'other
372 || (unifiable && not (dopt_AllowOverlappingInstances dflags))
373 || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
376 -- New item is an instance of current item, so drop it here
377 | ins_item_more_specific = returnMaB (ins_item : env)
379 -- Otherwise carry on
380 | otherwise = insert_into rest `thenMaB` \ rest' ->
381 returnMaB (cur_item : rest')
383 unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
384 ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
385 cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
386 identical = ins_item_more_specific && cur_item_more_specific