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