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