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 Id ( mkUserLocal, isDataConWrapId_maybe )
40 import MkId ( mkSpecPragmaId )
41 import Var ( TyVar, Id, setVarName,
42 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
44 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
45 tcInstTyVars, zonkTcTyVars,
49 import Type ( Kind, Type, superKind,
50 tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
51 splitForAllTys, splitRhoTy, splitFunTys,
52 splitAlgTyConApp_maybe, getTyVar
54 import Subst ( substTy )
55 import UsageSPUtils ( unannotTy )
56 import DataCon ( DataCon )
57 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
58 import Class ( Class, classTyCon )
62 import BasicTypes ( Arity )
63 import IdInfo ( vanillaIdInfo )
64 import Name ( Name, OccName, nameOccName, getSrcLoc,
65 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
67 NameEnv, emptyNameEnv, addToNameEnv,
68 extendNameEnv, lookupNameEnv, nameEnvElts
70 import Unify ( unifyTyListsX, matchTys )
71 import Unique ( pprUnique10, Unique, Uniquable(..) )
73 import Unique ( Uniquable(..) )
74 import Util ( zipEqual, zipWith3Equal, mapAccumL )
75 import SrcLoc ( SrcLoc )
76 import FastString ( FastString )
81 %************************************************************************
85 %************************************************************************
89 type TcId = Id -- Type may be a TcType
92 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
93 tcLookupDataCon con_name
94 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
95 case isDataConWrapId_maybe con_id of {
96 Nothing -> failWithTc (badCon con_id);
99 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
100 -- Ignore the con_theta; overloaded constructors only
101 -- behave differently when called, not when used for
104 (arg_tys, result_ty) = splitFunTys con_tau
106 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
107 returnTc (data_con, arg_tys, result_ty) }
109 -- A useful function that takes an occurrence of a global thing
110 -- and instantiates its type with fresh type variables
112 -> NF_TcM s ([TcTyVar], -- It's instantiated type
117 (tyvars, rho) = splitForAllTys (unannotTy (idType id))
119 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
121 rho' = substTy tenv rho
122 (theta', tau') = splitRhoTy rho'
124 returnNF_Tc (tyvars', theta', tau')
127 Between the renamer and the first invocation of the UsageSP inference,
128 identifiers read from interface files will have usage information in
129 their types, whereas other identifiers will not. The unannotTy here
130 in @tcInstId@ prevents this information from pointlessly propagating
131 further prior to the first usage inference.
134 %************************************************************************
138 %************************************************************************
140 Data type declarations
141 ~~~~~~~~~~~~~~~~~~~~~
149 (TcTyVarSet, -- The in-scope TyVars
150 TcRef TcTyVarSet) -- Free type variables of the value env
151 -- ...why mutable? see notes with tcGetGlobalTyVars
152 -- Includes the in-scope tyvars
154 type UsageEnv = NameEnv UVar
155 type TypeEnv = NameEnv (TcKind, TcTyThing)
156 type ValueEnv = NameEnv Id
158 valueEnvIds :: ValueEnv -> [Id]
159 valueEnvIds ve = nameEnvElts ve
161 data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
162 -- if the kind is mutable, the tyvar must be so that
165 | ASynTyCon TyCon Arity
169 initEnv :: TcRef TcTyVarSet -> TcEnv
170 initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut)
172 getEnvClasses (TcEnv _ te _ _ _) = [cl | (_, AClass cl _) <- nameEnvElts te]
174 getEnvTyCons (TcEnv _ te _ _ _) = catMaybes (map get_tc (nameEnvElts te))
176 get_tc (_, ADataTyCon tc) = Just tc
177 get_tc (_, ASynTyCon tc _) = Just tc
178 get_tc other = Nothing
180 getEnvAllTyCons te_list = catMaybes (map get_tc te_list)
181 -- The 'all' means 'including the tycons from class decls'
183 get_tc (_, ADataTyCon tc) = Just tc
184 get_tc (_, ASynTyCon tc _) = Just tc
185 get_tc (_, AClass cl _) = Just (classTyCon cl)
186 get_tc other = Nothing
190 %************************************************************************
192 \subsection{The usage environment}
194 %************************************************************************
196 Extending the usage environment
199 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
200 tcExtendUVarEnv uv_name uv scope
201 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
202 tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve ie gtvs) scope
205 Looking up in the environments.
208 tcLookupUVar :: Name -> NF_TcM s UVar
210 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
211 case lookupNameEnv ue uv_name of
212 Just uv -> returnNF_Tc uv
213 Nothing -> failWithTc (uvNameOutOfScope uv_name)
217 %************************************************************************
219 \subsection{The type environment}
221 %************************************************************************
224 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
225 tcExtendTyVarEnv tyvars scope
226 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
228 extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
231 te' = extendNameEnv te extend_list
232 new_tv_set = mkVarSet tyvars
233 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
235 -- It's important to add the in-scope tyvars to the global tyvar set
237 -- f (x::r) = let g y = y::r in ...
238 -- Here, g mustn't be generalised. This is also important during
239 -- class and instance decls, when we mustn't generalise the class tyvars
240 -- when typechecking the methods.
241 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
242 tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope
244 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
245 -- the signature tyvars contain the original names
246 -- the instance tyvars are what those names should be mapped to
247 -- It's needed when typechecking the method bindings of class and instance decls
248 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
250 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
251 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
252 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
254 te' = extendNameEnv te stuff
256 tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside
258 stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv))
259 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
262 tcExtendGlobalTyVars extra_global_tvs scope
263 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) ->
264 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
265 tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope
267 tc_extend_gtvs gtvs extra_global_tvs
268 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
270 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
272 tcNewMutVar new_global_tyvars
275 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
276 To improve subsequent calls to the same function it writes the zonked set back into
280 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
282 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
283 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
284 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
286 global_tvs' = (tyVarsOfTypes global_tys')
288 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
289 returnNF_Tc global_tvs'
291 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
293 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
294 returnNF_Tc (varSetElems in_scope_tvs)
298 Type constructors and classes
301 tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r
302 tcExtendTypeEnv bindings scope
303 = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] )
304 -- Not for tyvars; use tcExtendTyVarEnv
305 tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
307 te' = extendNameEnv te bindings
309 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
313 Looking up in the environments.
316 tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing)
318 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
319 case lookupNameEnv te name of {
320 Just thing -> returnNF_Tc thing ;
323 case maybeWiredInTyConName name of
324 Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc))
325 | otherwise -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc)
327 Nothing -> -- This can happen if an interface-file
328 -- unfolding is screwed up
329 failWithTc (tyNameOutOfScope name)
332 tcLookupClassByKey :: Unique -> NF_TcM s Class
333 tcLookupClassByKey key
334 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
335 case lookupUFM_Directly te key of
336 Just (_, AClass cl _) -> returnNF_Tc cl
337 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
339 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
340 tcLookupClassByKey_maybe key
341 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
342 case lookupUFM_Directly te key of
343 Just (_, AClass cl _) -> returnNF_Tc (Just cl)
344 other -> returnNF_Tc Nothing
346 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
347 tcLookupTyConByKey key
348 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
349 case lookupUFM_Directly te key of
350 Just (_, ADataTyCon tc) -> returnNF_Tc tc
351 Just (_, ASynTyCon tc _) -> returnNF_Tc tc
352 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
358 %************************************************************************
360 \subsection{The value environment}
362 %************************************************************************
365 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
366 tcExtendGlobalValEnv ids scope
367 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
369 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
371 tcSetEnv (TcEnv ue te ve' ie gtvs) scope
373 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
374 tcExtendLocalValEnv names_w_ids scope
375 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) ->
376 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
378 ve' = extendNameEnv ve names_w_ids
379 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
381 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
382 tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope
387 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
389 = case maybeWiredInIdName name of
390 Just id -> returnNF_Tc id
391 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
392 returnNF_Tc (lookupWithDefaultUFM ve def name)
394 def = pprPanic "tcLookupValue:" (ppr name)
396 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
397 tcLookupValueMaybe name
398 = case maybeWiredInIdName name of
399 Just id -> returnNF_Tc (Just id)
400 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
401 returnNF_Tc (lookupNameEnv ve name)
403 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
404 tcLookupValueByKey key
405 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
406 returnNF_Tc (explicitLookupValueByKey ve key)
408 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
409 tcLookupValueByKeyMaybe key
410 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
411 returnNF_Tc (lookupUFM_Directly ve key)
413 tcGetValueEnv :: NF_TcM s ValueEnv
415 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
419 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
420 tcSetValueEnv ve scope
421 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
422 tcSetEnv (TcEnv ue te ve ie gtvs) scope
424 -- Non-monadic version, environment given explicitly
425 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
426 explicitLookupValueByKey ve key
427 = lookupWithDefaultUFM_Directly ve def key
429 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
431 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
432 explicitLookupValue ve name
433 = case maybeWiredInIdName name of
435 Nothing -> lookupNameEnv ve name
437 -- Extract the IdInfo from an IfaceSig imported from an interface file
438 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
439 tcAddImportedIdInfo unf_env id
440 | isLocallyDefined id -- Don't look up locally defined Ids, because they
441 -- have explicit local definitions, so we get a black hole!
444 = id `lazySetIdInfo` new_info
445 -- The Id must be returned without a data dependency on maybe_id
447 new_info = -- pprTrace "tcAdd" (ppr id) $
448 case explicitLookupValue unf_env (getName id) of
449 Nothing -> vanillaIdInfo
450 Just imported_id -> idInfo imported_id
451 -- ToDo: could check that types are the same
457 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
458 newLocalId name ty loc
459 = tcGetUnique `thenNF_Tc` \ uniq ->
460 returnNF_Tc (mkUserLocal name uniq ty loc)
462 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
463 newSpecPragmaId name ty
464 = tcGetUnique `thenNF_Tc` \ uniq ->
465 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
469 %************************************************************************
471 \subsection{The instance environment}
473 %************************************************************************
476 tcGetInstEnv :: NF_TcM s InstEnv
477 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
480 tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a
481 tcSetInstEnv ie scope
482 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
483 tcSetEnv (TcEnv ue te ve ie gtvs) scope
488 type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
489 type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
491 classInstEnv :: InstEnv -> Class -> ClsInstEnv
492 classInstEnv env cls = lookupWithDefaultUFM env [] cls
495 A @ClsInstEnv@ lives inside a class, and identifies all the instances
496 of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
499 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
501 forall a b, C t1 t2 t3 can be constructed by dfun
503 or, to put it another way, we have
505 instance (...) => C t1 t2 t3, witnessed by dfun
507 There is an important consistency constraint in the elements of a ClsInstEnv:
509 * [a,b] must be a superset of the free vars of [t1,t2,t3]
511 * The dfun must itself be quantified over [a,b]
513 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
514 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
515 The "a" in the pattern must be one of the forall'd variables in
520 Notes on overlapping instances
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
524 In others, overlap is permitted, but only in such a way that one can make
525 a unique choice when looking up. That is, overlap is only permitted if
526 one template matches the other, or vice versa. So this is ok:
534 If overlap is permitted, the list is kept most specific first, so that
535 the first lookup is the right choice.
538 For now we just use association lists.
540 \subsection{Avoiding a problem with overlapping}
542 Consider this little program:
545 class C a where c :: a
546 class C a => D a where d :: a
548 instance C Int where c = 17
549 instance D Int where d = 13
551 instance C a => C [a] where c = [c]
552 instance ({- C [a], -} D a) => D [a] where d = c
554 instance C [Int] where c = [37]
556 main = print (d :: [Int])
559 What do you think `main' prints (assuming we have overlapping instances, and
560 all that turned on)? Well, the instance for `D' at type `[a]' is defined to
561 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
562 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
563 the `C [Int]' instance is more specific).
565 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
566 was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
567 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
568 doesn't even compile! What's going on!?
570 What hugs complains about is the `D [a]' instance decl.
573 ERROR "mj.hs" (line 10): Cannot build superclass instance
575 *** Context supplied : D a
576 *** Required superclass : C [a]
579 You might wonder what hugs is complaining about. It's saying that you
580 need to add `C [a]' to the context of the `D [a]' instance (as appears
581 in comments). But there's that `C [a]' instance decl one line above
582 that says that I can reduce the need for a `C [a]' instance to the
583 need for a `C a' instance, and in this case, I already have the
584 necessary `C a' instance (since we have `D a' explicitly in the
585 context, and `C' is a superclass of `D').
587 Unfortunately, the above reasoning indicates a premature commitment to the
588 generic `C [a]' instance. I.e., it prematurely rules out the more specific
589 instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
590 add the context that hugs suggests (uncomment the `C [a]'), effectively
591 deferring the decision about which instance to use.
593 Now, interestingly enough, 4.04 has this same bug, but it's covered up
594 in this case by a little known `optimization' that was disabled in
595 4.06. Ghc-4.04 silently inserts any missing superclass context into
596 an instance declaration. In this case, it silently inserts the `C
597 [a]', and everything happens to work out.
599 (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
600 `Mark Jones', although Mark claims no credit for the `optimization' in
601 question, and would rather it stopped being called the `Mark Jones
604 So, what's the fix? I think hugs has it right. Here's why. Let's try
605 something else out with ghc-4.04. Let's add the following line:
610 Everyone raise their hand who thinks that `d :: [Int]' should give a
611 different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
612 `optimization' only applies to instance decls, not to regular
613 bindings, giving inconsistent behavior.
615 Old hugs had this same bug. Here's how we fixed it: like GHC, the
616 list of instances for a given class is ordered, so that more specific
617 instances come before more generic ones. For example, the instance
618 list for C might contain:
619 ..., C Int, ..., C a, ...
620 When we go to look for a `C Int' instance we'll get that one first.
621 But what if we go looking for a `C b' (`b' is unconstrained)? We'll
622 pass the `C Int' instance, and keep going. But if `b' is
623 unconstrained, then we don't know yet if the more specific instance
624 will eventually apply. GHC keeps going, and matches on the generic `C
625 a'. The fix is to, at each step, check to see if there's a reverse
626 match, and if so, abort the search. This prevents hugs from
627 prematurely chosing a generic instance when a more specific one
633 emptyInstEnv :: InstEnv
634 emptyInstEnv = emptyUFM
637 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
638 the env is kept ordered, the first match must be the only one. The
639 thing we are looking up can have an arbitrary "flexi" part.
642 lookupInstEnv :: InstEnv -- The envt
643 -> Class -> [Type] -- Key
646 data InstLookupResult
647 = FoundInst -- There is a (template,substitution) pair
648 -- that makes the template match the key,
649 -- and no template is an instance of the key
652 | NoMatch Bool -- Boolean is true iff there is at least one
653 -- template that matches the key.
654 -- (but there are other template(s) that are
655 -- instances of the key, so we don't report
657 -- The NoMatch True case happens when we look up
659 -- in an InstEnv that has entries for
662 -- Then which we choose would depend on the way in which 'a'
663 -- is instantiated. So we say there is no match, but identify
664 -- it as ambiguous case in the hope of giving a better error msg.
665 -- See the notes above from Jeff Lewis
667 lookupInstEnv env key_cls key_tys
668 = find (classInstEnv env key_cls)
670 key_vars = tyVarsOfTypes key_tys
672 find [] = NoMatch False
673 find ((tpl_tyvars, tpl, val) : rest)
674 = case matchTys tpl_tyvars tpl key_tys of
676 case matchTys key_vars key_tys tpl of
678 Just (_, _) -> NoMatch (any_match rest)
679 Just (subst, leftovers) -> ASSERT( null leftovers )
682 any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
683 | (tvs,tpl,_) <- rest
687 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
689 A boolean flag controls overlap reporting.
691 True => overlap is permitted, but only if one template matches the other;
692 not if they unify but neither is
695 addToInstEnv :: Bool -- True <=> overlap permitted
697 -> Class -> [TyVar] -> [Type] -> Id -- New item
698 -> MaybeErr InstEnv -- Success...
699 ([Type], Id) -- Failure: Offending overlap
701 addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
702 = case insert_into (classInstEnv inst_env clas) of
703 Failed stuff -> Failed stuff
704 Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
707 ins_tv_set = mkVarSet ins_tvs
708 ins_item = (ins_tv_set, ins_tys, value)
710 insert_into [] = returnMaB [ins_item]
711 insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
714 -- (a) they are the same, or
715 -- (b) they unify, and any sort of overlap is prohibited,
716 -- (c) they unify but neither is more specific than t'other
718 || (unifiable && not overlap_ok)
719 || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
720 = failMaB (tpl_tys, val)
722 -- New item is an instance of current item, so drop it here
723 | ins_item_more_specific = returnMaB (ins_item : env)
725 -- Otherwise carry on
726 | otherwise = insert_into rest `thenMaB` \ rest' ->
727 returnMaB (cur_item : rest')
729 unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
730 ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
731 cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
732 identical = ins_item_more_specific && cur_item_more_specific
737 %************************************************************************
741 %************************************************************************
745 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
747 = quotes (ppr op) <+> ptext SLIT("is not a primop")
749 uvNameOutOfScope name
750 = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
752 tyNameOutOfScope name
753 = quotes (ppr name) <+> ptext SLIT("is not in scope")