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