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, ClsInstEnv, InstEnv,
  11
  12         emptyInstEnv, extendInstEnv, pprInstEnv,
  13         lookupInstEnv, InstLookupResult(..),
  14         classInstEnv, simpleDFunClassTyCon
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import Class            ( Class, classTvsFds )
  20 import Var              ( TyVar, Id )
  21 import VarSet
  22 import VarEnv
  23 import Maybes           ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
  24 import Name             ( getSrcLoc )
  25 import TcType           ( Type, tcTyConAppTyCon, mkTyVarTy,
  26                           tcSplitDFunTy, tyVarsOfTypes,
  27                           matchTys, unifyTyListsX, allDistinctTyVars
  28                         )
  29 import PprType          ( pprClassPred )
  30 import FunDeps          ( checkClsFD )
  31 import TyCon            ( TyCon )
  32 import Outputable
  33 import UniqFM           ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
  34 import Id               ( idType )
  35 import ErrUtils         ( Message )
  36 import CmdLineOpts
  37 \end{code}
  38
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection{The key types}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 \begin{code}
  47 type DFunId     = Id
  48
  49 type InstEnv    = UniqFM ClsInstEnv             -- Maps Class to instances for that class
  50
  51 simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
  52 simpleDFunClassTyCon dfun
  53   = (clas, tycon)
  54   where
  55     (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun)
  56     tycon           = tcTyConAppTyCon ty
  57
  58 pprInstEnv :: InstEnv -> SDoc
  59 pprInstEnv env
  60   = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+>
  61            brackets (pprWithCommas ppr tys) <+> ppr dfun
  62          | cls_inst_env <-  eltsUFM env
  63          , (tyvars, tys, dfun) <- cls_inst_env
  64          ]
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Instance environments: InstEnv and ClsInstEnv}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 type ClsInstEnv = [(TyVarSet, [Type], DFunId)]  -- The instances for a particular class
  75         -- INVARIANTs: see notes below
  76
  77 emptyInstEnv :: InstEnv
  78 emptyInstEnv = emptyUFM
  79
  80 classInstEnv :: InstEnv -> Class -> ClsInstEnv
  81 classInstEnv env cls = lookupWithDefaultUFM env [] cls
  82 \end{code}
  83
  84 A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a
  85 ClsInstEnv mapping is the dfun for that instance.
  86
  87 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
  88
  89         forall a b, C t1 t2 t3  can be constructed by dfun
  90
  91 or, to put it another way, we have
  92
  93         instance (...) => C t1 t2 t3,  witnessed by dfun
  94
  95 There is an important consistency constraint in the elements of a ClsInstEnv:
  96
  97   * [a,b] must be a superset of the free vars of [t1,t2,t3]
  98
  99   * The dfun must itself be quantified over [a,b]
 100
 101   * More specific instances come before less specific ones,
 102     where they overlap
 103
 104 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
 105         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 106 The "a" in the pattern must be one of the forall'd variables in
 107 the dfun type.
 108
 109
 110
 111 Notes on overlapping instances
 112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 113 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
 114
 115 In others, overlap is permitted, but only in such a way that one can make
 116 a unique choice when looking up.  That is, overlap is only permitted if
 117 one template matches the other, or vice versa.  So this is ok:
 118
 119   [a]  [Int]
 120
 121 but this is not
 122
 123   (Int,a)  (b,Int)
 124
 125 If overlap is permitted, the list is kept most specific first, so that
 126 the first lookup is the right choice.
 127
 128
 129 For now we just use association lists.
 130
 131 \subsection{Avoiding a problem with overlapping}
 132
 133 Consider this little program:
 134
 135 \begin{pseudocode}
 136      class C a        where c :: a
 137      class C a => D a where d :: a
 138
 139      instance C Int where c = 17
 140      instance D Int where d = 13
 141
 142      instance C a => C [a] where c = [c]
 143      instance ({- C [a], -} D a) => D [a] where d = c
 144
 145      instance C [Int] where c = [37]
 146
 147      main = print (d :: [Int])
 148 \end{pseudocode}
 149
 150 What do you think `main' prints  (assuming we have overlapping instances, and
 151 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
 152 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
 153 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
 154 the `C [Int]' instance is more specific).
 155
 156 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
 157 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
 158 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
 159 doesn't even compile!  What's going on!?
 160
 161 What hugs complains about is the `D [a]' instance decl.
 162
 163 \begin{pseudocode}
 164      ERROR "mj.hs" (line 10): Cannot build superclass instance
 165      *** Instance            : D [a]
 166      *** Context supplied    : D a
 167      *** Required superclass : C [a]
 168 \end{pseudocode}
 169
 170 You might wonder what hugs is complaining about.  It's saying that you
 171 need to add `C [a]' to the context of the `D [a]' instance (as appears
 172 in comments).  But there's that `C [a]' instance decl one line above
 173 that says that I can reduce the need for a `C [a]' instance to the
 174 need for a `C a' instance, and in this case, I already have the
 175 necessary `C a' instance (since we have `D a' explicitly in the
 176 context, and `C' is a superclass of `D').
 177
 178 Unfortunately, the above reasoning indicates a premature commitment to the
 179 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
 180 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
 181 add the context that hugs suggests (uncomment the `C [a]'), effectively
 182 deferring the decision about which instance to use.
 183
 184 Now, interestingly enough, 4.04 has this same bug, but it's covered up
 185 in this case by a little known `optimization' that was disabled in
 186 4.06.  Ghc-4.04 silently inserts any missing superclass context into
 187 an instance declaration.  In this case, it silently inserts the `C
 188 [a]', and everything happens to work out.
 189
 190 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
 191 `Mark Jones', although Mark claims no credit for the `optimization' in
 192 question, and would rather it stopped being called the `Mark Jones
 193 optimization' ;-)
 194
 195 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
 196 something else out with ghc-4.04.  Let's add the following line:
 197
 198     d' :: D a => [a]
 199     d' = c
 200
 201 Everyone raise their hand who thinks that `d :: [Int]' should give a
 202 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
 203 `optimization' only applies to instance decls, not to regular
 204 bindings, giving inconsistent behavior.
 205
 206 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
 207 list of instances for a given class is ordered, so that more specific
 208 instances come before more generic ones.  For example, the instance
 209 list for C might contain:
 210     ..., C Int, ..., C a, ...
 211 When we go to look for a `C Int' instance we'll get that one first.
 212 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
 213 pass the `C Int' instance, and keep going.  But if `b' is
 214 unconstrained, then we don't know yet if the more specific instance
 215 will eventually apply.  GHC keeps going, and matches on the generic `C
 216 a'.  The fix is to, at each step, check to see if there's a reverse
 217 match, and if so, abort the search.  This prevents hugs from
 218 prematurely chosing a generic instance when a more specific one
 219 exists.
 220
 221 --Jeff
 222
 223 BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
 224 this test.  Suppose the instance envt had
 225     ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
 226 (still most specific first)
 227 Now suppose we are looking for (C x y Int), where x and y are unconstrained.
 228         C x y Int  doesn't match the template {a,b} C a a b
 229 but neither does
 230         C a a b  match the template {x,y} C x y Int
 231 But still x and y might subsequently be unified so they *do* match.
 232
 233 Simple story: unify, don't match.
 234
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection{Looking up an instance}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
 243 the env is kept ordered, the first match must be the only one.  The
 244 thing we are looking up can have an arbitrary "flexi" part.
 245
 246 \begin{code}
 247 lookupInstEnv :: InstEnv                        -- The envt
 248               -> Class -> [Type]        -- Key
 249               -> InstLookupResult
 250
 251 data InstLookupResult
 252   = FoundInst                   -- There is a (template,substitution) pair
 253                                 -- that makes the template match the key,
 254                                 -- and no template is an instance of the key
 255         TyVarSubstEnv Id
 256
 257   | NoMatch Bool        -- Boolean is true iff there is at least one
 258                         -- template that matches the key.
 259                         -- (but there are other template(s) that are
 260                         --  instances of the key, so we don't report
 261                         --  FoundInst)
 262         -- The NoMatch True case happens when we look up
 263         --      Foo [a]
 264         -- in an InstEnv that has entries for
 265         --      Foo [Int]
 266         --      Foo [b]
 267         -- Then which we choose would depend on the way in which 'a'
 268         -- is instantiated.  So we say there is no match, but identify
 269         -- it as ambiguous case in the hope of giving a better error msg.
 270         -- See the notes above from Jeff Lewis
 271
 272 lookupInstEnv env key_cls key_tys
 273   = find (classInstEnv env key_cls)
 274   where
 275     key_vars = tyVarsOfTypes key_tys
 276
 277     find [] = NoMatch False
 278     find ((tpl_tyvars, tpl, dfun_id) : rest)
 279       = case matchTys tpl_tyvars tpl key_tys of
 280           Nothing                 ->
 281                 -- Check whether the things unify, so that
 282                 -- we bale out if a later instantiation of this
 283                 -- predicate might match this instance
 284                 -- [see notes about overlapping instances above]
 285             case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of
 286               Nothing        -> find rest
 287               Just _         -> NoMatch (any_match rest)
 288           Just (subst, leftovers) -> ASSERT( null leftovers )
 289                                      pprTrace "lookupInst" (vcat [text "look:" <+> ppr key_cls <+> ppr key_tys,
 290                                                                   text "found:" <+> ppr dfun_id,
 291                                                                   text "env:" <+> ppr (classInstEnv env key_cls)]) $
 292                                      FoundInst subst dfun_id
 293
 294     any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
 295                         | (tvs,tpl,_) <- rest
 296                         ]
 297 \end{code}
 298
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection{Extending an instance environment}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 @extendInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
 307
 308 A boolean flag controls overlap reporting.
 309
 310 True => overlap is permitted, but only if one template matches the other;
 311         not if they unify but neither is
 312
 313 \begin{code}
 314 extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message])
 315   -- Similar, but all we have is the DFuns
 316 extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids
 317
 318
 319 addToInstEnv :: DynFlags
 320              -> (InstEnv, [Message])
 321              -> DFunId
 322              -> (InstEnv, [Message])    -- Resulting InstEnv and augmented error messages
 323
 324 addToInstEnv dflags (inst_env, errs) dfun_id
 325         -- Check first that the new instance doesn't
 326         -- conflict with another.  See notes below about fundeps.
 327   | not (null bad_fundeps)
 328   = (inst_env, fundep_err : errs)               -- Bad fundeps; report the first only
 329
 330   | otherwise
 331   = case insert_into cls_inst_env of
 332         Failed err        -> (inst_env, err : errs)
 333         Succeeded new_env -> (addToUFM inst_env clas new_env, errs)
 334
 335   where
 336     cls_inst_env = classInstEnv inst_env clas
 337     (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id)
 338     bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys
 339     fundep_err  = fundepErr dfun_id (head bad_fundeps)
 340
 341     ins_tv_set = mkVarSet ins_tvs
 342     ins_item   = (ins_tv_set, ins_tys, dfun_id)
 343
 344     insert_into [] = returnMaB [ins_item]
 345     insert_into env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest)
 346       = case unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys of
 347           Just subst -> insert_unifiable env subst
 348           Nothing    -> carry_on cur_item rest
 349
 350     carry_on cur_item rest = insert_into rest     `thenMaB` \ rest' ->
 351                              returnMaB (cur_item : rest')
 352
 353             -- The two templates unify.  This is acceptable iff
 354             -- (a) -fallow-overlapping-instances is on
 355             -- (b) one is strictly more specific than the other
 356             -- [It's bad if they are identical or incomparable]
 357     insert_unifiable env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) subst
 358       |  ins_item_more_specific && cur_item_more_specific
 359       =         -- Duplicates
 360         failMaB (dupInstErr dfun_id tpl_dfun_id)
 361
 362       |  not (dopt Opt_AllowOverlappingInstances dflags)
 363       || not (ins_item_more_specific || cur_item_more_specific)
 364       =         -- Overlap illegal, or the two are incomparable
 365          failMaB (overlapErr dfun_id tpl_dfun_id)
 366
 367       | otherwise
 368       =         -- OK, it's acceptable.  Remaining question is whether
 369                 -- we drop it here or compare it with others
 370         if ins_item_more_specific then
 371                 -- New item is an instance of current item, so drop it here
 372             returnMaB (ins_item : env)
 373         else
 374             carry_on cur_item rest
 375
 376       where
 377         ins_item_more_specific = allVars subst ins_tvs
 378         cur_item_more_specific = allVars subst (varSetElems tpl_tvs)
 379
 380 allVars :: TyVarSubstEnv -> [TyVar] -> Bool
 381 -- True iff all the type vars are mapped to distinct type vars
 382 allVars subst tvs
 383   = allDistinctTyVars (map lookup tvs) emptyVarSet
 384   where
 385     lookup tv = case lookupSubstEnv subst tv of
 386                   Just (DoneTy ty) -> ty
 387                   Nothing          -> mkTyVarTy tv
 388 \end{code}
 389
 390 Functional dependencies
 391 ~~~~~~~~~~~~~~~~~~~~~~~
 392 Here is the bad case:
 393         class C a b | a->b where ...
 394         instance C Int Bool where ...
 395         instance C Int Char where ...
 396
 397 The point is that a->b, so Int in the first parameter must uniquely
 398 determine the second.  In general, given the same class decl, and given
 399
 400         instance C s1 s2 where ...
 401         instance C t1 t2 where ...
 402
 403 Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).
 404
 405 Matters are a little more complicated if there are free variables in
 406 the s2/t2.
 407
 408         class D a b c | a -> b
 409         instance D a b => D [(a,a)] [b] Int
 410         instance D a b => D [a]     [b] Bool
 411
 412 The instance decls don't overlap, because the third parameter keeps
 413 them separate.  But we want to make sure that given any constraint
 414         D s1 s2 s3
 415 if s1 matches
 416
 417
 418
 419
 420 \begin{code}
 421 badFunDeps :: ClsInstEnv -> Class
 422            -> TyVarSet -> [Type]        -- Proposed new instance type
 423            -> [DFunId]
 424 badFunDeps cls_inst_env clas ins_tv_set ins_tys
 425   = [ dfun_id | fd <- fds,
 426                (tvs, tys, dfun_id) <- cls_inst_env,
 427                not (null (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys))
 428     ]
 429   where
 430     (clas_tvs, fds) = classTvsFds clas
 431 \end{code}
 432
 433
 434 \begin{code}
 435 dupInstErr dfun1 dfun2 = addInstErr (ptext SLIT("Duplicate instance declarations:"))  dfun1 dfun2
 436 overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declarations:")) dfun1 dfun2
 437 fundepErr  dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 438                                     dfun1 dfun2
 439
 440 addInstErr what dfun1 dfun2
 441  = hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
 442   where
 443     ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys
 444                   where
 445                     (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
 446 \end{code}