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