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 )
  20 import Var              ( Id )
  21 import VarSet           ( TyVarSet, unionVarSet, mkVarSet, varSetElems )
  22 import VarEnv           ( TyVarSubstEnv )
  23 import Maybes           ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
  24 import Name             ( getSrcLoc )
  25 import Type             ( Type, tyConAppTyCon,
  26                           splitSigmaTy, splitDFunTy, tyVarsOfTypes
  27                         )
  28 import PprType          ( )
  29 import TyCon            ( TyCon )
  30 import Outputable
  31 import Unify            ( matchTys, unifyTyListsX )
  32 import UniqFM           ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
  33 import Id               ( idType )
  34 import ErrUtils         ( Message )
  35 import CmdLineOpts
  36 \end{code}
  37
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection{The key types}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 type DFunId     = Id
  47
  48 type InstEnv    = UniqFM ClsInstEnv             -- Maps Class to instances for that class
  49
  50 type ClsInstEnv = [(TyVarSet, [Type], DFunId)]  -- The instances for a particular class
  51
  52 simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
  53 simpleDFunClassTyCon dfun
  54   = (clas, tycon)
  55   where
  56     (_,_,clas,[ty]) = splitDFunTy (idType dfun)
  57     tycon           = tyConAppTyCon ty
  58
  59 pprInstEnv :: InstEnv -> SDoc
  60 pprInstEnv env
  61   = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+>
  62            brackets (pprWithCommas ppr tys) <+> ppr dfun
  63          | cls_inst_env <-  eltsUFM env
  64          , (tyvars, tys, dfun) <- cls_inst_env
  65          ]
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{Instance environments: InstEnv and ClsInstEnv}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 The actual type declarations are in HscTypes.
  75
  76 \begin{code}
  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@ lives inside a class, and identifies all the instances
  85 of that class.  The @Id@ inside a ClsInstEnv mapping is the dfun for
  86 that instance.
  87
  88 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
  89
  90         forall a b, C t1 t2 t3  can be constructed by dfun
  91
  92 or, to put it another way, we have
  93
  94         instance (...) => C t1 t2 t3,  witnessed by dfun
  95
  96 There is an important consistency constraint in the elements of a ClsInstEnv:
  97
  98   * [a,b] must be a superset of the free vars of [t1,t2,t3]
  99
 100   * The dfun must itself be quantified over [a,b]
 101
 102 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
 103         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 104 The "a" in the pattern must be one of the forall'd variables in
 105 the dfun type.
 106
 107
 108
 109 Notes on overlapping instances
 110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 111 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
 112
 113 In others, overlap is permitted, but only in such a way that one can make
 114 a unique choice when looking up.  That is, overlap is only permitted if
 115 one template matches the other, or vice versa.  So this is ok:
 116
 117   [a]  [Int]
 118
 119 but this is not
 120
 121   (Int,a)  (b,Int)
 122
 123 If overlap is permitted, the list is kept most specific first, so that
 124 the first lookup is the right choice.
 125
 126
 127 For now we just use association lists.
 128
 129 \subsection{Avoiding a problem with overlapping}
 130
 131 Consider this little program:
 132
 133 \begin{pseudocode}
 134      class C a        where c :: a
 135      class C a => D a where d :: a
 136
 137      instance C Int where c = 17
 138      instance D Int where d = 13
 139
 140      instance C a => C [a] where c = [c]
 141      instance ({- C [a], -} D a) => D [a] where d = c
 142
 143      instance C [Int] where c = [37]
 144
 145      main = print (d :: [Int])
 146 \end{pseudocode}
 147
 148 What do you think `main' prints  (assuming we have overlapping instances, and
 149 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
 150 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
 151 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
 152 the `C [Int]' instance is more specific).
 153
 154 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
 155 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
 156 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
 157 doesn't even compile!  What's going on!?
 158
 159 What hugs complains about is the `D [a]' instance decl.
 160
 161 \begin{pseudocode}
 162      ERROR "mj.hs" (line 10): Cannot build superclass instance
 163      *** Instance            : D [a]
 164      *** Context supplied    : D a
 165      *** Required superclass : C [a]
 166 \end{pseudocode}
 167
 168 You might wonder what hugs is complaining about.  It's saying that you
 169 need to add `C [a]' to the context of the `D [a]' instance (as appears
 170 in comments).  But there's that `C [a]' instance decl one line above
 171 that says that I can reduce the need for a `C [a]' instance to the
 172 need for a `C a' instance, and in this case, I already have the
 173 necessary `C a' instance (since we have `D a' explicitly in the
 174 context, and `C' is a superclass of `D').
 175
 176 Unfortunately, the above reasoning indicates a premature commitment to the
 177 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
 178 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
 179 add the context that hugs suggests (uncomment the `C [a]'), effectively
 180 deferring the decision about which instance to use.
 181
 182 Now, interestingly enough, 4.04 has this same bug, but it's covered up
 183 in this case by a little known `optimization' that was disabled in
 184 4.06.  Ghc-4.04 silently inserts any missing superclass context into
 185 an instance declaration.  In this case, it silently inserts the `C
 186 [a]', and everything happens to work out.
 187
 188 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
 189 `Mark Jones', although Mark claims no credit for the `optimization' in
 190 question, and would rather it stopped being called the `Mark Jones
 191 optimization' ;-)
 192
 193 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
 194 something else out with ghc-4.04.  Let's add the following line:
 195
 196     d' :: D a => [a]
 197     d' = c
 198
 199 Everyone raise their hand who thinks that `d :: [Int]' should give a
 200 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
 201 `optimization' only applies to instance decls, not to regular
 202 bindings, giving inconsistent behavior.
 203
 204 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
 205 list of instances for a given class is ordered, so that more specific
 206 instances come before more generic ones.  For example, the instance
 207 list for C might contain:
 208     ..., C Int, ..., C a, ...
 209 When we go to look for a `C Int' instance we'll get that one first.
 210 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
 211 pass the `C Int' instance, and keep going.  But if `b' is
 212 unconstrained, then we don't know yet if the more specific instance
 213 will eventually apply.  GHC keeps going, and matches on the generic `C
 214 a'.  The fix is to, at each step, check to see if there's a reverse
 215 match, and if so, abort the search.  This prevents hugs from
 216 prematurely chosing a generic instance when a more specific one
 217 exists.
 218
 219 --Jeff
 220
 221
 222 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
 223 the env is kept ordered, the first match must be the only one.  The
 224 thing we are looking up can have an arbitrary "flexi" part.
 225
 226 \begin{code}
 227 lookupInstEnv :: InstEnv                        -- The envt
 228               -> Class -> [Type]        -- Key
 229               -> InstLookupResult
 230
 231 data InstLookupResult
 232   = FoundInst                   -- There is a (template,substitution) pair
 233                                 -- that makes the template match the key,
 234                                 -- and no template is an instance of the key
 235         TyVarSubstEnv Id
 236
 237   | NoMatch Bool        -- Boolean is true iff there is at least one
 238                         -- template that matches the key.
 239                         -- (but there are other template(s) that are
 240                         --  instances of the key, so we don't report
 241                         --  FoundInst)
 242         -- The NoMatch True case happens when we look up
 243         --      Foo [a]
 244         -- in an InstEnv that has entries for
 245         --      Foo [Int]
 246         --      Foo [b]
 247         -- Then which we choose would depend on the way in which 'a'
 248         -- is instantiated.  So we say there is no match, but identify
 249         -- it as ambiguous case in the hope of giving a better error msg.
 250         -- See the notes above from Jeff Lewis
 251
 252 lookupInstEnv env key_cls key_tys
 253   = find (classInstEnv env key_cls)
 254   where
 255     key_vars = tyVarsOfTypes key_tys
 256
 257     find [] = NoMatch False
 258     find ((tpl_tyvars, tpl, val) : rest)
 259       = case matchTys tpl_tyvars tpl key_tys of
 260           Nothing                 ->
 261             case matchTys key_vars key_tys tpl of
 262               Nothing             -> find rest
 263               Just (_, _)         -> NoMatch (any_match rest)
 264           Just (subst, leftovers) -> ASSERT( null leftovers )
 265                                      FoundInst subst val
 266
 267     any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
 268                         | (tvs,tpl,_) <- rest
 269                         ]
 270 \end{code}
 271
 272 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
 273
 274 A boolean flag controls overlap reporting.
 275
 276 True => overlap is permitted, but only if one template matches the other;
 277         not if they unify but neither is
 278
 279 \begin{code}
 280 extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message])
 281   -- Similar, but all we have is the DFuns
 282 extendInstEnv dflags env infos
 283   = go env [] infos
 284   where
 285     go env msgs []           = (env, msgs)
 286     go env msgs (dfun:dfuns) = case addToInstEnv dflags env dfun of
 287                                     Succeeded new_env -> go new_env msgs dfuns
 288                                     Failed dfun'      -> go env (msg:msgs) dfuns
 289                                                      where
 290                                                          msg = dupInstErr dfun dfun'
 291
 292
 293 dupInstErr dfun1 dfun2
 294         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 295   = hang (ptext SLIT("Duplicate or overlapping instance declarations:"))
 296        2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
 297   where
 298     ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau
 299                   where
 300                     (_,_,tau) = splitSigmaTy (idType dfun)
 301
 302 addToInstEnv :: DynFlags
 303              -> InstEnv -> DFunId
 304              -> MaybeErr InstEnv        -- Success...
 305                          DFunId         -- Failure: Offending overlap
 306
 307 addToInstEnv dflags inst_env dfun_id
 308   = case insert_into (classInstEnv inst_env clas) of
 309         Failed stuff      -> Failed stuff
 310         Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
 311
 312   where
 313     (ins_tvs, _, clas, ins_tys) = splitDFunTy (idType dfun_id)
 314
 315     ins_tv_set = mkVarSet ins_tvs
 316     ins_item = (ins_tv_set, ins_tys, dfun_id)
 317
 318     insert_into [] = returnMaB [ins_item]
 319     insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
 320
 321         -- FAIL if:
 322         -- (a) they are the same, or
 323         -- (b) they unify, and any sort of overlap is prohibited,
 324         -- (c) they unify but neither is more specific than t'other
 325       |  identical
 326       || (unifiable && not (dopt Opt_AllowOverlappingInstances dflags))
 327       || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
 328       =  failMaB val
 329
 330         -- New item is an instance of current item, so drop it here
 331       | ins_item_more_specific  = returnMaB (ins_item : env)
 332
 333         -- Otherwise carry on
 334       | otherwise  = insert_into rest     `thenMaB` \ rest' ->
 335                      returnMaB (cur_item : rest')
 336       where
 337         unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
 338         ins_item_more_specific = maybeToBool (matchTys tpl_tvs    tpl_tys ins_tys)
 339         cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
 340         identical = ins_item_more_specific && cur_item_more_specific
 341 \end{code}
 342
 343