ghc/compiler/typecheck/TcEnv.lhs

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