3 TcId, TcIdSet, tcInstId,
6 TcEnv, ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
8 initEnv, getEnvTyCons, getEnvClasses,
10 tcExtendUVarEnv, tcLookupUVar,
12 tcExtendKindEnv, tcExtendTyVarEnv,
13 tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
17 tcLookupClassByKey, tcLookupClassByKey_maybe,
19 tcExtendGlobalValEnv, tcExtendLocalValEnv,
20 tcGetValueEnv, tcSetValueEnv,
23 tcLookupValue, tcLookupValueMaybe,
24 tcLookupValueByKey, tcLookupValueByKeyMaybe,
25 explicitLookupValueByKey, explicitLookupValue,
28 newLocalId, newSpecPragmaId,
29 tcGetGlobalTyVars, tcExtendGlobalTyVars,
31 InstEnv, emptyInstEnv, addToInstEnv,
32 lookupInstEnv, InstLookupResult(..),
33 tcGetInstEnv, tcSetInstEnv, classInstEnv,
38 #include "HsVersions.h"
40 import Id ( mkUserLocal, isDataConWrapId_maybe )
41 import MkId ( mkSpecPragmaId )
42 import Var ( TyVar, Id, setVarName,
43 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
45 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
46 tcInstTyVars, zonkTcTyVars,
50 import Type ( Kind, Type, superKind,
51 tyVarsOfType, tyVarsOfTypes,
52 splitForAllTys, splitRhoTy, splitFunTys,
53 splitAlgTyConApp_maybe, getTyVar
55 import Subst ( substTy )
56 import UsageSPUtils ( unannotTy )
57 import DataCon ( DataCon )
58 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
59 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
63 import BasicTypes ( Arity )
64 import IdInfo ( vanillaIdInfo )
65 import Name ( Name, OccName, nameOccName, getSrcLoc,
66 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
68 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
69 extendNameEnv, extendNameEnvList
71 import Unify ( unifyTyListsX, matchTys )
72 import Unique ( pprUnique10, Unique, Uniquable(..) )
74 import Unique ( Uniquable(..) )
75 import Util ( zipEqual, zipWith3Equal, mapAccumL )
76 import VarEnv ( TyVarSubstEnv )
77 import SrcLoc ( SrcLoc )
78 import FastString ( FastString )
83 %************************************************************************
87 %************************************************************************
91 type TcId = Id -- Type may be a TcType
94 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
95 tcLookupDataCon con_name
96 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
97 case isDataConWrapId_maybe con_id of {
98 Nothing -> failWithTc (badCon con_id);
101 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
102 -- Ignore the con_theta; overloaded constructors only
103 -- behave differently when called, not when used for
106 (arg_tys, result_ty) = splitFunTys con_tau
108 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
109 returnTc (data_con, arg_tys, result_ty) }
111 -- A useful function that takes an occurrence of a global thing
112 -- and instantiates its type with fresh type variables
114 -> NF_TcM s ([TcTyVar], -- It's instantiated type
119 (tyvars, rho) = splitForAllTys (unannotTy (idType id))
121 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
123 rho' = substTy tenv rho
124 (theta', tau') = splitRhoTy rho'
126 returnNF_Tc (tyvars', theta', tau')
129 Between the renamer and the first invocation of the UsageSP inference,
130 identifiers read from interface files will have usage information in
131 their types, whereas other identifiers will not. The unannotTy here
132 in @tcInstId@ prevents this information from pointlessly propagating
133 further prior to the first usage inference.
136 %************************************************************************
140 %************************************************************************
142 Data type declarations
143 ~~~~~~~~~~~~~~~~~~~~~
151 (TcTyVarSet, -- The in-scope TyVars
152 TcRef TcTyVarSet) -- Free type variables of the value env
153 -- ...why mutable? see notes with tcGetGlobalTyVars
154 -- Includes the in-scope tyvars
156 type UsageEnv = NameEnv UVar
157 type TypeEnv = NameEnv TyThing
158 type ValueEnv = NameEnv Id
160 valueEnvIds :: ValueEnv -> [Id]
161 valueEnvIds ve = nameEnvElts ve
163 data TyThing = ATyVar TyVar
166 | AThing TcKind -- Used temporarily, during kind checking
167 -- For example, when checking (forall a. T a Int):
168 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
169 -- 2. Then we kind-check the (T a Int) part.
170 -- 3. Then we zonk the kind variable.
171 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
173 tyThingKind :: TyThing -> TcKind
174 tyThingKind (ATyVar tv) = tyVarKind tv
175 tyThingKind (ATyCon tc) = tyConKind tc
176 tyThingKind (AClass cl) = tyConKind (classTyCon cl) -- For some odd reason,
177 -- a class doesn't include its kind
178 tyThingKind (AThing k) = k
180 data TyThingDetails = SynTyDetails Type
181 | DataTyDetails ClassContext [DataCon] [Class]
182 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
184 initEnv :: TcRef TcTyVarSet -> TcEnv
185 initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut)
187 getEnvClasses (TcEnv _ te _ _ _) = [cl | AClass cl <- nameEnvElts te]
188 getEnvTyCons (TcEnv _ te _ _ _) = [tc | ATyCon tc <- nameEnvElts te]
191 %************************************************************************
193 \subsection{The usage environment}
195 %************************************************************************
197 Extending the usage environment
200 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
201 tcExtendUVarEnv uv_name uv scope
202 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
203 tcSetEnv (TcEnv (extendNameEnv ue uv_name uv) te ve ie gtvs) scope
206 Looking up in the environments.
209 tcLookupUVar :: Name -> NF_TcM s UVar
211 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
212 case lookupNameEnv ue uv_name of
213 Just uv -> returnNF_Tc uv
214 Nothing -> failWithTc (uvNameOutOfScope uv_name)
218 %************************************************************************
220 \subsection{The type environment}
222 %************************************************************************
225 tcExtendKindEnv :: [(Name,TcKind)] -> TcM s r -> TcM s r
226 tcExtendKindEnv pairs scope
227 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
229 te' = extendNameEnvList te [(n, AThing k) | (n,k) <- pairs]
230 -- No need to extend global tyvars for kind checking
232 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
234 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
235 tcExtendTyVarEnv tyvars scope
236 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
238 te' = extendNameEnvList te [ (getName tv, ATyVar tv) | tv <- tyvars]
239 new_tv_set = mkVarSet tyvars
240 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
242 -- It's important to add the in-scope tyvars to the global tyvar set
244 -- f (x::r) = let g y = y::r in ...
245 -- Here, g mustn't be generalised. This is also important during
246 -- class and instance decls, when we mustn't generalise the class tyvars
247 -- when typechecking the methods.
248 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
249 tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope
251 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
252 -- the signature tyvars contain the original names
253 -- the instance tyvars are what those names should be mapped to
254 -- It's needed when typechecking the method bindings of class and instance decls
255 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
257 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
258 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
259 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
261 te' = extendNameEnvList te stuff
263 tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside
265 stuff = [ (getName sig_tv, ATyVar inst_tv)
266 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
269 tcExtendGlobalTyVars extra_global_tvs scope
270 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) ->
271 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
272 tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope
274 tc_extend_gtvs gtvs extra_global_tvs
275 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
277 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
279 tcNewMutVar new_global_tyvars
282 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
283 To improve subsequent calls to the same function it writes the zonked set back into
287 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
289 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
290 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
291 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
293 global_tvs' = (tyVarsOfTypes global_tys')
295 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
296 returnNF_Tc global_tvs'
298 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
300 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
301 returnNF_Tc (varSetElems in_scope_tvs)
305 Type constructors and classes
308 tcExtendTypeEnv :: [(Name, TyThing)] -> TcM s r -> TcM s r
309 tcExtendTypeEnv bindings scope
310 = ASSERT( null [tv | (_, ATyVar tv) <- bindings] )
311 -- Not for tyvars; use tcExtendTyVarEnv
312 tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
314 te' = extendNameEnvList te bindings
316 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
320 Looking up in the environments.
323 tcLookupTy :: Name -> NF_TcM s TyThing
325 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
326 case lookupNameEnv te name of {
327 Just thing -> returnNF_Tc thing ;
330 case maybeWiredInTyConName name of
331 Just tc -> returnNF_Tc (ATyCon tc)
333 Nothing -> -- This can happen if an interface-file
334 -- unfolding is screwed up
335 failWithTc (tyNameOutOfScope name)
338 tcLookupClassByKey :: Unique -> NF_TcM s Class
339 tcLookupClassByKey key
340 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
341 case lookupUFM_Directly te key of
342 Just (AClass cl) -> returnNF_Tc cl
343 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
345 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
346 tcLookupClassByKey_maybe key
347 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
348 case lookupUFM_Directly te key of
349 Just (AClass cl) -> returnNF_Tc (Just cl)
350 other -> returnNF_Tc Nothing
352 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
353 tcLookupTyConByKey key
354 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
355 case lookupUFM_Directly te key of
356 Just (ATyCon tc) -> returnNF_Tc tc
357 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
363 %************************************************************************
365 \subsection{The value environment}
367 %************************************************************************
370 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
371 tcExtendGlobalValEnv ids scope
372 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
374 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
376 tcSetEnv (TcEnv ue te ve' ie gtvs) scope
378 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
379 tcExtendLocalValEnv names_w_ids scope
380 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) ->
381 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
383 ve' = extendNameEnvList ve names_w_ids
384 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
386 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
387 tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope
392 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
394 = case maybeWiredInIdName name of
395 Just id -> returnNF_Tc id
396 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
397 returnNF_Tc (lookupWithDefaultUFM ve def name)
399 def = pprPanic "tcLookupValue:" (ppr name)
401 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
402 tcLookupValueMaybe name
403 = case maybeWiredInIdName name of
404 Just id -> returnNF_Tc (Just id)
405 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
406 returnNF_Tc (lookupNameEnv ve name)
408 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
409 tcLookupValueByKey key
410 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
411 returnNF_Tc (explicitLookupValueByKey ve key)
413 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
414 tcLookupValueByKeyMaybe key
415 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
416 returnNF_Tc (lookupUFM_Directly ve key)
418 tcGetValueEnv :: NF_TcM s ValueEnv
420 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
424 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
425 tcSetValueEnv ve scope
426 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
427 tcSetEnv (TcEnv ue te ve ie gtvs) scope
429 -- Non-monadic version, environment given explicitly
430 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
431 explicitLookupValueByKey ve key
432 = lookupWithDefaultUFM_Directly ve def key
434 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
436 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
437 explicitLookupValue ve name
438 = case maybeWiredInIdName name of
440 Nothing -> lookupNameEnv ve name
442 -- Extract the IdInfo from an IfaceSig imported from an interface file
443 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
444 tcAddImportedIdInfo unf_env id
445 | isLocallyDefined id -- Don't look up locally defined Ids, because they
446 -- have explicit local definitions, so we get a black hole!
449 = id `lazySetIdInfo` new_info
450 -- The Id must be returned without a data dependency on maybe_id
452 new_info = case explicitLookupValue unf_env (getName id) of
453 Nothing -> vanillaIdInfo
454 Just imported_id -> idInfo imported_id
455 -- ToDo: could check that types are the same
461 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
462 newLocalId name ty loc
463 = tcGetUnique `thenNF_Tc` \ uniq ->
464 returnNF_Tc (mkUserLocal name uniq ty loc)
466 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
467 newSpecPragmaId name ty
468 = tcGetUnique `thenNF_Tc` \ uniq ->
469 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
473 %************************************************************************
475 \subsection{The instance environment}
477 %************************************************************************
480 tcGetInstEnv :: NF_TcM s InstEnv
481 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
484 tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a
485 tcSetInstEnv ie scope
486 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
487 tcSetEnv (TcEnv ue te ve ie gtvs) scope
492 type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
493 type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
495 classInstEnv :: InstEnv -> Class -> ClsInstEnv
496 classInstEnv env cls = lookupWithDefaultUFM env [] cls
499 A @ClsInstEnv@ lives inside a class, and identifies all the instances
500 of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
503 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
505 forall a b, C t1 t2 t3 can be constructed by dfun
507 or, to put it another way, we have
509 instance (...) => C t1 t2 t3, witnessed by dfun
511 There is an important consistency constraint in the elements of a ClsInstEnv:
513 * [a,b] must be a superset of the free vars of [t1,t2,t3]
515 * The dfun must itself be quantified over [a,b]
517 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
518 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
519 The "a" in the pattern must be one of the forall'd variables in
524 Notes on overlapping instances
525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
526 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
528 In others, overlap is permitted, but only in such a way that one can make
529 a unique choice when looking up. That is, overlap is only permitted if
530 one template matches the other, or vice versa. So this is ok:
538 If overlap is permitted, the list is kept most specific first, so that
539 the first lookup is the right choice.
542 For now we just use association lists.
544 \subsection{Avoiding a problem with overlapping}
546 Consider this little program:
549 class C a where c :: a
550 class C a => D a where d :: a
552 instance C Int where c = 17
553 instance D Int where d = 13
555 instance C a => C [a] where c = [c]
556 instance ({- C [a], -} D a) => D [a] where d = c
558 instance C [Int] where c = [37]
560 main = print (d :: [Int])
563 What do you think `main' prints (assuming we have overlapping instances, and
564 all that turned on)? Well, the instance for `D' at type `[a]' is defined to
565 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
566 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
567 the `C [Int]' instance is more specific).
569 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
570 was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
571 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
572 doesn't even compile! What's going on!?
574 What hugs complains about is the `D [a]' instance decl.
577 ERROR "mj.hs" (line 10): Cannot build superclass instance
579 *** Context supplied : D a
580 *** Required superclass : C [a]
583 You might wonder what hugs is complaining about. It's saying that you
584 need to add `C [a]' to the context of the `D [a]' instance (as appears
585 in comments). But there's that `C [a]' instance decl one line above
586 that says that I can reduce the need for a `C [a]' instance to the
587 need for a `C a' instance, and in this case, I already have the
588 necessary `C a' instance (since we have `D a' explicitly in the
589 context, and `C' is a superclass of `D').
591 Unfortunately, the above reasoning indicates a premature commitment to the
592 generic `C [a]' instance. I.e., it prematurely rules out the more specific
593 instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
594 add the context that hugs suggests (uncomment the `C [a]'), effectively
595 deferring the decision about which instance to use.
597 Now, interestingly enough, 4.04 has this same bug, but it's covered up
598 in this case by a little known `optimization' that was disabled in
599 4.06. Ghc-4.04 silently inserts any missing superclass context into
600 an instance declaration. In this case, it silently inserts the `C
601 [a]', and everything happens to work out.
603 (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
604 `Mark Jones', although Mark claims no credit for the `optimization' in
605 question, and would rather it stopped being called the `Mark Jones
608 So, what's the fix? I think hugs has it right. Here's why. Let's try
609 something else out with ghc-4.04. Let's add the following line:
614 Everyone raise their hand who thinks that `d :: [Int]' should give a
615 different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
616 `optimization' only applies to instance decls, not to regular
617 bindings, giving inconsistent behavior.
619 Old hugs had this same bug. Here's how we fixed it: like GHC, the
620 list of instances for a given class is ordered, so that more specific
621 instances come before more generic ones. For example, the instance
622 list for C might contain:
623 ..., C Int, ..., C a, ...
624 When we go to look for a `C Int' instance we'll get that one first.
625 But what if we go looking for a `C b' (`b' is unconstrained)? We'll
626 pass the `C Int' instance, and keep going. But if `b' is
627 unconstrained, then we don't know yet if the more specific instance
628 will eventually apply. GHC keeps going, and matches on the generic `C
629 a'. The fix is to, at each step, check to see if there's a reverse
630 match, and if so, abort the search. This prevents hugs from
631 prematurely chosing a generic instance when a more specific one
637 emptyInstEnv :: InstEnv
638 emptyInstEnv = emptyUFM
641 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
642 the env is kept ordered, the first match must be the only one. The
643 thing we are looking up can have an arbitrary "flexi" part.
646 lookupInstEnv :: InstEnv -- The envt
647 -> Class -> [Type] -- Key
650 data InstLookupResult
651 = FoundInst -- There is a (template,substitution) pair
652 -- that makes the template match the key,
653 -- and no template is an instance of the key
656 | NoMatch Bool -- Boolean is true iff there is at least one
657 -- template that matches the key.
658 -- (but there are other template(s) that are
659 -- instances of the key, so we don't report
661 -- The NoMatch True case happens when we look up
663 -- in an InstEnv that has entries for
666 -- Then which we choose would depend on the way in which 'a'
667 -- is instantiated. So we say there is no match, but identify
668 -- it as ambiguous case in the hope of giving a better error msg.
669 -- See the notes above from Jeff Lewis
671 lookupInstEnv env key_cls key_tys
672 = find (classInstEnv env key_cls)
674 key_vars = tyVarsOfTypes key_tys
676 find [] = NoMatch False
677 find ((tpl_tyvars, tpl, val) : rest)
678 = case matchTys tpl_tyvars tpl key_tys of
680 case matchTys key_vars key_tys tpl of
682 Just (_, _) -> NoMatch (any_match rest)
683 Just (subst, leftovers) -> ASSERT( null leftovers )
686 any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
687 | (tvs,tpl,_) <- rest
691 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
693 A boolean flag controls overlap reporting.
695 True => overlap is permitted, but only if one template matches the other;
696 not if they unify but neither is
699 addToInstEnv :: Bool -- True <=> overlap permitted
701 -> Class -> [TyVar] -> [Type] -> Id -- New item
702 -> MaybeErr InstEnv -- Success...
703 ([Type], Id) -- Failure: Offending overlap
705 addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
706 = case insert_into (classInstEnv inst_env clas) of
707 Failed stuff -> Failed stuff
708 Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
711 ins_tv_set = mkVarSet ins_tvs
712 ins_item = (ins_tv_set, ins_tys, value)
714 insert_into [] = returnMaB [ins_item]
715 insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
718 -- (a) they are the same, or
719 -- (b) they unify, and any sort of overlap is prohibited,
720 -- (c) they unify but neither is more specific than t'other
722 || (unifiable && not overlap_ok)
723 || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
724 = failMaB (tpl_tys, val)
726 -- New item is an instance of current item, so drop it here
727 | ins_item_more_specific = returnMaB (ins_item : env)
729 -- Otherwise carry on
730 | otherwise = insert_into rest `thenMaB` \ rest' ->
731 returnMaB (cur_item : rest')
733 unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
734 ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
735 cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
736 identical = ins_item_more_specific && cur_item_more_specific
741 %************************************************************************
745 %************************************************************************
749 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
751 = quotes (ppr op) <+> ptext SLIT("is not a primop")
753 uvNameOutOfScope name
754 = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
756 tyNameOutOfScope name
757 = quotes (ppr name) <+> ptext SLIT("is not in scope")