3 TcId, TcIdSet, tcInstId,
6 TcEnv, ValueEnv, TcTyThing(..),
8 initEnv, getEnvTyCons, getEnvClasses, getEnvAllTyCons,
10 tcExtendUVarEnv, tcLookupUVar,
12 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
16 tcLookupClassByKey, tcLookupClassByKey_maybe,
18 tcExtendGlobalValEnv, tcExtendLocalValEnv,
19 tcGetValueEnv, tcSetValueEnv,
22 tcLookupValue, tcLookupValueMaybe,
23 tcLookupValueByKey, tcLookupValueByKeyMaybe,
24 explicitLookupValueByKey, explicitLookupValue,
27 newLocalId, newSpecPragmaId,
28 tcGetGlobalTyVars, tcExtendGlobalTyVars,
30 InstEnv, emptyInstEnv, addToInstEnv,
31 lookupInstEnv, InstLookupResult(..),
32 tcGetInstEnv, tcSetInstEnv, classInstEnv,
37 #include "HsVersions.h"
39 import HsTypes ( HsTyVarBndr, getTyVarName )
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,
51 import Type ( Kind, Type, superKind,
52 tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
53 splitForAllTys, splitRhoTy, splitFunTys,
54 splitAlgTyConApp_maybe, getTyVar
56 import Subst ( substTy )
57 import UsageSPUtils ( unannotTy )
58 import DataCon ( DataCon )
59 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
60 import Class ( Class, classTyCon )
64 import BasicTypes ( Arity )
65 import IdInfo ( vanillaIdInfo )
66 import Name ( Name, OccName, nameOccName, getSrcLoc,
67 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
69 NameEnv, emptyNameEnv, addToNameEnv,
70 extendNameEnv, lookupNameEnv, nameEnvElts
72 import Unify ( unifyTyListsX, matchTys )
73 import Unique ( pprUnique10, Unique, Uniquable(..) )
74 import FiniteMap ( lookupFM, addToFM )
76 import Unique ( Uniquable(..) )
77 import Util ( zipEqual, zipWith3Equal, mapAccumL )
78 import Bag ( bagToList )
79 import SrcLoc ( SrcLoc )
80 import FastString ( FastString )
85 %************************************************************************
89 %************************************************************************
93 type TcId = Id -- Type may be a TcType
96 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
97 tcLookupDataCon con_name
98 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
99 case isDataConWrapId_maybe con_id of {
100 Nothing -> failWithTc (badCon con_id);
103 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
104 -- Ignore the con_theta; overloaded constructors only
105 -- behave differently when called, not when used for
108 (arg_tys, result_ty) = splitFunTys con_tau
110 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
111 returnTc (data_con, arg_tys, result_ty) }
113 -- A useful function that takes an occurrence of a global thing
114 -- and instantiates its type with fresh type variables
116 -> NF_TcM s ([TcTyVar], -- It's instantiated type
121 (tyvars, rho) = splitForAllTys (unannotTy (idType id))
123 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
125 rho' = substTy tenv rho
126 (theta', tau') = splitRhoTy rho'
128 returnNF_Tc (tyvars', theta', tau')
131 Between the renamer and the first invocation of the UsageSP inference,
132 identifiers read from interface files will have usage information in
133 their types, whereas other identifiers will not. The unannotTy here
134 in @tcInstId@ prevents this information from pointlessly propagating
135 further prior to the first usage inference.
138 %************************************************************************
142 %************************************************************************
144 Data type declarations
145 ~~~~~~~~~~~~~~~~~~~~~
153 (TcTyVarSet, -- The in-scope TyVars
154 TcRef TcTyVarSet) -- Free type variables of the value env
155 -- ...why mutable? see notes with tcGetGlobalTyVars
156 -- Includes the in-scope tyvars
158 type UsageEnv = NameEnv UVar
159 type TypeEnv = NameEnv (TcKind, TcTyThing)
160 type ValueEnv = NameEnv Id
162 valueEnvIds :: ValueEnv -> [Id]
163 valueEnvIds ve = nameEnvElts ve
165 data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
166 -- if the kind is mutable, the tyvar must be so that
169 | ASynTyCon TyCon Arity
173 initEnv :: TcRef TcTyVarSet -> TcEnv
174 initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut)
176 getEnvClasses (TcEnv _ te _ _ _) = [cl | (_, AClass cl _) <- nameEnvElts te]
178 getEnvTyCons (TcEnv _ te _ _ _) = catMaybes (map get_tc (nameEnvElts te))
180 get_tc (_, ADataTyCon tc) = Just tc
181 get_tc (_, ASynTyCon tc _) = Just tc
182 get_tc other = Nothing
184 getEnvAllTyCons te_list = catMaybes (map get_tc te_list)
185 -- The 'all' means 'including the tycons from class decls'
187 get_tc (_, ADataTyCon tc) = Just tc
188 get_tc (_, ASynTyCon tc _) = Just tc
189 get_tc (_, AClass cl _) = Just (classTyCon cl)
190 get_tc other = Nothing
194 %************************************************************************
196 \subsection{The usage environment}
198 %************************************************************************
200 Extending the usage environment
203 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
204 tcExtendUVarEnv uv_name uv scope
205 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
206 tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve ie gtvs) scope
209 Looking up in the environments.
212 tcLookupUVar :: Name -> NF_TcM s UVar
214 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
215 case lookupNameEnv ue uv_name of
216 Just uv -> returnNF_Tc uv
217 Nothing -> failWithTc (uvNameOutOfScope uv_name)
221 %************************************************************************
223 \subsection{The type environment}
225 %************************************************************************
228 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
229 tcExtendTyVarEnv tyvars scope
230 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
232 extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
235 te' = extendNameEnv te extend_list
236 new_tv_set = mkVarSet tyvars
237 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
239 -- It's important to add the in-scope tyvars to the global tyvar set
241 -- f (x::r) = let g y = y::r in ...
242 -- Here, g mustn't be generalised. This is also important during
243 -- class and instance decls, when we mustn't generalise the class tyvars
244 -- when typechecking the methods.
245 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
246 tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope
248 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
249 -- the signature tyvars contain the original names
250 -- the instance tyvars are what those names should be mapped to
251 -- It's needed when typechecking the method bindings of class and instance decls
252 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
254 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
255 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
256 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
258 te' = extendNameEnv te stuff
260 tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside
262 stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv))
263 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
266 tcExtendGlobalTyVars extra_global_tvs scope
267 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) ->
268 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
269 tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope
271 tc_extend_gtvs gtvs extra_global_tvs
272 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
274 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
276 tcNewMutVar new_global_tyvars
279 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
280 To improve subsequent calls to the same function it writes the zonked set back into
284 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
286 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
287 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
288 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
290 global_tvs' = (tyVarsOfTypes global_tys')
292 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
293 returnNF_Tc global_tvs'
295 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
297 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
298 returnNF_Tc (varSetElems in_scope_tvs)
302 Type constructors and classes
305 tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r
306 tcExtendTypeEnv bindings scope
307 = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] )
308 -- Not for tyvars; use tcExtendTyVarEnv
309 tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
311 te' = extendNameEnv te bindings
313 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
317 Looking up in the environments.
320 tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing)
322 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
323 case lookupNameEnv te name of {
324 Just thing -> returnNF_Tc thing ;
327 case maybeWiredInTyConName name of
328 Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc))
329 | otherwise -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc)
331 Nothing -> -- This can happen if an interface-file
332 -- unfolding is screwed up
333 failWithTc (tyNameOutOfScope name)
336 tcLookupClassByKey :: Unique -> NF_TcM s Class
337 tcLookupClassByKey key
338 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
339 case lookupUFM_Directly te key of
340 Just (_, AClass cl _) -> returnNF_Tc cl
341 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
343 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
344 tcLookupClassByKey_maybe key
345 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
346 case lookupUFM_Directly te key of
347 Just (_, AClass cl _) -> returnNF_Tc (Just cl)
348 other -> returnNF_Tc Nothing
350 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
351 tcLookupTyConByKey key
352 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
353 case lookupUFM_Directly te key of
354 Just (_, ADataTyCon tc) -> returnNF_Tc tc
355 Just (_, ASynTyCon tc _) -> returnNF_Tc tc
356 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
362 %************************************************************************
364 \subsection{The value environment}
366 %************************************************************************
369 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
370 tcExtendGlobalValEnv ids scope
371 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
373 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
375 tcSetEnv (TcEnv ue te ve' ie gtvs) scope
377 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
378 tcExtendLocalValEnv names_w_ids scope
379 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) ->
380 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
382 ve' = extendNameEnv ve names_w_ids
383 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
385 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
386 tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope
391 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
393 = case maybeWiredInIdName name of
394 Just id -> returnNF_Tc id
395 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
396 returnNF_Tc (lookupWithDefaultUFM ve def name)
398 def = pprPanic "tcLookupValue:" (ppr name)
400 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
401 tcLookupValueMaybe name
402 = case maybeWiredInIdName name of
403 Just id -> returnNF_Tc (Just id)
404 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
405 returnNF_Tc (lookupNameEnv ve name)
407 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
408 tcLookupValueByKey key
409 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
410 returnNF_Tc (explicitLookupValueByKey ve key)
412 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
413 tcLookupValueByKeyMaybe key
414 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
415 returnNF_Tc (lookupUFM_Directly ve key)
417 tcGetValueEnv :: NF_TcM s ValueEnv
419 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
423 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
424 tcSetValueEnv ve scope
425 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
426 tcSetEnv (TcEnv ue te ve ie gtvs) scope
428 -- Non-monadic version, environment given explicitly
429 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
430 explicitLookupValueByKey ve key
431 = lookupWithDefaultUFM_Directly ve def key
433 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
435 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
436 explicitLookupValue ve name
437 = case maybeWiredInIdName name of
439 Nothing -> lookupNameEnv ve name
441 -- Extract the IdInfo from an IfaceSig imported from an interface file
442 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
443 tcAddImportedIdInfo unf_env id
444 | isLocallyDefined id -- Don't look up locally defined Ids, because they
445 -- have explicit local definitions, so we get a black hole!
448 = id `lazySetIdInfo` new_info
449 -- The Id must be returned without a data dependency on maybe_id
451 new_info = -- pprTrace "tcAdd" (ppr id) $
452 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")