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