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 ( dopt_AllowOverlappingInstances )
26 --import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv )
27 import Bag ( bagToList, Bag )
28 import Class ( Class )
29 import Var ( TyVar, Id, idName )
30 import VarSet ( unionVarSet, mkVarSet )
31 import VarEnv ( TyVarSubstEnv )
32 import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
33 import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
34 import SrcLoc ( SrcLoc )
35 import Type ( Type, ThetaType, splitTyConApp_maybe,
36 mkSigmaTy, mkDictTy, tyVarsOfTypes )
37 import PprType ( pprConstraint )
38 import Class ( classTyCon )
39 import DataCon ( DataCon )
40 import TyCon ( TyCon, tyConDataCons )
42 import HscTypes ( InstEnv, ClsInstEnv )
43 import Unify ( matchTys, unifyTyListsX )
44 import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM )
49 %************************************************************************
51 \subsection{The InstInfo type}
53 %************************************************************************
55 The InstInfo type summarises the information in an instance declaration
57 instance c => k (t tvs) where b
62 iClass :: Class, -- Class, k
63 iTyVars :: [TyVar], -- Type variables, tvs
64 iTys :: [Type], -- The types at which the class is being instantiated
65 iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
66 -- instance declaration. It constrains (some of)
68 iLocal :: Bool, -- True <=> it's defined in this module
69 iDFunId :: DFunId, -- The dfun id
70 iBinds :: RenamedMonoBinds, -- Bindings, b
71 iLoc :: SrcLoc -- Source location assoc'd with this instance's defn
72 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
75 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
76 nest 4 (ppr (iBinds info))]
78 simpleInstInfoTy :: InstInfo -> Type
79 simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
81 simpleInstInfoTyCon :: InstInfo -> TyCon
82 -- Gets the type constructor for a simple instance declaration,
83 -- i.e. one of the form instance (...) => C (T a b c) where ...
84 simpleInstInfoTyCon inst
85 = case splitTyConApp_maybe (simpleInstInfoTy inst) of
86 Just (tycon, _) -> tycon
88 isLocalInst :: InstInfo -> Bool
89 isLocalInst info = iLocal info
93 A tiny function which doesn't belong anywhere else.
94 It makes a nasty mutual-recursion knot if you put it in Class.
97 simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
98 simpleDFunClassTyCon dfun
101 (_,_,dict_ty) = splitSigmaTy (idType dfun)
102 (clas, [ty]) = splitDictTy dict_ty
103 tycon = case splitTyConApp_maybe ty of
104 Just (tycon,_) -> tycon
106 classDataCon :: Class -> DataCon
107 classDataCon clas = case tyConDataCons (classTyCon clas) of
108 (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
111 %************************************************************************
113 \subsection{Instance environments: InstEnv and ClsInstEnv}
115 %************************************************************************
117 The actual type declarations are in HscTypes.
120 emptyInstEnv :: InstEnv
121 emptyInstEnv = emptyUFM
123 classInstEnv :: InstEnv -> Class -> ClsInstEnv
124 classInstEnv env cls = lookupWithDefaultUFM env [] cls
127 A @ClsInstEnv@ lives inside a class, and identifies all the instances
128 of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
131 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
133 forall a b, C t1 t2 t3 can be constructed by dfun
135 or, to put it another way, we have
137 instance (...) => C t1 t2 t3, witnessed by dfun
139 There is an important consistency constraint in the elements of a ClsInstEnv:
141 * [a,b] must be a superset of the free vars of [t1,t2,t3]
143 * The dfun must itself be quantified over [a,b]
145 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
146 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
147 The "a" in the pattern must be one of the forall'd variables in
152 Notes on overlapping instances
153 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
154 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
156 In others, overlap is permitted, but only in such a way that one can make
157 a unique choice when looking up. That is, overlap is only permitted if
158 one template matches the other, or vice versa. So this is ok:
166 If overlap is permitted, the list is kept most specific first, so that
167 the first lookup is the right choice.
170 For now we just use association lists.
172 \subsection{Avoiding a problem with overlapping}
174 Consider this little program:
177 class C a where c :: a
178 class C a => D a where d :: a
180 instance C Int where c = 17
181 instance D Int where d = 13
183 instance C a => C [a] where c = [c]
184 instance ({- C [a], -} D a) => D [a] where d = c
186 instance C [Int] where c = [37]
188 main = print (d :: [Int])
191 What do you think `main' prints (assuming we have overlapping instances, and
192 all that turned on)? Well, the instance for `D' at type `[a]' is defined to
193 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
194 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
195 the `C [Int]' instance is more specific).
197 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
198 was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
199 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
200 doesn't even compile! What's going on!?
202 What hugs complains about is the `D [a]' instance decl.
205 ERROR "mj.hs" (line 10): Cannot build superclass instance
207 *** Context supplied : D a
208 *** Required superclass : C [a]
211 You might wonder what hugs is complaining about. It's saying that you
212 need to add `C [a]' to the context of the `D [a]' instance (as appears
213 in comments). But there's that `C [a]' instance decl one line above
214 that says that I can reduce the need for a `C [a]' instance to the
215 need for a `C a' instance, and in this case, I already have the
216 necessary `C a' instance (since we have `D a' explicitly in the
217 context, and `C' is a superclass of `D').
219 Unfortunately, the above reasoning indicates a premature commitment to the
220 generic `C [a]' instance. I.e., it prematurely rules out the more specific
221 instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
222 add the context that hugs suggests (uncomment the `C [a]'), effectively
223 deferring the decision about which instance to use.
225 Now, interestingly enough, 4.04 has this same bug, but it's covered up
226 in this case by a little known `optimization' that was disabled in
227 4.06. Ghc-4.04 silently inserts any missing superclass context into
228 an instance declaration. In this case, it silently inserts the `C
229 [a]', and everything happens to work out.
231 (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
232 `Mark Jones', although Mark claims no credit for the `optimization' in
233 question, and would rather it stopped being called the `Mark Jones
236 So, what's the fix? I think hugs has it right. Here's why. Let's try
237 something else out with ghc-4.04. Let's add the following line:
242 Everyone raise their hand who thinks that `d :: [Int]' should give a
243 different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
244 `optimization' only applies to instance decls, not to regular
245 bindings, giving inconsistent behavior.
247 Old hugs had this same bug. Here's how we fixed it: like GHC, the
248 list of instances for a given class is ordered, so that more specific
249 instances come before more generic ones. For example, the instance
250 list for C might contain:
251 ..., C Int, ..., C a, ...
252 When we go to look for a `C Int' instance we'll get that one first.
253 But what if we go looking for a `C b' (`b' is unconstrained)? We'll
254 pass the `C Int' instance, and keep going. But if `b' is
255 unconstrained, then we don't know yet if the more specific instance
256 will eventually apply. GHC keeps going, and matches on the generic `C
257 a'. The fix is to, at each step, check to see if there's a reverse
258 match, and if so, abort the search. This prevents hugs from
259 prematurely chosing a generic instance when a more specific one
265 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
266 the env is kept ordered, the first match must be the only one. The
267 thing we are looking up can have an arbitrary "flexi" part.
270 lookupInstEnv :: InstEnv -- The envt
271 -> Class -> [Type] -- Key
274 data InstLookupResult
275 = FoundInst -- There is a (template,substitution) pair
276 -- that makes the template match the key,
277 -- and no template is an instance of the key
280 | NoMatch Bool -- Boolean is true iff there is at least one
281 -- template that matches the key.
282 -- (but there are other template(s) that are
283 -- instances of the key, so we don't report
285 -- The NoMatch True case happens when we look up
287 -- in an InstEnv that has entries for
290 -- Then which we choose would depend on the way in which 'a'
291 -- is instantiated. So we say there is no match, but identify
292 -- it as ambiguous case in the hope of giving a better error msg.
293 -- See the notes above from Jeff Lewis
295 lookupInstEnv env key_cls key_tys
296 = find (classInstEnv env key_cls)
298 key_vars = tyVarsOfTypes key_tys
300 find [] = NoMatch False
301 find ((tpl_tyvars, tpl, val) : rest)
302 = case matchTys tpl_tyvars tpl key_tys of
304 case matchTys key_vars key_tys tpl of
306 Just (_, _) -> NoMatch (any_match rest)
307 Just (subst, leftovers) -> ASSERT( null leftovers )
310 any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
311 | (tvs,tpl,_) <- rest
315 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
317 A boolean flag controls overlap reporting.
319 True => overlap is permitted, but only if one template matches the other;
320 not if they unify but neither is
323 extendInstEnv :: InstEnv -> [DFunId] -> (InstEnv, [Message])
324 -- Similar, but all we have is the DFuns
325 extendInstEnvWithDFuns env infos
328 go env msgs [] = (env, msgs)
329 go env msgs (dfun:dfuns) = case addToInstEnv inst_env dfun of
330 Succeeded new_env -> go new_env msgs dfuns
331 Failed dfun' -> go env (msg:msgs) infos
333 msg = dupInstErr dfun dfun'
336 dupInstErr dfun1 dfun2
337 -- Overlapping/duplicate instances for given class; msg could be more glamourous
338 = hang (ptext SLIT("Duplicate or overlapping instance declarations:"))
339 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
341 ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau
343 (_,_,tau) = splitSigmaTy (idType dfun)
345 addToInstEnv :: InstEnv -> DFunId
346 -> MaybeErr InstEnv -- Success...
347 DFunId -- Failure: Offending overlap
349 addToInstEnv inst_env dfun_id
350 = case insert_into (classInstEnv inst_env clas) of
351 Failed stuff -> Failed stuff
352 Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
355 (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id)
356 (clas, ins_tys) = splitDictTy dict_ty
358 ins_tv_set = mkVarSet ins_tvs
359 ins_item = (ins_tv_set, ins_tys, dfun_id)
361 insert_into [] = returnMaB [ins_item]
362 insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
365 -- (a) they are the same, or
366 -- (b) they unify, and any sort of overlap is prohibited,
367 -- (c) they unify but neither is more specific than t'other
369 || (unifiable && not opt_AllowOverlappingInstances)
370 || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
373 -- New item is an instance of current item, so drop it here
374 | ins_item_more_specific = returnMaB (ins_item : env)
376 -- Otherwise carry on
377 | otherwise = insert_into rest `thenMaB` \ rest' ->
378 returnMaB (cur_item : rest')
380 unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
381 ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
382 cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
383 identical = ins_item_more_specific && cur_item_more_specific