Updated documentation; changed "group" to "branched" in type families
[ghc.git] / compiler / types / InstEnv.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[InstEnv]{Utilities for typechecking instance declarations}
6
7 The bits common to TcInstDcls and TcDeriv.
8
9 \begin{code}
10 module InstEnv (
11         DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult,
12         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, 
13         instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
14         instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
15
16         InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, 
17         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
18         classInstances, orphNamesOfClsInst, instanceBindFun,
19         instanceCantMatch, roughMatchTcs
20     ) where
21
22 #include "HsVersions.h"
23
24 import Class
25 import Var
26 import VarSet
27 import Name
28 import NameSet
29 import TcType
30 import TyCon
31 import Unify
32 import Outputable
33 import ErrUtils
34 import BasicTypes
35 import UniqFM
36 import Util
37 import Id
38 import FastString
39 import Data.Data        ( Data, Typeable )
40 import Data.Maybe       ( isJust, isNothing )
41 \end{code}
42
43
44 %************************************************************************
45 %*                                                                      *
46 \subsection{The key types}
47 %*                                                                      *
48 %************************************************************************
49
50 \begin{code}
51 data ClsInst 
52   = ClsInst {   -- Used for "rough matching"; see Note [Rough-match field]
53                 -- INVARIANT: is_tcs = roughMatchTcs is_tys
54                is_cls_nm :: Name  -- Class name
55              , is_tcs  :: [Maybe Name]  -- Top of type args
56
57                 -- Used for "proper matching"; see Note [Proper-match fields]
58              , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match
59                                         -- See Note [Template tyvars are fresh]
60              , is_cls  :: Class         -- The real class
61              , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)
62                 -- INVARIANT: is_dfun Id has type 
63                 --      forall is_tvs. (...) => is_cls is_tys
64                 -- (modulo alpha conversion)
65
66              , is_dfun :: DFunId -- See Note [Haddock assumptions]
67                     -- See Note [Silent superclass arguments] in TcInstDcls
68                     -- for how to map the DFun's type back to the source
69                     -- language instance decl
70
71              , is_flag :: OverlapFlag   -- See detailed comments with
72                                         -- the decl of BasicTypes.OverlapFlag
73     }
74   deriving (Data, Typeable)
75 \end{code}
76
77 Note [Template tyvars are fresh]
78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 The is_tvs field of a ClsInst has *completely fresh* tyvars.  
80 That is, they are
81   * distinct from any other ClsInst
82   * distinct from any tyvars free in predicates that may
83     be looked up in the class instance environment
84 Reason for freshness: we use unification when checking for overlap
85 etc, and that requires the tyvars to be distinct.
86
87 The invariant is checked by the ASSERT in lookupInstEnv'.
88
89 Note [Rough-match field]
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
91 The is_cls_nm, is_tcs fields allow a "rough match" to be done
92 *without* poking inside the DFunId.  Poking the DFunId forces
93 us to suck in all the type constructors etc it involves,
94 which is a total waste of time if it has no chance of matching
95 So the Name, [Maybe Name] fields allow us to say "definitely
96 does not match", based only on the Name.
97
98 In is_tcs, 
99     Nothing  means that this type arg is a type variable
100
101     (Just n) means that this type arg is a
102                 TyConApp with a type constructor of n.
103                 This is always a real tycon, never a synonym!
104                 (Two different synonyms might match, but two
105                 different real tycons can't.)
106                 NB: newtypes are not transparent, though!
107
108 Note [Proper-match fields]
109 ~~~~~~~~~~~~~~~~~~~~~~~~~
110 The is_tvs, is_cls, is_tys fields are simply cached values, pulled
111 out (lazily) from the dfun id. They are cached here simply so 
112 that we don't need to decompose the DFunId each time we want 
113 to match it.  The hope is that the fast-match fields mean
114 that we often never poke the proper-match fields.
115
116 However, note that:
117  * is_tvs must be a superset of the free vars of is_tys
118
119  * is_tvs, is_tys may be alpha-renamed compared to the ones in
120    the dfun Id
121
122 Note [Haddock assumptions]
123 ~~~~~~~~~~~~~~~~~~~~~~~~~~
124 For normal user-written instances, Haddock relies on
125
126  * the SrcSpan of
127  * the Name of
128  * the is_dfun of
129  * an Instance
130
131 being equal to
132
133   * the SrcSpan of
134   * the instance head type of
135   * the InstDecl used to construct the Instance.
136
137 \begin{code}
138 instanceDFunId :: ClsInst -> DFunId
139 instanceDFunId = is_dfun
140
141 tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
142 tidyClsInstDFun tidy_dfun ispec
143   = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
144
145 instanceRoughTcs :: ClsInst -> [Maybe Name]
146 instanceRoughTcs = is_tcs
147 \end{code}
148
149 \begin{code}
150 instance NamedThing ClsInst where
151    getName ispec = getName (is_dfun ispec)
152
153 instance Outputable ClsInst where
154    ppr = pprInstance
155
156 pprInstance :: ClsInst -> SDoc
157 -- Prints the ClsInst as an instance declaration
158 pprInstance ispec
159   = hang (pprInstanceHdr ispec)
160         2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec))
161
162 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
163 pprInstanceHdr :: ClsInst -> SDoc
164 -- Prints the ClsInst as an instance declaration
165 pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
166   = getPprStyle $ \ sty ->
167     let theta_to_print
168           | debugStyle sty = theta
169           | otherwise = drop (dfunNSilent dfun) theta
170           -- See Note [Silent superclass arguments] in TcInstDcls
171     in ptext (sLit "instance") <+> ppr flag
172        <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
173   where
174     (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
175        -- Print without the for-all, which the programmer doesn't write
176
177 pprInstances :: [ClsInst] -> SDoc
178 pprInstances ispecs = vcat (map pprInstance ispecs)
179
180 instanceHead :: ClsInst -> ([TyVar], Class, [Type])
181 -- Returns the head, using the fresh tyavs from the ClsInst
182 instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })
183    = (tvs, cls, tys)
184    where
185      (_, _, cls, _) = tcSplitDFunTy (idType dfun)
186
187 instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])
188 -- Decomposes the DFunId
189 instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
190
191 mkLocalInstance :: DFunId -> OverlapFlag
192                 -> [TyVar] -> Class -> [Type]
193                 -> ClsInst
194 -- Used for local instances, where we can safely pull on the DFunId
195 mkLocalInstance dfun oflag tvs cls tys
196   = ClsInst { is_flag = oflag, is_dfun = dfun
197             , is_tvs = tvs
198             , is_cls = cls, is_cls_nm = className cls
199             , is_tys = tys, is_tcs = roughMatchTcs tys }
200
201 mkImportedInstance :: Name -> [Maybe Name]
202                    -> DFunId -> OverlapFlag -> ClsInst
203 -- Used for imported instances, where we get the rough-match stuff
204 -- from the interface file
205 -- The bound tyvars of the dfun are guaranteed fresh, because
206 -- the dfun has been typechecked out of the same interface file
207 mkImportedInstance cls_nm mb_tcs dfun oflag
208   = ClsInst { is_flag = oflag, is_dfun = dfun
209             , is_tvs = tvs, is_tys = tys
210             , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs }
211   where
212     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
213
214 roughMatchTcs :: [Type] -> [Maybe Name]
215 roughMatchTcs tys = map rough tys
216   where
217     rough ty = case tcSplitTyConApp_maybe ty of
218                   Just (tc,_) -> Just (tyConName tc)
219                   Nothing     -> Nothing
220
221 instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
222 -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
223 -- possibly be instantiated to actual, nor vice versa; 
224 -- False is non-committal
225 instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
226 instanceCantMatch _             _             =  False  -- Safe
227 \end{code}
228
229
230 Note [Overlapping instances]
231 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232 Overlap is permitted, but only in such a way that one can make
233 a unique choice when looking up.  That is, overlap is only permitted if
234 one template matches the other, or vice versa.  So this is ok:
235
236   [a]  [Int]
237
238 but this is not
239
240   (Int,a)  (b,Int)
241
242 If overlap is permitted, the list is kept most specific first, so that
243 the first lookup is the right choice.
244
245
246 For now we just use association lists.
247
248 \subsection{Avoiding a problem with overlapping}
249
250 Consider this little program:
251
252 \begin{pseudocode}
253      class C a        where c :: a
254      class C a => D a where d :: a
255
256      instance C Int where c = 17
257      instance D Int where d = 13
258
259      instance C a => C [a] where c = [c]
260      instance ({- C [a], -} D a) => D [a] where d = c
261
262      instance C [Int] where c = [37]
263
264      main = print (d :: [Int])
265 \end{pseudocode}
266
267 What do you think `main' prints  (assuming we have overlapping instances, and
268 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
269 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
270 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
271 the `C [Int]' instance is more specific).
272
273 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
274 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
275 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
276 doesn't even compile!  What's going on!?
277
278 What hugs complains about is the `D [a]' instance decl.
279
280 \begin{pseudocode}
281      ERROR "mj.hs" (line 10): Cannot build superclass instance
282      *** Instance            : D [a]
283      *** Context supplied    : D a
284      *** Required superclass : C [a]
285 \end{pseudocode}
286
287 You might wonder what hugs is complaining about.  It's saying that you
288 need to add `C [a]' to the context of the `D [a]' instance (as appears
289 in comments).  But there's that `C [a]' instance decl one line above
290 that says that I can reduce the need for a `C [a]' instance to the
291 need for a `C a' instance, and in this case, I already have the
292 necessary `C a' instance (since we have `D a' explicitly in the
293 context, and `C' is a superclass of `D').
294
295 Unfortunately, the above reasoning indicates a premature commitment to the
296 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
297 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
298 add the context that hugs suggests (uncomment the `C [a]'), effectively
299 deferring the decision about which instance to use.
300
301 Now, interestingly enough, 4.04 has this same bug, but it's covered up
302 in this case by a little known `optimization' that was disabled in
303 4.06.  Ghc-4.04 silently inserts any missing superclass context into
304 an instance declaration.  In this case, it silently inserts the `C
305 [a]', and everything happens to work out.
306
307 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
308 `Mark Jones', although Mark claims no credit for the `optimization' in
309 question, and would rather it stopped being called the `Mark Jones
310 optimization' ;-)
311
312 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
313 something else out with ghc-4.04.  Let's add the following line:
314
315     d' :: D a => [a]
316     d' = c
317
318 Everyone raise their hand who thinks that `d :: [Int]' should give a
319 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
320 `optimization' only applies to instance decls, not to regular
321 bindings, giving inconsistent behavior.
322
323 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
324 list of instances for a given class is ordered, so that more specific
325 instances come before more generic ones.  For example, the instance
326 list for C might contain:
327     ..., C Int, ..., C a, ...  
328 When we go to look for a `C Int' instance we'll get that one first.
329 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
330 pass the `C Int' instance, and keep going.  But if `b' is
331 unconstrained, then we don't know yet if the more specific instance
332 will eventually apply.  GHC keeps going, and matches on the generic `C
333 a'.  The fix is to, at each step, check to see if there's a reverse
334 match, and if so, abort the search.  This prevents hugs from
335 prematurely chosing a generic instance when a more specific one
336 exists.
337
338 --Jeff
339
340 BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
341 this test.  Suppose the instance envt had
342     ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
343 (still most specific first)
344 Now suppose we are looking for (C x y Int), where x and y are unconstrained.
345         C x y Int  doesn't match the template {a,b} C a a b
346 but neither does 
347         C a a b  match the template {x,y} C x y Int
348 But still x and y might subsequently be unified so they *do* match.
349
350 Simple story: unify, don't match.
351
352
353 %************************************************************************
354 %*                                                                      *
355                 InstEnv, ClsInstEnv
356 %*                                                                      *
357 %************************************************************************
358
359 A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a
360 ClsInstEnv mapping is the dfun for that instance.
361
362 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
363
364         forall a b, C t1 t2 t3  can be constructed by dfun
365
366 or, to put it another way, we have
367
368         instance (...) => C t1 t2 t3,  witnessed by dfun
369
370 \begin{code}
371 ---------------------------------------------------
372 type InstEnv = UniqFM ClsInstEnv        -- Maps Class to instances for that class
373
374 newtype ClsInstEnv 
375   = ClsIE [ClsInst]    -- The instances for a particular class, in any order
376
377 instance Outputable ClsInstEnv where
378   ppr (ClsIE is) = pprInstances is
379
380 -- INVARIANTS:
381 --  * The is_tvs are distinct in each ClsInst
382 --      of a ClsInstEnv (so we can safely unify them)
383
384 -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
385 --      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
386 -- The "a" in the pattern must be one of the forall'd variables in
387 -- the dfun type.
388
389 emptyInstEnv :: InstEnv
390 emptyInstEnv = emptyUFM
391
392 instEnvElts :: InstEnv -> [ClsInst]
393 instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts]
394
395 classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst]
396 classInstances (pkg_ie, home_ie) cls 
397   = get home_ie ++ get pkg_ie
398   where
399     get env = case lookupUFM env cls of
400                 Just (ClsIE insts) -> insts
401                 Nothing            -> []
402
403 -- | Collects the names of concrete types and type constructors that make
404 -- up the head of a class instance. For instance, given `class Foo a b`:
405 --
406 -- `instance Foo (Either (Maybe Int) a) Bool` would yield
407 --      [Either, Maybe, Int, Bool]
408 --
409 -- Used in the implementation of ":info" in GHCi.
410 orphNamesOfClsInst :: ClsInst -> NameSet
411 orphNamesOfClsInst = orphNamesOfDFunHead . idType . instanceDFunId
412
413 extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
414 extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
415
416 extendInstEnv :: InstEnv -> ClsInst -> InstEnv
417 extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
418   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
419   where
420     add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
421
422 overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv
423 overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys })
424   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
425   where
426     add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts)
427     
428     rough_tcs  = roughMatchTcs tys
429     replaceInst [] = [ins_item]
430     replaceInst (item@(ClsInst { is_tcs = mb_tcs,  is_tvs = tpl_tvs 
431                                , is_tys = tpl_tys }) : rest)
432     -- Fast check for no match, uses the "rough match" fields
433       | instanceCantMatch rough_tcs mb_tcs
434       = item : replaceInst rest
435
436       | let tpl_tv_set = mkVarSet tpl_tvs
437       , Just _ <- tcMatchTys tpl_tv_set tpl_tys tys
438       = ins_item : rest
439
440       | otherwise
441       = item : replaceInst rest
442 \end{code}
443
444
445 %************************************************************************
446 %*                                                                      *
447         Looking up an instance
448 %*                                                                      *
449 %************************************************************************
450
451 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
452 the env is kept ordered, the first match must be the only one.  The
453 thing we are looking up can have an arbitrary "flexi" part.
454
455 \begin{code}
456 type DFunInstType = Maybe Type
457         -- Just ty   => Instantiate with this type
458         -- Nothing   => Instantiate with any type of this tyvar's kind
459         -- See Note [DFunInstType: instantiating types]
460
461 type InstMatch = (ClsInst, [DFunInstType])
462
463 type ClsInstLookupResult 
464      = ( [InstMatch]     -- Successful matches
465        , [ClsInst]       -- These don't match but do unify
466        , Bool)           -- True if error condition caused by
467                          -- SafeHaskell condition.
468 \end{code}
469
470 Note [DFunInstType: instantiating types]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 A successful match is a ClsInst, together with the types at which
473         the dfun_id in the ClsInst should be instantiated
474 The instantiating types are (Either TyVar Type)s because the dfun
475 might have some tyvars that *only* appear in arguments
476         dfun :: forall a b. C a b, Ord b => D [a]
477 When we match this against D [ty], we return the instantiating types
478         [Just ty, Nothing]
479 where the 'Nothing' indicates that 'b' can be freely instantiated.  
480 (The caller instantiates it to a flexi type variable, which will 
481  presumably later become fixed via functional dependencies.)
482
483 \begin{code}
484 -- |Look up an instance in the given instance environment. The given class application must match exactly
485 -- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,
486 -- yield 'Left errorMessage'.
487 --
488 lookupUniqueInstEnv :: (InstEnv, InstEnv) 
489                     -> Class -> [Type]
490                     -> Either MsgDoc (ClsInst, [Type])
491 lookupUniqueInstEnv instEnv cls tys
492   = case lookupInstEnv instEnv cls tys of
493       ([(inst, inst_tys)], _, _) 
494              | noFlexiVar -> Right (inst, inst_tys')
495              | otherwise  -> Left $ ptext (sLit "flexible type variable:") <+>
496                                     (ppr $ mkTyConApp (classTyCon cls) tys)
497              where
498                inst_tys'  = [ty | Just ty <- inst_tys]
499                noFlexiVar = all isJust inst_tys
500       _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys)
501
502 lookupInstEnv' :: InstEnv          -- InstEnv to look in
503                -> Class -> [Type]  -- What we are looking for
504                -> ([InstMatch],    -- Successful matches
505                    [ClsInst])     -- These don't match but do unify
506 -- The second component of the result pair happens when we look up
507 --      Foo [a]
508 -- in an InstEnv that has entries for
509 --      Foo [Int]
510 --      Foo [b]
511 -- Then which we choose would depend on the way in which 'a'
512 -- is instantiated.  So we report that Foo [b] is a match (mapping b->a)
513 -- but Foo [Int] is a unifier.  This gives the caller a better chance of
514 -- giving a suitable error message
515
516 lookupInstEnv' ie cls tys
517   = lookup ie
518   where
519     rough_tcs  = roughMatchTcs tys
520     all_tvs    = all isNothing rough_tcs
521     --------------
522     lookup env = case lookupUFM env cls of
523                    Nothing -> ([],[])   -- No instances for this class
524                    Just (ClsIE insts) -> find [] [] insts
525
526     --------------
527     find ms us [] = (ms, us)
528     find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs
529                               , is_tys = tpl_tys, is_flag = oflag }) : rest)
530         -- Fast check for no match, uses the "rough match" fields
531       | instanceCantMatch rough_tcs mb_tcs
532       = find ms us rest
533
534       | Just subst <- tcMatchTys tpl_tv_set tpl_tys tys
535       = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest
536
537         -- Does not match, so next check whether the things unify
538         -- See Note [Overlapping instances] above
539       | Incoherent _ <- oflag
540       = find ms us rest
541
542       | otherwise
543       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tv_set,
544                  (ppr cls <+> ppr tys <+> ppr all_tvs) $$
545                  (ppr tpl_tvs <+> ppr tpl_tys)
546                 )
547                 -- Unification will break badly if the variables overlap
548                 -- They shouldn't because we allocate separate uniques for them
549                 -- See Note [Template tyvars are fresh]
550         case tcUnifyTys instanceBindFun tpl_tys tys of
551             Just _   -> find ms (item:us) rest
552             Nothing  -> find ms us        rest
553       where
554         tpl_tv_set = mkVarSet tpl_tvs
555
556     ----------------
557     lookup_tv :: TvSubst -> TyVar -> DFunInstType
558         -- See Note [DFunInstType: instantiating types]
559     lookup_tv subst tv = case lookupTyVar subst tv of
560                                 Just ty -> Just ty
561                                 Nothing -> Nothing
562
563 ---------------
564 -- This is the common way to call this function.
565 lookupInstEnv :: (InstEnv, InstEnv)     -- External and home package inst-env
566               -> Class -> [Type]   -- What we are looking for
567               -> ClsInstLookupResult
568  
569 lookupInstEnv (pkg_ie, home_ie) cls tys
570   = (safe_matches, all_unifs, safe_fail)
571   where
572     (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys
573     (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  cls tys
574     all_matches = home_matches ++ pkg_matches
575     all_unifs   = home_unifs   ++ pkg_unifs
576     pruned_matches = foldr insert_overlapping [] all_matches
577     (safe_matches, safe_fail) = if length pruned_matches == 1 
578                         then check_safe (head pruned_matches) all_matches
579                         else (pruned_matches, False)
580         -- Even if the unifs is non-empty (an error situation)
581         -- we still prune the matches, so that the error message isn't
582         -- misleading (complaining of multiple matches when some should be
583         -- overlapped away)
584
585     -- Safe Haskell: We restrict code compiled in 'Safe' mode from 
586     -- overriding code compiled in any other mode. The rational is
587     -- that code compiled in 'Safe' mode is code that is untrusted
588     -- by the ghc user. So we shouldn't let that code change the
589     -- behaviour of code the user didn't compile in 'Safe' mode
590     -- since that's the code they trust. So 'Safe' instances can only
591     -- overlap instances from the same module. A same instance origin
592     -- policy for safe compiled instances.
593     check_safe match@(inst,_) others
594         = case isSafeOverlap (is_flag inst) of
595                 -- most specific isn't from a Safe module so OK
596                 False -> ([match], False)
597                 -- otherwise we make sure it only overlaps instances from
598                 -- the same module
599                 True -> (go [] others, True)
600         where
601             go bad [] = match:bad
602             go bad (i@(x,_):unchecked) =
603                 if inSameMod x
604                     then go bad unchecked
605                     else go (i:bad) unchecked
606             
607             inSameMod b =
608                 let na = getName $ getName inst
609                     la = isInternalName na
610                     nb = getName $ getName b
611                     lb = isInternalName nb
612                 in (la && lb) || (nameModule na == nameModule nb)
613
614 ---------------
615 ---------------
616 insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
617 -- Add a new solution, knocking out strictly less specific ones
618 insert_overlapping new_item [] = [new_item]
619 insert_overlapping new_item (item:items)
620   | new_beats_old && old_beats_new = item : insert_overlapping new_item items
621         -- Duplicate => keep both for error report
622   | new_beats_old = insert_overlapping new_item items
623         -- Keep new one
624   | old_beats_new = item : items
625         -- Keep old one
626   | otherwise     = item : insert_overlapping new_item items
627         -- Keep both
628   where
629     new_beats_old = new_item `beats` item
630     old_beats_new = item `beats` new_item
631
632     (instA, _) `beats` (instB, _)
633           = overlap_ok && 
634             isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA))
635                     -- A beats B if A is more specific than B,
636                     -- (ie. if B can be instantiated to match A)
637                     -- and overlap is permitted
638           where
639             -- Overlap permitted if *either* instance permits overlap
640             -- This is a change (Trac #3877, Dec 10). It used to
641             -- require that instB (the less specific one) permitted overlap.
642             overlap_ok = case (is_flag instA, is_flag instB) of
643                               (NoOverlap _, NoOverlap _) -> False
644                               _                          -> True
645 \end{code}
646
647
648 %************************************************************************
649 %*                                                                      *
650         Binding decisions
651 %*                                                                      *
652 %************************************************************************
653
654 \begin{code}
655 instanceBindFun :: TyVar -> BindFlag
656 instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem
657                    | otherwise                              = BindMe
658    -- Note [Binding when looking up instances]
659 \end{code}
660
661 Note [Binding when looking up instances]
662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
663 When looking up in the instance environment, or family-instance environment,
664 we are careful about multiple matches, as described above in 
665 Note [Overlapping instances]
666
667 The key_tys can contain skolem constants, and we can guarantee that those
668 are never going to be instantiated to anything, so we should not involve
669 them in the unification test.  Example:
670         class Foo a where { op :: a -> Int }
671         instance Foo a => Foo [a]       -- NB overlap
672         instance Foo [Int]              -- NB overlap
673         data T = forall a. Foo a => MkT a
674         f :: T -> Int
675         f (MkT x) = op [x,x]
676 The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
677 complain, saying that the choice of instance depended on the instantiation
678 of 'a'; but of course it isn't *going* to be instantiated.
679
680 We do this only for isOverlappableTyVar skolems.  For example we reject
681         g :: forall a => [a] -> Int
682         g x = op x
683 on the grounds that the correct instance depends on the instantiation of 'a'