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