ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcId, TcIdSet, tcInstId,
   4
   5         TcEnv, TyThing(..), TyThingDetails(..),
   6
   7         initEnv,
   8
   9         -- Getting stuff from the environment
  10         tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
  11
  12         -- Global environment
  13         tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
  14
  15         -- Local environment
  16         tcExtendKindEnv, tcExtendTyVarEnv,
  17         tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
  18
  19         -- Global type variables
  20         tcGetGlobalTyVars, tcExtendGlobalTyVars,
  21
  22         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  23         tcGetValueEnv,        tcSetValueEnv,
  24         tcAddImportedIdInfo,
  25
  26         tcLookupValue,      tcLookupValueMaybe,
  27         explicitLookupValue,
  28
  29         newLocalId, newSpecPragmaId,
  30         newDefaultMethodName, newDFunName,
  31
  32         InstEnv, emptyInstEnv, addToInstEnv,
  33         lookupInstEnv, InstLookupResult(..),
  34         tcGetInstEnv, tcSetInstEnv, classInstEnv,
  35
  36         badCon, badPrimOp
  37   ) where
  38
  39 #include "HsVersions.h"
  40
  41 import Id       ( mkUserLocal, isDataConWrapId_maybe )
  42 import MkId     ( mkSpecPragmaId )
  43 import Var      ( TyVar, Id, setVarName,
  44                   idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
  45                 )
  46 import TcType   ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
  47                   tcInstTyVars, zonkTcTyVars,
  48                   TcKind,
  49                 )
  50 import VarSet
  51 import Type     ( Kind, Type, superKind,
  52                   tyVarsOfType, tyVarsOfTypes,
  53                   splitForAllTys, splitRhoTy, splitFunTys,
  54                   splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
  55                 )
  56 import Subst    ( substTy )
  57 import UsageSPUtils ( unannotTy )
  58 import DataCon  ( DataCon )
  59 import TyCon    ( TyCon, tyConKind, tyConArity, isSynTyCon )
  60 import Class    ( Class, ClassOpItem, ClassContext, classTyCon )
  61
  62 import TcMonad
  63
  64 import IdInfo           ( vanillaIdInfo )
  65 import Name             ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
  66                           nameOccName, nameModule, getSrcLoc, mkGlobalName,
  67                           maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
  68                           NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
  69                                    extendNameEnv, extendNameEnvList
  70                         )
  71 import OccName          ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
  72 import Module           ( Module )
  73 import Unify            ( unifyTyListsX, matchTys )
  74 import Unique           ( pprUnique10, Unique, Uniquable(..) )
  75 import UniqFM
  76 import Unique           ( Uniquable(..) )
  77 import Util             ( zipEqual, zipWith3Equal, mapAccumL )
  78 import VarEnv           ( TyVarSubstEnv )
  79 import SrcLoc           ( SrcLoc )
  80 import FastString       ( FastString )
  81 import Maybes
  82 import Outputable
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection{TcEnv}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 data TcEnv
  93   = TcEnv {
  94         tcGST    :: GlobalSymbolTable,  -- The symbol table at the moment we began this compilation
  95
  96         tcInst   :: InstEnv,            -- All instances (both imported and in this module)
  97
  98         tcGEnv   :: NameEnv TyThing     -- The global type environment we've accumulated while
  99                                         -- compiling this module:
 100                                         --      types and classes (both imported and local)
 101                                         --      imported Ids
 102                                         -- (Ids defined in this module are in the local envt)
 103
 104         tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
 105                                         -- defined in this module
 106
 107         tcTyVars :: TcRef TcTyVarSet    -- The "global tyvars"
 108                                         -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
 109                                         -- mentioned in the types of Ids bound in tcLEnv
 110                                         -- Why mutable? see notes with tcGetGlobalTyVars
 111     }
 112
 113 \end{code}
 114
 115 The Global-Env/Local-Env story
 116 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 117 During type checking, we keep in the GlobalEnv
 118         * All types and classes
 119         * All Ids derived from types and classes (constructors, selectors)
 120         * Imported Ids
 121
 122 At the end of type checking, we zonk the local bindings,
 123 and as we do so we add to the GlobalEnv
 124         * Locally defined top-level Ids
 125
 126 Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
 127 used thus:
 128         a) fed back (via the knot) to typechecking the
 129            unfoldings of interface signatures
 130
 131         b) used to augment the GlobalSymbolTable
 132
 133
 134 \begin{code}
 135 data TcTyThing
 136   = AGlobal TyThing     -- Used only in the return type of a lookup
 137   | ATcId  TcId         -- Ids defined in this module
 138   | ATyVar TyVar        -- Type variables
 139   | AThing TcKind       -- Used temporarily, during kind checking
 140 -- Here's an example of how the AThing guy is used
 141 -- Suppose we are checking (forall a. T a Int):
 142 --      1. We first bind (a -> AThink kv), where kv is a kind variable.
 143 --      2. Then we kind-check the (T a Int) part.
 144 --      3. Then we zonk the kind variable.
 145 --      4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 146
 147 initEnv :: GlobalSymbolTable -> InstEnv -> NF_TcM TcEnv
 148 initEnv gst inst_env
 149   = tcNewMutVar emptyVarSet     `thenNF_Tc` \ gtv_var ->
 150     returnTc (TcEnv { tcGST = gst,
 151                       tcGEnv = emptyNameEnv,
 152                       tcInst = inst_env,
 153                       tcLEnv = emptyNameEnv,
 154                       tcTyVars = gtv_var
 155              })
 156
 157 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
 158 tcEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
 159 tcEnvIds     env = [id | AnId   id <- nameEnvElts (tcGEnv env)]
 160 tcEnvTyVars  env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
 161 tcEnvTcIds   env = [id | ATcId  id <- nameEnvElts (tcLEnv env)]
 162
 163 -- This data type is used to help tie the knot
 164 -- when type checking type and class declarations
 165 data TyThingDetails = SynTyDetails Type
 166                     | DataTyDetails ClassContext [DataCon] [Class]
 167                     | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
 168 \end{code}
 169
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{Basic lookups}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 lookup_global :: TcEnv -> Name -> Maybe TyThing
 179 lookup_global env name
 180   =     -- Try the global envt
 181     case lookupNameEnv (tcGEnv env) name of {
 182         Just thing -> Just thing ;
 183         Nothing    ->
 184
 185         -- Try the global symbol table
 186     case lookupModuleEnv (tcGST env) of {
 187         Nothing   -> Nothing ;
 188         Just genv -> lookupNameEnv genv name
 189     }}
 190
 191 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
 192 lookup_local env name
 193  = case lookupNameEnv (tcLEnv env) name of
 194         Just thing -> Just thing ;
 195         Nothing    -> case lookup_global env name of
 196                         Just thing -> AGlobal thing
 197                         Nothing    -> Nothing
 198 \end{code}
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection{TcId}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207
 208 \begin{code}
 209 type TcId    = Id                       -- Type may be a TcType
 210 type TcIdSet = IdSet
 211
 212 -- A useful function that takes an occurrence of a global thing
 213 -- and instantiates its type with fresh type variables
 214 tcInstId :: Id
 215          -> NF_TcM ([TcTyVar],  -- It's instantiated type
 216                       TcThetaType,      --
 217                       TcType)           --
 218 tcInstId id
 219   = let
 220       (tyvars, rho) = splitForAllTys (idType id)
 221     in
 222     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 223     let
 224         rho'           = substTy tenv rho
 225         (theta', tau') = splitRhoTy rho'
 226     in
 227     returnNF_Tc (tyvars', theta', tau')
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection{The global environment}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 \begin{code}
 238 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
 239 tcExtendGlobalEnv bindings thing_inside
 240   = tcGetEnv                            `thenNF_Tc` \ env ->
 241     let
 242         ge' = extendNameEnvList (tcGEnv env) bindings
 243     in
 244     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 245
 246 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 247 tcExtendGlobalValEnv ids thing_inside
 248   = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
 249 \end{code}
 250
 251
 252 \begin{code}
 253 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
 254 tcLookupGlobal_maybe name
 255   = tcGetEnv            `thenNF_Tc` \ env ->
 256     returnNF_Tc (lookup_global env name)
 257 \end{code}
 258
 259 A variety of global lookups, when we know what we are looking for.
 260
 261 \begin{code}
 262 tcLookupGlobal :: Name -> NF_TcM TyThing
 263   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
 264     case maybe_thing of
 265         Just thing -> returnNF_Tc thing
 266         other      -> notFound "tcLookupGlobal:" name
 267
 268 tcLookupGlobalId :: Name -> NF_TcM Id
 269 tcLookupGlobalId name
 270   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
 271     case maybe_id of
 272         Just (AnId clas) -> returnNF_Tc id
 273         other            -> notFound "tcLookupGlobalId:" name
 274
 275 tcLookupDataCon :: Name -> TcM DataCon
 276 tcLookupDataCon con_name
 277   = tcLookupGlobalId con_name           `thenNF_Tc` \ con_id ->
 278     case isDataConWrapId_maybe con_id of {
 279         Just data_con -> returnTc data_con
 280         Nothing       -> failWithTc (badCon con_id);
 281
 282
 283 tcLookupClass :: Name -> NF_TcM Class
 284 tcLookupClass name
 285   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
 286     case maybe_clas of
 287         Just (AClass clas) -> returnNF_Tc clas
 288         other              -> notFound "tcLookupClass:" name
 289
 290 tcLookupTyCon :: Name -> NF_TcM TyCon
 291 tcLookupTyCon name
 292   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
 293     case maybe_tc of
 294         Just (ATyCon tc) -> returnNF_Tc tc
 295         other            -> notFound "tcLookupTyCon:" name
 296 \end{code}
 297
 298
 299 %************************************************************************
 300 %*                                                                      *
 301 \subsection{The local environment}
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 \begin{code}
 306 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 307 tcExtendKindEnv pairs thing_inside
 308   = tcGetEnv                            `thenNF_Tc` \ env ->
 309     let
 310         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
 311         -- No need to extend global tyvars for kind checking
 312     in
 313     tcSetEnv (env {tcLEnv = le'}) thing_inside
 314
 315 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 316 tcExtendTyVarEnv tyvars thing_inside
 317   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = (in_scope_tvs, gtvs)}) ->
 318     let
 319         le'           = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
 320         new_tv_set    = mkVarSet tyvars
 321     in
 322         -- It's important to add the in-scope tyvars to the global tyvar set
 323         -- as well.  Consider
 324         --      f (x::r) = let g y = y::r in ...
 325         -- Here, g mustn't be generalised.  This is also important during
 326         -- class and instance decls, when we mustn't generalise the class tyvars
 327         -- when typechecking the methods.
 328     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
 329     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 330
 331 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
 332 --      the signature tyvars contain the original names
 333 --      the instance  tyvars are what those names should be mapped to
 334 -- It's needed when typechecking the method bindings of class and instance decls
 335 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
 336
 337 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
 338 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
 339   = tcGetEnv                                    `thenNF_Tc` \ env ->
 340     let
 341         le'   = extendNameEnvList (tcLEnv env) stuff
 342         stuff = [ (getName sig_tv, ATyVar inst_tv)
 343                 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
 344                 ]
 345     in
 346     tcSetEnv (env {tcLEnv = le'}) thing_inside
 347 \end{code}
 348
 349
 350 \begin{code}
 351 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
 352 tcExtendLocalValEnv names_w_ids thing_inside
 353   = tcGetEnv            `thenNF_Tc` \ env ->
 354     let
 355         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 356         extra_env           = [(name, ATcId id) | (name,id) <- names_w_ids]
 357         le'                 = extendNameEnvList (tcLEnv env) extra_env
 358     in
 359     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
 360     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{The global tyvars}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 tcExtendGlobalTyVars extra_global_tvs thing_inside
 372   = tcGetEnv                                            `thenNF_Tc` \ env ->
 373     tc_extend_gtvs (tcTyVars env) extra_global_tvs      `thenNF_Tc` \ gtvs' ->
 374     tcSetEnv (env {tcTyVars = gtvs') thing_inside
 375
 376 tc_extend_gtvs gtvs extra_global_tvs
 377   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 378     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
 379 \end{code}
 380
 381 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 382 To improve subsequent calls to the same function it writes the zonked set back into
 383 the environment.
 384
 385 \begin{code}
 386 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
 387 tcGetGlobalTyVars
 388   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
 389     tcReadMutVar gtv_var                        `thenNF_Tc` \ global_tvs ->
 390     zonkTcTyVars (varSetElems global_tvs)       `thenNF_Tc` \ global_tys' ->
 391     let
 392         global_tvs' = (tyVarsOfTypes global_tys')
 393     in
 394     tcWriteMutVar gtv_var global_tvs'           `thenNF_Tc_`
 395     returnNF_Tc global_tvs'
 396 \end{code}
 397
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection{The local environment}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405 \begin{code}
 406 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
 407 tcLookup_maybe name
 408   = tcGetEnv            `thenNF_Tc` \ env ->
 409     returnNF_Tc (lookup_local env name)
 410
 411 tcLookup :: Name -> NF_TcM TcTyThing
 412 tcLookup name
 413   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
 414     case maybe_thing of
 415         Just thing -> returnNF_Tc thing
 416         other      -> notFound "tcLookup:" name
 417
 418
 419
 420 tcGetValueEnv :: NF_TcM ValueEnv
 421 tcGetValueEnv
 422   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
 423     returnNF_Tc ve
 424
 425
 426 tcSetValueEnv :: ValueEnv -> TcM a -> TcM a
 427 tcSetValueEnv ve thing_inside
 428   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
 429     tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside
 430
 431 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 432 explicitLookupValue ve name
 433   = case maybeWiredInIdName name of
 434         Just id -> Just id
 435         Nothing -> lookupNameEnv ve name
 436
 437         -- Extract the IdInfo from an IfaceSig imported from an interface file
 438 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 439 tcAddImportedIdInfo unf_env id
 440   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 441                                 -- have explicit local definitions, so we get a black hole!
 442   = id
 443   | otherwise
 444   = id `lazySetIdInfo` new_info
 445         -- The Id must be returned without a data dependency on maybe_id
 446   where
 447     new_info = case explicitLookupValue unf_env (getName id) of
 448                      Nothing          -> vanillaIdInfo
 449                      Just imported_id -> idInfo imported_id
 450                 -- ToDo: could check that types are the same
 451 \end{code}
 452
 453
 454 %************************************************************************
 455 %*                                                                      *
 456 \subsection{The instance environment}
 457 %*                                                                      *
 458 %************************************************************************
 459
 460 Constructing new Ids
 461
 462 \begin{code}
 463 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
 464 newLocalId name ty loc
 465   = tcGetUnique         `thenNF_Tc` \ uniq ->
 466     returnNF_Tc (mkUserLocal name uniq ty loc)
 467
 468 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
 469 newSpecPragmaId name ty
 470   = tcGetUnique         `thenNF_Tc` \ uniq ->
 471     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 472 \end{code}
 473
 474 Make a name for the dict fun for an instance decl
 475
 476 \begin{code}
 477 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
 478 newDFunName mod clas (ty:_) loc
 479   = tcGetDFunUniq dfun_string   `thenNF_Tc` \ inst_uniq ->
 480     tcGetUnique                 `thenNF_Tc` \ uniq ->
 481     returnNF_Tc (mkGlobalName uniq mod
 482                               (mkDFunOcc dfun_string inst_uniq)
 483                               (LocalDef loc Exported))
 484   where
 485         -- Any string that is somewhat unique will do
 486     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 487
 488 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
 489 newDefaultMethodName op_name loc
 490   = tcGetUnique                 `thenNF_Tc` \ uniq ->
 491     returnNF_Tc (mkGlobalName uniq (nameModule op_name)
 492                               (mkDefaultMethodOcc (getOccName op_name))
 493                               (LocalDef loc Exported))
 494 \end{code}
 495
 496
 497 %************************************************************************
 498 %*                                                                      *
 499 \subsection{The instance environment}
 500 %*                                                                      *
 501 %************************************************************************
 502
 503 \begin{code}
 504 tcGetInstEnv :: NF_TcM InstEnv
 505 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
 506                returnNF_Tc ie
 507
 508 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 509 tcSetInstEnv ie thing_inside
 510   = tcGetEnv    `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
 511     tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside
 512 \end{code}
 513
 514
 515 \begin{code}
 516 type InstEnv    = UniqFM ClsInstEnv             -- Maps Class to instances for that class
 517 type ClsInstEnv = [(TyVarSet, [Type], Id)]      -- The instances for a particular class
 518
 519 classInstEnv :: InstEnv -> Class -> ClsInstEnv
 520 classInstEnv env cls = lookupWithDefaultUFM env [] cls
 521 \end{code}
 522
 523 A @ClsInstEnv@ lives inside a class, and identifies all the instances
 524 of that class.  The @Id@ inside a ClsInstEnv mapping is the dfun for
 525 that instance.
 526
 527 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
 528
 529         forall a b, C t1 t2 t3  can be constructed by dfun
 530
 531 or, to put it another way, we have
 532
 533         instance (...) => C t1 t2 t3,  witnessed by dfun
 534
 535 There is an important consistency constraint in the elements of a ClsInstEnv:
 536
 537   * [a,b] must be a superset of the free vars of [t1,t2,t3]
 538
 539   * The dfun must itself be quantified over [a,b]
 540
 541 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
 542         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 543 The "a" in the pattern must be one of the forall'd variables in
 544 the dfun type.
 545
 546
 547
 548 Notes on overlapping instances
 549 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 550 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
 551
 552 In others, overlap is permitted, but only in such a way that one can make
 553 a unique choice when looking up.  That is, overlap is only permitted if
 554 one template matches the other, or vice versa.  So this is ok:
 555
 556   [a]  [Int]
 557
 558 but this is not
 559
 560   (Int,a)  (b,Int)
 561
 562 If overlap is permitted, the list is kept most specific first, so that
 563 the first lookup is the right choice.
 564
 565
 566 For now we just use association lists.
 567
 568 \subsection{Avoiding a problem with overlapping}
 569
 570 Consider this little program:
 571
 572 \begin{pseudocode}
 573      class C a        where c :: a
 574      class C a => D a where d :: a
 575
 576      instance C Int where c = 17
 577      instance D Int where d = 13
 578
 579      instance C a => C [a] where c = [c]
 580      instance ({- C [a], -} D a) => D [a] where d = c
 581
 582      instance C [Int] where c = [37]
 583
 584      main = print (d :: [Int])
 585 \end{pseudocode}
 586
 587 What do you think `main' prints  (assuming we have overlapping instances, and
 588 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
 589 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
 590 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
 591 the `C [Int]' instance is more specific).
 592
 593 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
 594 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
 595 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
 596 doesn't even compile!  What's going on!?
 597
 598 What hugs complains about is the `D [a]' instance decl.
 599
 600 \begin{pseudocode}
 601      ERROR "mj.hs" (line 10): Cannot build superclass instance
 602      *** Instance            : D [a]
 603      *** Context supplied    : D a
 604      *** Required superclass : C [a]
 605 \end{pseudocode}
 606
 607 You might wonder what hugs is complaining about.  It's saying that you
 608 need to add `C [a]' to the context of the `D [a]' instance (as appears
 609 in comments).  But there's that `C [a]' instance decl one line above
 610 that says that I can reduce the need for a `C [a]' instance to the
 611 need for a `C a' instance, and in this case, I already have the
 612 necessary `C a' instance (since we have `D a' explicitly in the
 613 context, and `C' is a superclass of `D').
 614
 615 Unfortunately, the above reasoning indicates a premature commitment to the
 616 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
 617 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
 618 add the context that hugs suggests (uncomment the `C [a]'), effectively
 619 deferring the decision about which instance to use.
 620
 621 Now, interestingly enough, 4.04 has this same bug, but it's covered up
 622 in this case by a little known `optimization' that was disabled in
 623 4.06.  Ghc-4.04 silently inserts any missing superclass context into
 624 an instance declaration.  In this case, it silently inserts the `C
 625 [a]', and everything happens to work out.
 626
 627 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
 628 `Mark Jones', although Mark claims no credit for the `optimization' in
 629 question, and would rather it stopped being called the `Mark Jones
 630 optimization' ;-)
 631
 632 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
 633 something else out with ghc-4.04.  Let's add the following line:
 634
 635     d' :: D a => [a]
 636     d' = c
 637
 638 Everyone raise their hand who thinks that `d :: [Int]' should give a
 639 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
 640 `optimization' only applies to instance decls, not to regular
 641 bindings, giving inconsistent behavior.
 642
 643 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
 644 list of instances for a given class is ordered, so that more specific
 645 instances come before more generic ones.  For example, the instance
 646 list for C might contain:
 647     ..., C Int, ..., C a, ...
 648 When we go to look for a `C Int' instance we'll get that one first.
 649 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
 650 pass the `C Int' instance, and keep going.  But if `b' is
 651 unconstrained, then we don't know yet if the more specific instance
 652 will eventually apply.  GHC keeps going, and matches on the generic `C
 653 a'.  The fix is to, at each step, check to see if there's a reverse
 654 match, and if so, abort the search.  This prevents hugs from
 655 prematurely chosing a generic instance when a more specific one
 656 exists.
 657
 658 --Jeff
 659
 660 \begin{code}
 661 emptyInstEnv :: InstEnv
 662 emptyInstEnv = emptyUFM
 663 \end{code}
 664
 665 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
 666 the env is kept ordered, the first match must be the only one.  The
 667 thing we are looking up can have an arbitrary "flexi" part.
 668
 669 \begin{code}
 670 lookupInstEnv :: InstEnv                        -- The envt
 671               -> Class -> [Type]        -- Key
 672               -> InstLookupResult
 673
 674 data InstLookupResult
 675   = FoundInst                   -- There is a (template,substitution) pair
 676                                 -- that makes the template match the key,
 677                                 -- and no template is an instance of the key
 678         TyVarSubstEnv Id
 679
 680   | NoMatch Bool        -- Boolean is true iff there is at least one
 681                         -- template that matches the key.
 682                         -- (but there are other template(s) that are
 683                         --  instances of the key, so we don't report
 684                         --  FoundInst)
 685         -- The NoMatch True case happens when we look up
 686         --      Foo [a]
 687         -- in an InstEnv that has entries for
 688         --      Foo [Int]
 689         --      Foo [b]
 690         -- Then which we choose would depend on the way in which 'a'
 691         -- is instantiated.  So we say there is no match, but identify
 692         -- it as ambiguous case in the hope of giving a better error msg.
 693         -- See the notes above from Jeff Lewis
 694
 695 lookupInstEnv env key_cls key_tys
 696   = find (classInstEnv env key_cls)
 697   where
 698     key_vars = tyVarsOfTypes key_tys
 699
 700     find [] = NoMatch False
 701     find ((tpl_tyvars, tpl, val) : rest)
 702       = case matchTys tpl_tyvars tpl key_tys of
 703           Nothing                 ->
 704             case matchTys key_vars key_tys tpl of
 705               Nothing             -> find rest
 706               Just (_, _)         -> NoMatch (any_match rest)
 707           Just (subst, leftovers) -> ASSERT( null leftovers )
 708                                      FoundInst subst val
 709
 710     any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
 711                         | (tvs,tpl,_) <- rest
 712                         ]
 713 \end{code}
 714
 715 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
 716
 717 A boolean flag controls overlap reporting.
 718
 719 True => overlap is permitted, but only if one template matches the other;
 720         not if they unify but neither is
 721
 722 \begin{code}
 723 addToInstEnv :: Bool                                    -- True <=> overlap permitted
 724              -> InstEnv                                 -- Envt
 725              -> Class -> [TyVar] -> [Type] -> Id        -- New item
 726              -> MaybeErr InstEnv                        -- Success...
 727                          ([Type], Id)                   -- Failure: Offending overlap
 728
 729 addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
 730   = case insert_into (classInstEnv inst_env clas) of
 731         Failed stuff      -> Failed stuff
 732         Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
 733
 734   where
 735     ins_tv_set = mkVarSet ins_tvs
 736     ins_item = (ins_tv_set, ins_tys, value)
 737
 738     insert_into [] = returnMaB [ins_item]
 739     insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
 740
 741         -- FAIL if:
 742         -- (a) they are the same, or
 743         -- (b) they unify, and any sort of overlap is prohibited,
 744         -- (c) they unify but neither is more specific than t'other
 745       |  identical
 746       || (unifiable && not overlap_ok)
 747       || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
 748       =  failMaB (tpl_tys, val)
 749
 750         -- New item is an instance of current item, so drop it here
 751       | ins_item_more_specific  = returnMaB (ins_item : env)
 752
 753         -- Otherwise carry on
 754       | otherwise  = insert_into rest     `thenMaB` \ rest' ->
 755                      returnMaB (cur_item : rest')
 756       where
 757         unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
 758         ins_item_more_specific = maybeToBool (matchTys tpl_tvs    tpl_tys ins_tys)
 759         cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
 760         identical = ins_item_more_specific && cur_item_more_specific
 761 \end{code}
 762
 763
 764 %************************************************************************
 765 %*                                                                      *
 766 \subsection{Errors}
 767 %*                                                                      *
 768 %************************************************************************
 769
 770 \begin{code}
 771 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 772 badPrimOp op  = quotes (ppr op) <+> ptext SLIT("is not a primop")
 773
 774 notFound where name
 775   = failWithTc (text where <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope"))
 776 \end{code}