remove empty dir
[ghc-hetmet.git] / ghc / compiler / types / InstEnv.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[InstEnv]{Utilities for typechecking instance declarations}
5
6 The bits common to TcInstDcls and TcDeriv.
7
8 \begin{code}
9 module InstEnv (
10         DFunId, OverlapFlag(..),
11         Instance(..), pprInstance, pprInstanceHdr, pprInstances, 
12         instanceHead, mkLocalInstance, mkImportedInstance,
13         instanceDFunId, setInstanceDFunId, instanceRoughTcs,
14
15         InstEnv, emptyInstEnv, extendInstEnv, 
16         extendInstEnvList, lookupInstEnv, instEnvElts,
17         classInstances, 
18         instanceCantMatch, roughMatchTcs
19     ) where
20
21 #include "HsVersions.h"
22
23 import Class            ( Class )
24 import Var              ( Id, TyVar, isTcTyVar )
25 import VarSet
26 import Name             ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom, nameModule )
27 import OccName          ( OccName )
28 import NameSet          ( unionNameSets, unitNameSet, nameSetToList )
29 import Type             ( TvSubst )
30 import TcType           ( Type, PredType, tcEqType,
31                           tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar,
32                           pprThetaArrow, pprClassPred,
33                           tyClsNamesOfType, tcSplitTyConApp_maybe
34                         )
35 import TyCon            ( tyConName )
36 import Unify            ( tcMatchTys, tcUnifyTys, BindFlag(..) )
37 import Outputable
38 import UniqFM           ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
39 import Id               ( idType, idName )
40 import SrcLoc           ( pprDefnLoc )
41 import Maybe            ( isJust, isNothing )
42 \end{code}
43
44
45 %************************************************************************
46 %*                                                                      *
47 \subsection{The key types}
48 %*                                                                      *
49 %************************************************************************
50
51 \begin{code}
52 type DFunId = Id
53 data Instance 
54   = Instance { is_cls  :: Name          -- Class name
55         
56                 -- Used for "rough matching"; see note below
57              , is_tcs  :: [Maybe Name]  -- Top of type args
58
59                 -- Used for "proper matching"; see note
60              , is_tvs  :: TyVarSet      -- Template tyvars for full match
61              , is_tys  :: [Type]        -- Full arg types
62
63              , is_dfun :: DFunId
64              , is_flag :: OverlapFlag
65
66              , is_orph :: Maybe OccName }
67
68 -- The "rough-match" fields
69 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
70 -- The is_cls, is_args fields allow a "rough match" to be done
71 -- without poking inside the DFunId.  Poking the DFunId forces
72 -- us to suck in all the type constructors etc it involves,
73 -- which is a total waste of time if it has no chance of matching
74 -- So the Name, [Maybe Name] fields allow us to say "definitely
75 -- does not match", based only on the Name.
76 --
77 -- In is_tcs, 
78 --     Nothing  means that this type arg is a type variable
79 --
80 --     (Just n) means that this type arg is a
81 --              TyConApp with a type constructor of n.
82 --              This is always a real tycon, never a synonym!
83 --              (Two different synonyms might match, but two
84 --              different real tycons can't.)
85 --              NB: newtypes are not transparent, though!
86 --
87 -- The "proper-match" fields
88 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
89 -- The is_tvs, is_tys fields are simply cahced values, pulled
90 -- out (lazily) from the dfun id. They are cached here simply so 
91 -- that we don't need to decompose the DFunId each time we want 
92 -- to match it.  The hope is that the fast-match fields mean
93 -- that we often never poke th proper-match fields
94 --
95 -- However, note that:
96 --  * is_tvs must be a superset of the free vars of is_tys
97 --
98 --  * The is_dfun must itself be quantified over exactly is_tvs
99 --    (This is so that we can use the matching substitution to
100 --     instantiate the dfun's context.)
101 --
102 -- The "orphan" field
103 -- ~~~~~~~~~~~~~~~~~~
104 -- An instance is an orphan if its head (after the =>) mentions
105 -- nothing defined in this module.  
106 --
107 --    Just n    The head mentions n, which is defined in this module
108 --              This is used for versioning; the instance decl is
109 --              considered part of the defn of n when computing versions
110 --
111 --    Nothing   The head mentions nothing defined in this modle
112 --
113 -- If a module contains any orphans, then its interface file is read 
114 -- regardless, so that its instances are not missed. 
115 -- 
116 -- Functional dependencies worsen the situation a bit. Consider
117 --      class C a b | a -> b
118 -- In some other module we might have
119 --    module M where
120 --      data T = ...
121 --      instance C Int T where ...
122 -- This isn't considered an orphan, so we will only read M's interface
123 -- if something from M is used (e.g. T).  So there's a risk we'll
124 -- miss the improvement from the instance.  Workaround: import M.
125
126 instanceDFunId :: Instance -> DFunId
127 instanceDFunId = is_dfun
128
129 setInstanceDFunId :: Instance -> DFunId -> Instance
130 setInstanceDFunId ispec dfun
131    = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
132         -- We need to create the cached fields afresh from
133         -- the new dfun id.  In particular, the is_tvs in
134         -- the Instance must match those in the dfun!
135         -- We assume that the only thing that changes is
136         -- the quantified type variables, so the other fields
137         -- are ok; hence the assert
138      ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
139    where 
140      (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
141
142 instanceRoughTcs :: Instance -> [Maybe Name]
143 instanceRoughTcs = is_tcs
144 \end{code}
145
146 \begin{code}
147 instance NamedThing Instance where
148    getName ispec = getName (is_dfun ispec)
149
150 instance Outputable Instance where
151    ppr = pprInstance
152
153 pprInstance :: Instance -> SDoc
154 -- Prints the Instance as an instance declaration
155 pprInstance ispec@(Instance { is_flag = flag })
156   = hang (pprInstanceHdr ispec)
157         2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc ispec)))
158
159 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
160 pprInstanceHdr :: Instance -> SDoc
161 -- Prints the Instance as an instance declaration
162 pprInstanceHdr ispec@(Instance { is_flag = flag })
163   = ptext SLIT("instance") <+> ppr flag
164     <+> sep [pprThetaArrow theta, pprClassPred clas tys]
165   where
166     (_, theta, clas, tys) = instanceHead ispec
167         -- Print without the for-all, which the programmer doesn't write
168
169 pprInstances :: [Instance] -> SDoc
170 pprInstances ispecs = vcat (map pprInstance ispecs)
171
172 instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type])
173 instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec))
174
175 mkLocalInstance :: DFunId -> OverlapFlag -> Instance
176 -- Used for local instances, where we can safely pull on the DFunId
177 mkLocalInstance dfun oflag
178   = Instance {  is_flag = oflag, is_dfun = dfun,
179                 is_tvs = mkVarSet tvs, is_tys = tys,
180                 is_cls = cls_name, is_tcs = roughMatchTcs tys,
181                 is_orph = orph }
182   where
183     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
184     mod = nameModule (idName dfun)
185     cls_name = getName cls
186     tycl_names = foldr (unionNameSets . tyClsNamesOfType) 
187                        (unitNameSet cls_name) tys
188     orph = case filter (nameIsLocalOrFrom mod) (nameSetToList tycl_names) of
189                 []     -> Nothing
190                 (n:ns) -> Just (getOccName n)
191
192 mkImportedInstance :: Name -> [Maybe Name] -> Maybe OccName
193                    -> DFunId -> OverlapFlag -> Instance
194 -- Used for imported instances, where we get the rough-match stuff
195 -- from the interface file
196 mkImportedInstance cls mb_tcs orph dfun oflag
197   = Instance {  is_flag = oflag, is_dfun = dfun,
198                 is_tvs = mkVarSet tvs, is_tys = tys,
199                 is_cls = cls, is_tcs = mb_tcs, is_orph = orph }
200   where
201     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
202
203 roughMatchTcs :: [Type] -> [Maybe Name]
204 roughMatchTcs tys = map rough tys
205   where
206     rough ty = case tcSplitTyConApp_maybe ty of
207                   Just (tc,_) -> Just (tyConName tc)
208                   Nothing     -> Nothing
209
210 instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
211 -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
212 -- possibly be instantiated to actual, nor vice versa; 
213 -- False is non-committal
214 instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
215 instanceCantMatch ts            as            =  False  -- Safe
216
217 ---------------------------------------------------
218 data OverlapFlag
219   = NoOverlap   -- This instance must not overlap another
220
221   | OverlapOk   -- Silently ignore this instance if you find a 
222                 -- more specific one that matches the constraint
223                 -- you are trying to resolve
224                 --
225                 -- Example: constraint (Foo [Int])
226                 --          instances  (Foo [Int])
227                 --                     (Foo [a])        OverlapOk
228                 -- Since the second instance has the OverlapOk flag,
229                 -- the first instance will be chosen (otherwise 
230                 -- its ambiguous which to choose)
231
232   | Incoherent  -- Like OverlapOk, but also ignore this instance 
233                 -- if it doesn't match the constraint you are
234                 -- trying to resolve, but could match if the type variables
235                 -- in the constraint were instantiated
236                 --
237                 -- Example: constraint (Foo [b])
238                 --          instances  (Foo [Int])      Incoherent
239                 --                     (Foo [a])
240                 -- Without the Incoherent flag, we'd complain that
241                 -- instantiating 'b' would change which instance 
242                 -- was chosen
243
244 instance Outputable OverlapFlag where
245    ppr NoOverlap  = empty
246    ppr OverlapOk  = ptext SLIT("[overlap ok]")
247    ppr Incoherent = ptext SLIT("[incoherent]")
248 \end{code}
249
250
251 Note [Overlapping instances]
252 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253 Overlap is permitted, but only in such a way that one can make
254 a unique choice when looking up.  That is, overlap is only permitted if
255 one template matches the other, or vice versa.  So this is ok:
256
257   [a]  [Int]
258
259 but this is not
260
261   (Int,a)  (b,Int)
262
263 If overlap is permitted, the list is kept most specific first, so that
264 the first lookup is the right choice.
265
266
267 For now we just use association lists.
268
269 \subsection{Avoiding a problem with overlapping}
270
271 Consider this little program:
272
273 \begin{pseudocode}
274      class C a        where c :: a
275      class C a => D a where d :: a
276
277      instance C Int where c = 17
278      instance D Int where d = 13
279
280      instance C a => C [a] where c = [c]
281      instance ({- C [a], -} D a) => D [a] where d = c
282
283      instance C [Int] where c = [37]
284
285      main = print (d :: [Int])
286 \end{pseudocode}
287
288 What do you think `main' prints  (assuming we have overlapping instances, and
289 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
290 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
291 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
292 the `C [Int]' instance is more specific).
293
294 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
295 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
296 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
297 doesn't even compile!  What's going on!?
298
299 What hugs complains about is the `D [a]' instance decl.
300
301 \begin{pseudocode}
302      ERROR "mj.hs" (line 10): Cannot build superclass instance
303      *** Instance            : D [a]
304      *** Context supplied    : D a
305      *** Required superclass : C [a]
306 \end{pseudocode}
307
308 You might wonder what hugs is complaining about.  It's saying that you
309 need to add `C [a]' to the context of the `D [a]' instance (as appears
310 in comments).  But there's that `C [a]' instance decl one line above
311 that says that I can reduce the need for a `C [a]' instance to the
312 need for a `C a' instance, and in this case, I already have the
313 necessary `C a' instance (since we have `D a' explicitly in the
314 context, and `C' is a superclass of `D').
315
316 Unfortunately, the above reasoning indicates a premature commitment to the
317 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
318 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
319 add the context that hugs suggests (uncomment the `C [a]'), effectively
320 deferring the decision about which instance to use.
321
322 Now, interestingly enough, 4.04 has this same bug, but it's covered up
323 in this case by a little known `optimization' that was disabled in
324 4.06.  Ghc-4.04 silently inserts any missing superclass context into
325 an instance declaration.  In this case, it silently inserts the `C
326 [a]', and everything happens to work out.
327
328 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
329 `Mark Jones', although Mark claims no credit for the `optimization' in
330 question, and would rather it stopped being called the `Mark Jones
331 optimization' ;-)
332
333 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
334 something else out with ghc-4.04.  Let's add the following line:
335
336     d' :: D a => [a]
337     d' = c
338
339 Everyone raise their hand who thinks that `d :: [Int]' should give a
340 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
341 `optimization' only applies to instance decls, not to regular
342 bindings, giving inconsistent behavior.
343
344 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
345 list of instances for a given class is ordered, so that more specific
346 instances come before more generic ones.  For example, the instance
347 list for C might contain:
348     ..., C Int, ..., C a, ...  
349 When we go to look for a `C Int' instance we'll get that one first.
350 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
351 pass the `C Int' instance, and keep going.  But if `b' is
352 unconstrained, then we don't know yet if the more specific instance
353 will eventually apply.  GHC keeps going, and matches on the generic `C
354 a'.  The fix is to, at each step, check to see if there's a reverse
355 match, and if so, abort the search.  This prevents hugs from
356 prematurely chosing a generic instance when a more specific one
357 exists.
358
359 --Jeff
360
361 BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
362 this test.  Suppose the instance envt had
363     ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
364 (still most specific first)
365 Now suppose we are looking for (C x y Int), where x and y are unconstrained.
366         C x y Int  doesn't match the template {a,b} C a a b
367 but neither does 
368         C a a b  match the template {x,y} C x y Int
369 But still x and y might subsequently be unified so they *do* match.
370
371 Simple story: unify, don't match.
372
373
374 %************************************************************************
375 %*                                                                      *
376                 InstEnv, ClsInstEnv
377 %*                                                                      *
378 %************************************************************************
379
380 A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a
381 ClsInstEnv mapping is the dfun for that instance.
382
383 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
384
385         forall a b, C t1 t2 t3  can be constructed by dfun
386
387 or, to put it another way, we have
388
389         instance (...) => C t1 t2 t3,  witnessed by dfun
390
391 \begin{code}
392 ---------------------------------------------------
393 type InstEnv = UniqFM ClsInstEnv        -- Maps Class to instances for that class
394
395 data ClsInstEnv 
396   = ClsIE [Instance]    -- The instances for a particular class, in any order
397           Bool          -- True <=> there is an instance of form C a b c
398                         --      If *not* then the common case of looking up
399                         --      (C a b c) can fail immediately
400
401 -- INVARIANTS:
402 --  * The is_tvs are distinct in each Instance
403 --      of a ClsInstEnv (so we can safely unify them)
404
405 -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
406 --      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
407 -- The "a" in the pattern must be one of the forall'd variables in
408 -- the dfun type.
409
410 emptyInstEnv :: InstEnv
411 emptyInstEnv = emptyUFM
412
413 instEnvElts :: InstEnv -> [Instance]
414 instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts]
415
416 classInstances :: (InstEnv,InstEnv) -> Class -> [Instance]
417 classInstances (pkg_ie, home_ie) cls 
418   = get home_ie ++ get pkg_ie
419   where
420     get env = case lookupUFM env cls of
421                 Just (ClsIE insts _) -> insts
422                 Nothing              -> []
423
424 extendInstEnvList :: InstEnv -> [Instance] -> InstEnv
425 extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
426
427 extendInstEnv :: InstEnv -> Instance -> InstEnv
428 extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs })
429   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar)
430   where
431     add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts)
432                                               (ins_tyvar || cur_tyvar)
433     ins_tyvar = not (any isJust mb_tcs)
434 \end{code}                    
435
436
437 %************************************************************************
438 %*                                                                      *
439 \subsection{Looking up an instance}
440 %*                                                                      *
441 %************************************************************************
442
443 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
444 the env is kept ordered, the first match must be the only one.  The
445 thing we are looking up can have an arbitrary "flexi" part.
446
447 \begin{code}
448 lookupInstEnv :: (InstEnv       -- External package inst-env
449                  ,InstEnv)      -- Home-package inst-env
450               -> Class -> [Type]                -- What we are looking for
451               -> ([(TvSubst, Instance)],        -- Successful matches
452                   [Instance])                   -- These don't match but do unify
453         -- The second component of the tuple happens when we look up
454         --      Foo [a]
455         -- in an InstEnv that has entries for
456         --      Foo [Int]
457         --      Foo [b]
458         -- Then which we choose would depend on the way in which 'a'
459         -- is instantiated.  So we report that Foo [b] is a match (mapping b->a)
460         -- but Foo [Int] is a unifier.  This gives the caller a better chance of
461         -- giving a suitable error messagen
462
463 lookupInstEnv (pkg_ie, home_ie) cls tys
464   = (pruned_matches, all_unifs)
465   where
466     rough_tcs  = roughMatchTcs tys
467     all_tvs    = all isNothing rough_tcs
468     (home_matches, home_unifs) = lookup home_ie 
469     (pkg_matches,  pkg_unifs)  = lookup pkg_ie  
470     all_matches = home_matches ++ pkg_matches
471     all_unifs   = home_unifs   ++ pkg_unifs
472     pruned_matches 
473         | null all_unifs = foldr insert_overlapping [] all_matches
474         | otherwise      = all_matches  -- Non-empty unifs is always an error situation,
475                                         -- so don't attempt to pune the matches
476
477     --------------
478     lookup env = case lookupUFM env cls of
479                    Nothing -> ([],[])   -- No instances for this class
480                    Just (ClsIE insts has_tv_insts)
481                         | all_tvs && not has_tv_insts
482                         -> ([],[])      -- Short cut for common case
483                         -- The thing we are looking up is of form (C a b c), and
484                         -- the ClsIE has no instances of that form, so don't bother to search
485         
486                         | otherwise
487                         -> find [] [] insts
488
489     --------------
490     find ms us [] = (ms, us)
491     find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, 
492                                  is_tys = tpl_tys, is_flag = oflag,
493                                  is_dfun = dfun }) : rest)
494         -- Fast check for no match, uses the "rough match" fields
495       | instanceCantMatch rough_tcs mb_tcs
496       = find ms us rest
497
498       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
499       = find ((subst,item):ms) us rest
500
501         -- Does not match, so next check whether the things unify
502         -- See Note [overlapping instances] above
503       | Incoherent <- oflag
504       = find ms us rest
505
506       | otherwise
507       = ASSERT2( not (tyVarsOfTypes tys `intersectsVarSet` tpl_tvs),
508                        (ppr cls <+> ppr tys <+> ppr all_tvs) $$
509                        (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_tys)
510                 )
511                 -- Unification will break badly if the variables overlap
512                 -- They shouldn't because we allocate separate uniques for them
513         case tcUnifyTys bind_fn tpl_tys tys of
514             Just _   -> find ms (item:us) rest
515             Nothing  -> find ms us         rest
516
517 ---------------
518 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
519            | otherwise                             = BindMe
520         -- The key_tys can contain skolem constants, and we can guarantee that those
521         -- are never going to be instantiated to anything, so we should not involve
522         -- them in the unification test.  Example:
523         --      class Foo a where { op :: a -> Int }
524         --      instance Foo a => Foo [a]       -- NB overlap
525         --      instance Foo [Int]              -- NB overlap
526         --      data T = forall a. Foo a => MkT a
527         --      f :: T -> Int
528         --      f (MkT x) = op [x,x]
529         -- The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
530         -- complain, saying that the choice of instance depended on the instantiation
531         -- of 'a'; but of course it isn't *going* to be instantiated.
532         --
533         -- We do this only for pattern-bound skolems.  For example we reject
534         --      g :: forall a => [a] -> Int
535         --      g x = op x
536         -- on the grounds that the correct instance depends on the instantiation of 'a'
537
538 ---------------
539 insert_overlapping :: (TvSubst, Instance) -> [(TvSubst, Instance)] 
540                    -> [(TvSubst, Instance)]
541 -- Add a new solution, knocking out strictly less specific ones
542 insert_overlapping new_item [] = [new_item]
543 insert_overlapping new_item (item:items)
544   | new_beats_old && old_beats_new = item : insert_overlapping new_item items
545         -- Duplicate => keep both for error report
546   | new_beats_old = insert_overlapping new_item items
547         -- Keep new one
548   | old_beats_new = item : items
549         -- Keep old one
550   | otherwise     = item : insert_overlapping new_item items
551         -- Keep both
552   where
553     new_beats_old = new_item `beats` item
554     old_beats_new = item `beats` new_item
555
556     (_, instA) `beats` (_, instB)
557         = overlap_ok && 
558           isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
559                 -- A beats B if A is more specific than B, and B admits overlap
560                 -- I.e. if B can be instantiated to match A
561         where
562           overlap_ok = case is_flag instB of
563                         NoOverlap -> False
564                         other     -> True
565 \end{code}
566