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 newDefaultMethodName, newDFunName,
30 tcGetGlobalTyVars, tcExtendGlobalTyVars,
32 InstEnv, emptyInstEnv, addToInstEnv,
33 lookupInstEnv, InstLookupResult(..),
34 tcGetInstEnv, tcSetInstEnv, classInstEnv,
39 #include "HsVersions.h"
41 import Id ( mkUserLocal, isDataConWrapId_maybe )
42 import MkId ( mkSpecPragmaId )
43 import Var ( TyVar, Id, setVarName,
44 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
46 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
47 tcInstTyVars, zonkTcTyVars,
51 import Type ( Kind, Type, superKind,
52 tyVarsOfType, tyVarsOfTypes,
53 splitForAllTys, splitRhoTy, splitFunTys,
54 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
56 import Subst ( substTy )
57 import UsageSPUtils ( unannotTy )
58 import DataCon ( DataCon )
59 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
60 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
64 import IdInfo ( vanillaIdInfo )
65 import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
66 nameOccName, nameModule, getSrcLoc, mkGlobalName,
67 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
68 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
69 extendNameEnv, extendNameEnvList
71 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
72 import Module ( Module )
73 import Unify ( unifyTyListsX, matchTys )
74 import Unique ( pprUnique10, Unique, Uniquable(..) )
76 import Unique ( Uniquable(..) )
77 import Util ( zipEqual, zipWith3Equal, mapAccumL )
78 import VarEnv ( TyVarSubstEnv )
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 ~~~~~~~~~~~~~~~~~~~~~
150 tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
152 tcGEnv :: NameEnv TyThing -- The global type environment we've accumulated while
153 -- compiling this module:
154 -- types and classes (both imported and local)
156 -- (Ids defined in this module are in the local envt)
157 -- When type checking is over we'll augment the
158 -- global symbol table with everything in tcGEnv
160 tcInst :: InstEnv, -- All instances (both imported and in this module)
162 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
163 -- defined in this module
165 tcTyVars :: FreeTyVars -- Type variables free in tcLST
169 type InScopeTyVars = (TcTyVarSet, -- The in-scope TyVars
170 TcRef TcTyVarSet) -- Free type variables of the value env
171 -- ...why mutable? see notes with tcGetGlobalTyVars
173 valueEnvIds :: ValueEnv -> [Id]
174 valueEnvIds ve = nameEnvElts ve
176 data TcTyThing = ATyVar TyVar
178 | AThing TcKind -- Used temporarily, during kind checking
179 -- For example, when checking (forall a. T a Int):
180 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
181 -- 2. Then we kind-check the (T a Int) part.
182 -- 3. Then we zonk the kind variable.
183 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
185 tyThingKind :: TyThing -> TcKind
186 tyThingKind (ATyVar tv) = tyVarKind tv
187 tyThingKind (ATyCon tc) = tyConKind tc
188 tyThingKind (AClass cl) = tyConKind (classTyCon cl) -- For some odd reason,
189 -- a class doesn't include its kind
190 tyThingKind (AThing k) = k
192 data TyThingDetails = SynTyDetails Type
193 | DataTyDetails ClassContext [DataCon] [Class]
194 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
196 initEnv :: TcRef TcTyVarSet -> TcEnv
197 initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut)
199 getEnvClasses (TcEnv _ te _ _ _) = [cl | AClass cl <- nameEnvElts te]
200 getEnvTyCons (TcEnv _ te _ _ _) = [tc | ATyCon tc <- nameEnvElts te]
203 %************************************************************************
205 \subsection{The usage environment}
207 %************************************************************************
209 Extending the usage environment
212 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
213 tcExtendUVarEnv uv_name uv scope
214 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
215 tcSetEnv (TcEnv (extendNameEnv ue uv_name uv) te ve ie gtvs) scope
218 Looking up in the environments.
221 tcLookupUVar :: Name -> NF_TcM s UVar
223 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
224 case lookupNameEnv ue uv_name of
225 Just uv -> returnNF_Tc uv
226 Nothing -> failWithTc (uvNameOutOfScope uv_name)
230 %************************************************************************
232 \subsection{The type environment}
234 %************************************************************************
237 tcExtendKindEnv :: [(Name,TcKind)] -> TcM s r -> TcM s r
238 tcExtendKindEnv pairs scope
239 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
241 te' = extendNameEnvList te [(n, AThing k) | (n,k) <- pairs]
242 -- No need to extend global tyvars for kind checking
244 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
246 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
247 tcExtendTyVarEnv tyvars scope
248 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
250 te' = extendNameEnvList te [ (getName tv, ATyVar tv) | tv <- tyvars]
251 new_tv_set = mkVarSet tyvars
252 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
254 -- It's important to add the in-scope tyvars to the global tyvar set
256 -- f (x::r) = let g y = y::r in ...
257 -- Here, g mustn't be generalised. This is also important during
258 -- class and instance decls, when we mustn't generalise the class tyvars
259 -- when typechecking the methods.
260 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
261 tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope
263 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
264 -- the signature tyvars contain the original names
265 -- the instance tyvars are what those names should be mapped to
266 -- It's needed when typechecking the method bindings of class and instance decls
267 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
269 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
270 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
271 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
273 te' = extendNameEnvList te stuff
275 tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside
277 stuff = [ (getName sig_tv, ATyVar inst_tv)
278 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
281 tcExtendGlobalTyVars extra_global_tvs scope
282 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) ->
283 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
284 tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope
286 tc_extend_gtvs gtvs extra_global_tvs
287 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
289 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
291 tcNewMutVar new_global_tyvars
294 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
295 To improve subsequent calls to the same function it writes the zonked set back into
299 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
301 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
302 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
303 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
305 global_tvs' = (tyVarsOfTypes global_tys')
307 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
308 returnNF_Tc global_tvs'
310 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
312 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
313 returnNF_Tc (varSetElems in_scope_tvs)
317 Type constructors and classes
320 tcExtendTypeEnv :: [(Name, TyThing)] -> TcM s r -> TcM s r
321 tcExtendTypeEnv bindings scope
322 = ASSERT( null [tv | (_, ATyVar tv) <- bindings] )
323 -- Not for tyvars; use tcExtendTyVarEnv
324 tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
326 te' = extendNameEnvList te bindings
328 tcSetEnv (TcEnv ue te' ve ie gtvs) scope
332 Looking up in the environments.
335 tcLookupTy :: Name -> NF_TcM s TyThing
337 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
338 case lookupNameEnv te name of {
339 Just thing -> returnNF_Tc thing ;
342 case maybeWiredInTyConName name of
343 Just tc -> returnNF_Tc (ATyCon tc)
345 Nothing -> -- This can happen if an interface-file
346 -- unfolding is screwed up
347 failWithTc (tyNameOutOfScope name)
350 tcLookupClassByKey :: Unique -> NF_TcM s Class
351 tcLookupClassByKey key
352 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
353 case lookupUFM_Directly te key of
354 Just (AClass cl) -> returnNF_Tc cl
355 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
357 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
358 tcLookupClassByKey_maybe key
359 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
360 case lookupUFM_Directly te key of
361 Just (AClass cl) -> returnNF_Tc (Just cl)
362 other -> returnNF_Tc Nothing
364 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
365 tcLookupTyConByKey key
366 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
367 case lookupUFM_Directly te key of
368 Just (ATyCon tc) -> returnNF_Tc tc
369 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
375 %************************************************************************
377 \subsection{The value environment}
379 %************************************************************************
382 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
383 tcExtendGlobalValEnv ids scope
384 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
386 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
388 tcSetEnv (TcEnv ue te ve' ie gtvs) scope
390 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
391 tcExtendLocalValEnv names_w_ids scope
392 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) ->
393 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
395 ve' = extendNameEnvList ve names_w_ids
396 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
398 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
399 tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope
404 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
406 = case maybeWiredInIdName name of
407 Just id -> returnNF_Tc id
408 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
409 returnNF_Tc (lookupWithDefaultUFM ve def name)
411 wired_in = case maybeWiredInIdName name of
414 def = pprPanic "tcLookupValue:" (ppr name <+> ppr wired_in)
416 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
417 tcLookupValueMaybe name
418 = case maybeWiredInIdName name of
419 Just id -> returnNF_Tc (Just id)
420 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
421 returnNF_Tc (lookupNameEnv ve name)
423 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
424 tcLookupValueByKey key
425 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
426 returnNF_Tc (explicitLookupValueByKey ve key)
428 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
429 tcLookupValueByKeyMaybe key
430 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
431 returnNF_Tc (lookupUFM_Directly ve key)
433 tcGetValueEnv :: NF_TcM s ValueEnv
435 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
439 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
440 tcSetValueEnv ve scope
441 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
442 tcSetEnv (TcEnv ue te ve ie gtvs) scope
444 -- Non-monadic version, environment given explicitly
445 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
446 explicitLookupValueByKey ve key
447 = lookupWithDefaultUFM_Directly ve def key
449 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
451 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
452 explicitLookupValue ve name
453 = case maybeWiredInIdName name of
455 Nothing -> lookupNameEnv ve name
457 -- Extract the IdInfo from an IfaceSig imported from an interface file
458 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
459 tcAddImportedIdInfo unf_env id
460 | isLocallyDefined id -- Don't look up locally defined Ids, because they
461 -- have explicit local definitions, so we get a black hole!
464 = id `lazySetIdInfo` new_info
465 -- The Id must be returned without a data dependency on maybe_id
467 new_info = case explicitLookupValue unf_env (getName id) of
468 Nothing -> vanillaIdInfo
469 Just imported_id -> idInfo imported_id
470 -- ToDo: could check that types are the same
476 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
477 newLocalId name ty loc
478 = tcGetUnique `thenNF_Tc` \ uniq ->
479 returnNF_Tc (mkUserLocal name uniq ty loc)
481 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
482 newSpecPragmaId name ty
483 = tcGetUnique `thenNF_Tc` \ uniq ->
484 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
488 %************************************************************************
490 \subsection{The instance environment}
492 %************************************************************************
495 tcGetInstEnv :: NF_TcM s InstEnv
496 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
499 tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a
500 tcSetInstEnv ie scope
501 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
502 tcSetEnv (TcEnv ue te ve ie gtvs) scope
507 type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
508 type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
510 classInstEnv :: InstEnv -> Class -> ClsInstEnv
511 classInstEnv env cls = lookupWithDefaultUFM env [] cls
514 A @ClsInstEnv@ lives inside a class, and identifies all the instances
515 of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
518 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
520 forall a b, C t1 t2 t3 can be constructed by dfun
522 or, to put it another way, we have
524 instance (...) => C t1 t2 t3, witnessed by dfun
526 There is an important consistency constraint in the elements of a ClsInstEnv:
528 * [a,b] must be a superset of the free vars of [t1,t2,t3]
530 * The dfun must itself be quantified over [a,b]
532 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
533 [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
534 The "a" in the pattern must be one of the forall'd variables in
539 Notes on overlapping instances
540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
541 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
543 In others, overlap is permitted, but only in such a way that one can make
544 a unique choice when looking up. That is, overlap is only permitted if
545 one template matches the other, or vice versa. So this is ok:
553 If overlap is permitted, the list is kept most specific first, so that
554 the first lookup is the right choice.
557 For now we just use association lists.
559 \subsection{Avoiding a problem with overlapping}
561 Consider this little program:
564 class C a where c :: a
565 class C a => D a where d :: a
567 instance C Int where c = 17
568 instance D Int where d = 13
570 instance C a => C [a] where c = [c]
571 instance ({- C [a], -} D a) => D [a] where d = c
573 instance C [Int] where c = [37]
575 main = print (d :: [Int])
578 What do you think `main' prints (assuming we have overlapping instances, and
579 all that turned on)? Well, the instance for `D' at type `[a]' is defined to
580 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
581 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
582 the `C [Int]' instance is more specific).
584 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
585 was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
586 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
587 doesn't even compile! What's going on!?
589 What hugs complains about is the `D [a]' instance decl.
592 ERROR "mj.hs" (line 10): Cannot build superclass instance
594 *** Context supplied : D a
595 *** Required superclass : C [a]
598 You might wonder what hugs is complaining about. It's saying that you
599 need to add `C [a]' to the context of the `D [a]' instance (as appears
600 in comments). But there's that `C [a]' instance decl one line above
601 that says that I can reduce the need for a `C [a]' instance to the
602 need for a `C a' instance, and in this case, I already have the
603 necessary `C a' instance (since we have `D a' explicitly in the
604 context, and `C' is a superclass of `D').
606 Unfortunately, the above reasoning indicates a premature commitment to the
607 generic `C [a]' instance. I.e., it prematurely rules out the more specific
608 instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
609 add the context that hugs suggests (uncomment the `C [a]'), effectively
610 deferring the decision about which instance to use.
612 Now, interestingly enough, 4.04 has this same bug, but it's covered up
613 in this case by a little known `optimization' that was disabled in
614 4.06. Ghc-4.04 silently inserts any missing superclass context into
615 an instance declaration. In this case, it silently inserts the `C
616 [a]', and everything happens to work out.
618 (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
619 `Mark Jones', although Mark claims no credit for the `optimization' in
620 question, and would rather it stopped being called the `Mark Jones
623 So, what's the fix? I think hugs has it right. Here's why. Let's try
624 something else out with ghc-4.04. Let's add the following line:
629 Everyone raise their hand who thinks that `d :: [Int]' should give a
630 different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
631 `optimization' only applies to instance decls, not to regular
632 bindings, giving inconsistent behavior.
634 Old hugs had this same bug. Here's how we fixed it: like GHC, the
635 list of instances for a given class is ordered, so that more specific
636 instances come before more generic ones. For example, the instance
637 list for C might contain:
638 ..., C Int, ..., C a, ...
639 When we go to look for a `C Int' instance we'll get that one first.
640 But what if we go looking for a `C b' (`b' is unconstrained)? We'll
641 pass the `C Int' instance, and keep going. But if `b' is
642 unconstrained, then we don't know yet if the more specific instance
643 will eventually apply. GHC keeps going, and matches on the generic `C
644 a'. The fix is to, at each step, check to see if there's a reverse
645 match, and if so, abort the search. This prevents hugs from
646 prematurely chosing a generic instance when a more specific one
652 emptyInstEnv :: InstEnv
653 emptyInstEnv = emptyUFM
656 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
657 the env is kept ordered, the first match must be the only one. The
658 thing we are looking up can have an arbitrary "flexi" part.
661 lookupInstEnv :: InstEnv -- The envt
662 -> Class -> [Type] -- Key
665 data InstLookupResult
666 = FoundInst -- There is a (template,substitution) pair
667 -- that makes the template match the key,
668 -- and no template is an instance of the key
671 | NoMatch Bool -- Boolean is true iff there is at least one
672 -- template that matches the key.
673 -- (but there are other template(s) that are
674 -- instances of the key, so we don't report
676 -- The NoMatch True case happens when we look up
678 -- in an InstEnv that has entries for
681 -- Then which we choose would depend on the way in which 'a'
682 -- is instantiated. So we say there is no match, but identify
683 -- it as ambiguous case in the hope of giving a better error msg.
684 -- See the notes above from Jeff Lewis
686 lookupInstEnv env key_cls key_tys
687 = find (classInstEnv env key_cls)
689 key_vars = tyVarsOfTypes key_tys
691 find [] = NoMatch False
692 find ((tpl_tyvars, tpl, val) : rest)
693 = case matchTys tpl_tyvars tpl key_tys of
695 case matchTys key_vars key_tys tpl of
697 Just (_, _) -> NoMatch (any_match rest)
698 Just (subst, leftovers) -> ASSERT( null leftovers )
701 any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
702 | (tvs,tpl,_) <- rest
706 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
708 A boolean flag controls overlap reporting.
710 True => overlap is permitted, but only if one template matches the other;
711 not if they unify but neither is
714 addToInstEnv :: Bool -- True <=> overlap permitted
716 -> Class -> [TyVar] -> [Type] -> Id -- New item
717 -> MaybeErr InstEnv -- Success...
718 ([Type], Id) -- Failure: Offending overlap
720 addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
721 = case insert_into (classInstEnv inst_env clas) of
722 Failed stuff -> Failed stuff
723 Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
726 ins_tv_set = mkVarSet ins_tvs
727 ins_item = (ins_tv_set, ins_tys, value)
729 insert_into [] = returnMaB [ins_item]
730 insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
733 -- (a) they are the same, or
734 -- (b) they unify, and any sort of overlap is prohibited,
735 -- (c) they unify but neither is more specific than t'other
737 || (unifiable && not overlap_ok)
738 || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
739 = failMaB (tpl_tys, val)
741 -- New item is an instance of current item, so drop it here
742 | ins_item_more_specific = returnMaB (ins_item : env)
744 -- Otherwise carry on
745 | otherwise = insert_into rest `thenMaB` \ rest' ->
746 returnMaB (cur_item : rest')
748 unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
749 ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
750 cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
751 identical = ins_item_more_specific && cur_item_more_specific
754 Make a name for the dict fun for an instance decl
757 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM s Name
758 newDFunName mod clas (ty:_) loc
759 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
760 tcGetUnique `thenNF_Tc` \ uniq ->
761 returnNF_Tc (mkGlobalName uniq mod
762 (mkDFunOcc dfun_string inst_uniq)
763 (LocalDef loc Exported))
765 -- Any string that is somewhat unique will do
766 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
768 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM s Name
769 newDefaultMethodName op_name loc
770 = tcGetUnique `thenNF_Tc` \ uniq ->
771 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
772 (mkDefaultMethodOcc (getOccName op_name))
773 (LocalDef loc Exported))
777 %************************************************************************
781 %************************************************************************
785 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
787 = quotes (ppr op) <+> ptext SLIT("is not a primop")
789 uvNameOutOfScope name
790 = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
792 tyNameOutOfScope name
793 = quotes (ppr name) <+> ptext SLIT("is not in scope")