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     def = pprPanic "tcLookupValue:" (ppr name)
 402
 403 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
 404 tcLookupValueMaybe name
 405   = case maybeWiredInIdName name of
 406         Just id -> returnNF_Tc (Just id)
 407         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
 408                    returnNF_Tc (lookupNameEnv ve name)
 409
 410 tcLookupValueByKey :: Unique -> NF_TcM s Id     -- Panics if not found
 411 tcLookupValueByKey key
 412   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
 413     returnNF_Tc (explicitLookupValueByKey ve key)
 414
 415 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 416 tcLookupValueByKeyMaybe key
 417   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
 418     returnNF_Tc (lookupUFM_Directly ve key)
 419
 420 tcGetValueEnv :: NF_TcM s ValueEnv
 421 tcGetValueEnv
 422   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
 423     returnNF_Tc ve
 424
 425
 426 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
 427 tcSetValueEnv ve scope
 428   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
 429     tcSetEnv (TcEnv ue te ve ie gtvs) scope
 430
 431 -- Non-monadic version, environment given explicitly
 432 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
 433 explicitLookupValueByKey ve key
 434   = lookupWithDefaultUFM_Directly ve def key
 435   where
 436     def = pprPanic "lookupValueByKey:" (pprUnique10 key)
 437
 438 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 439 explicitLookupValue ve name
 440   = case maybeWiredInIdName name of
 441         Just id -> Just id
 442         Nothing -> lookupNameEnv ve name
 443
 444         -- Extract the IdInfo from an IfaceSig imported from an interface file
 445 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 446 tcAddImportedIdInfo unf_env id
 447   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 448                                 -- have explicit local definitions, so we get a black hole!
 449   = id
 450   | otherwise
 451   = id `lazySetIdInfo` new_info
 452         -- The Id must be returned without a data dependency on maybe_id
 453   where
 454     new_info = case explicitLookupValue unf_env (getName id) of
 455                      Nothing          -> vanillaIdInfo
 456                      Just imported_id -> idInfo imported_id
 457                 -- ToDo: could check that types are the same
 458 \end{code}
 459
 460 Constructing new Ids
 461
 462 \begin{code}
 463 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s 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 s 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
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{The instance environment}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 tcGetInstEnv :: NF_TcM s InstEnv
 483 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
 484                returnNF_Tc ie
 485
 486 tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a
 487 tcSetInstEnv ie scope
 488   = tcGetEnv    `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
 489     tcSetEnv (TcEnv ue te ve ie gtvs) scope
 490 \end{code}
 491
 492
 493 \begin{code}
 494 type InstEnv    = UniqFM ClsInstEnv             -- Maps Class to instances for that class
 495 type ClsInstEnv = [(TyVarSet, [Type], Id)]      -- The instances for a particular class
 496
 497 classInstEnv :: InstEnv -> Class -> ClsInstEnv
 498 classInstEnv env cls = lookupWithDefaultUFM env [] cls
 499 \end{code}
 500
 501 A @ClsInstEnv@ lives inside a class, and identifies all the instances
 502 of that class.  The @Id@ inside a ClsInstEnv mapping is the dfun for
 503 that instance.
 504
 505 If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
 506
 507         forall a b, C t1 t2 t3  can be constructed by dfun
 508
 509 or, to put it another way, we have
 510
 511         instance (...) => C t1 t2 t3,  witnessed by dfun
 512
 513 There is an important consistency constraint in the elements of a ClsInstEnv:
 514
 515   * [a,b] must be a superset of the free vars of [t1,t2,t3]
 516
 517   * The dfun must itself be quantified over [a,b]
 518
 519 Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
 520         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 521 The "a" in the pattern must be one of the forall'd variables in
 522 the dfun type.
 523
 524
 525
 526 Notes on overlapping instances
 527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 528 In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
 529
 530 In others, overlap is permitted, but only in such a way that one can make
 531 a unique choice when looking up.  That is, overlap is only permitted if
 532 one template matches the other, or vice versa.  So this is ok:
 533
 534   [a]  [Int]
 535
 536 but this is not
 537
 538   (Int,a)  (b,Int)
 539
 540 If overlap is permitted, the list is kept most specific first, so that
 541 the first lookup is the right choice.
 542
 543
 544 For now we just use association lists.
 545
 546 \subsection{Avoiding a problem with overlapping}
 547
 548 Consider this little program:
 549
 550 \begin{pseudocode}
 551      class C a        where c :: a
 552      class C a => D a where d :: a
 553
 554      instance C Int where c = 17
 555      instance D Int where d = 13
 556
 557      instance C a => C [a] where c = [c]
 558      instance ({- C [a], -} D a) => D [a] where d = c
 559
 560      instance C [Int] where c = [37]
 561
 562      main = print (d :: [Int])
 563 \end{pseudocode}
 564
 565 What do you think `main' prints  (assuming we have overlapping instances, and
 566 all that turned on)?  Well, the instance for `D' at type `[a]' is defined to
 567 be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
 568 answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
 569 the `C [Int]' instance is more specific).
 570
 571 Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That
 572 was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old
 573 hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
 574 doesn't even compile!  What's going on!?
 575
 576 What hugs complains about is the `D [a]' instance decl.
 577
 578 \begin{pseudocode}
 579      ERROR "mj.hs" (line 10): Cannot build superclass instance
 580      *** Instance            : D [a]
 581      *** Context supplied    : D a
 582      *** Required superclass : C [a]
 583 \end{pseudocode}
 584
 585 You might wonder what hugs is complaining about.  It's saying that you
 586 need to add `C [a]' to the context of the `D [a]' instance (as appears
 587 in comments).  But there's that `C [a]' instance decl one line above
 588 that says that I can reduce the need for a `C [a]' instance to the
 589 need for a `C a' instance, and in this case, I already have the
 590 necessary `C a' instance (since we have `D a' explicitly in the
 591 context, and `C' is a superclass of `D').
 592
 593 Unfortunately, the above reasoning indicates a premature commitment to the
 594 generic `C [a]' instance.  I.e., it prematurely rules out the more specific
 595 instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to
 596 add the context that hugs suggests (uncomment the `C [a]'), effectively
 597 deferring the decision about which instance to use.
 598
 599 Now, interestingly enough, 4.04 has this same bug, but it's covered up
 600 in this case by a little known `optimization' that was disabled in
 601 4.06.  Ghc-4.04 silently inserts any missing superclass context into
 602 an instance declaration.  In this case, it silently inserts the `C
 603 [a]', and everything happens to work out.
 604
 605 (See `basicTypes/MkId:mkDictFunId' for the code in question.  Search for
 606 `Mark Jones', although Mark claims no credit for the `optimization' in
 607 question, and would rather it stopped being called the `Mark Jones
 608 optimization' ;-)
 609
 610 So, what's the fix?  I think hugs has it right.  Here's why.  Let's try
 611 something else out with ghc-4.04.  Let's add the following line:
 612
 613     d' :: D a => [a]
 614     d' = c
 615
 616 Everyone raise their hand who thinks that `d :: [Int]' should give a
 617 different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The
 618 `optimization' only applies to instance decls, not to regular
 619 bindings, giving inconsistent behavior.
 620
 621 Old hugs had this same bug.  Here's how we fixed it: like GHC, the
 622 list of instances for a given class is ordered, so that more specific
 623 instances come before more generic ones.  For example, the instance
 624 list for C might contain:
 625     ..., C Int, ..., C a, ...
 626 When we go to look for a `C Int' instance we'll get that one first.
 627 But what if we go looking for a `C b' (`b' is unconstrained)?  We'll
 628 pass the `C Int' instance, and keep going.  But if `b' is
 629 unconstrained, then we don't know yet if the more specific instance
 630 will eventually apply.  GHC keeps going, and matches on the generic `C
 631 a'.  The fix is to, at each step, check to see if there's a reverse
 632 match, and if so, abort the search.  This prevents hugs from
 633 prematurely chosing a generic instance when a more specific one
 634 exists.
 635
 636 --Jeff
 637
 638 \begin{code}
 639 emptyInstEnv :: InstEnv
 640 emptyInstEnv = emptyUFM
 641 \end{code}
 642
 643 @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since
 644 the env is kept ordered, the first match must be the only one.  The
 645 thing we are looking up can have an arbitrary "flexi" part.
 646
 647 \begin{code}
 648 lookupInstEnv :: InstEnv                        -- The envt
 649               -> Class -> [Type]        -- Key
 650               -> InstLookupResult
 651
 652 data InstLookupResult
 653   = FoundInst                   -- There is a (template,substitution) pair
 654                                 -- that makes the template match the key,
 655                                 -- and no template is an instance of the key
 656         TyVarSubstEnv Id
 657
 658   | NoMatch Bool        -- Boolean is true iff there is at least one
 659                         -- template that matches the key.
 660                         -- (but there are other template(s) that are
 661                         --  instances of the key, so we don't report
 662                         --  FoundInst)
 663         -- The NoMatch True case happens when we look up
 664         --      Foo [a]
 665         -- in an InstEnv that has entries for
 666         --      Foo [Int]
 667         --      Foo [b]
 668         -- Then which we choose would depend on the way in which 'a'
 669         -- is instantiated.  So we say there is no match, but identify
 670         -- it as ambiguous case in the hope of giving a better error msg.
 671         -- See the notes above from Jeff Lewis
 672
 673 lookupInstEnv env key_cls key_tys
 674   = find (classInstEnv env key_cls)
 675   where
 676     key_vars = tyVarsOfTypes key_tys
 677
 678     find [] = NoMatch False
 679     find ((tpl_tyvars, tpl, val) : rest)
 680       = case matchTys tpl_tyvars tpl key_tys of
 681           Nothing                 ->
 682             case matchTys key_vars key_tys tpl of
 683               Nothing             -> find rest
 684               Just (_, _)         -> NoMatch (any_match rest)
 685           Just (subst, leftovers) -> ASSERT( null leftovers )
 686                                      FoundInst subst val
 687
 688     any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
 689                         | (tvs,tpl,_) <- rest
 690                         ]
 691 \end{code}
 692
 693 @addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
 694
 695 A boolean flag controls overlap reporting.
 696
 697 True => overlap is permitted, but only if one template matches the other;
 698         not if they unify but neither is
 699
 700 \begin{code}
 701 addToInstEnv :: Bool                                    -- True <=> overlap permitted
 702              -> InstEnv                                 -- Envt
 703              -> Class -> [TyVar] -> [Type] -> Id        -- New item
 704              -> MaybeErr InstEnv                        -- Success...
 705                          ([Type], Id)                   -- Failure: Offending overlap
 706
 707 addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
 708   = case insert_into (classInstEnv inst_env clas) of
 709         Failed stuff      -> Failed stuff
 710         Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
 711
 712   where
 713     ins_tv_set = mkVarSet ins_tvs
 714     ins_item = (ins_tv_set, ins_tys, value)
 715
 716     insert_into [] = returnMaB [ins_item]
 717     insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
 718
 719         -- FAIL if:
 720         -- (a) they are the same, or
 721         -- (b) they unify, and any sort of overlap is prohibited,
 722         -- (c) they unify but neither is more specific than t'other
 723       |  identical
 724       || (unifiable && not overlap_ok)
 725       || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
 726       =  failMaB (tpl_tys, val)
 727
 728         -- New item is an instance of current item, so drop it here
 729       | ins_item_more_specific  = returnMaB (ins_item : env)
 730
 731         -- Otherwise carry on
 732       | otherwise  = insert_into rest     `thenMaB` \ rest' ->
 733                      returnMaB (cur_item : rest')
 734       where
 735         unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
 736         ins_item_more_specific = maybeToBool (matchTys tpl_tvs    tpl_tys ins_tys)
 737         cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
 738         identical = ins_item_more_specific && cur_item_more_specific
 739 \end{code}
 740
 741 Make a name for the dict fun for an instance decl
 742
 743 \begin{code}
 744 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM s Name
 745 newDFunName mod clas (ty:_) loc
 746   = tcGetDFunUniq dfun_string   `thenNF_Tc` \ inst_uniq ->
 747     tcGetUnique                 `thenNF_Tc` \ uniq ->
 748     returnNF_Tc (mkGlobalName uniq mod
 749                               (mkDFunOcc dfun_string inst_uniq)
 750                               (LocalDef loc Exported))
 751   where
 752         -- Any string that is somewhat unique will do
 753     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 754
 755 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM s Name
 756 newDefaultMethodName op_name loc
 757   = tcGetUnique                 `thenNF_Tc` \ uniq ->
 758     returnNF_Tc (mkGlobalName uniq (nameModule op_name)
 759                               (mkDefaultMethodOcc (getOccName op_name))
 760                               (LocalDef loc Exported))
 761 \end{code}
 762
 763
 764 %************************************************************************
 765 %*                                                                      *
 766 \subsection{Errors}
 767 %*                                                                      *
 768 %************************************************************************
 769
 770 \begin{code}
 771 badCon con_id
 772   = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 773 badPrimOp op
 774   = quotes (ppr op) <+> ptext SLIT("is not a primop")
 775
 776 uvNameOutOfScope name
 777   = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
 778
 779 tyNameOutOfScope name
 780   = quotes (ppr name) <+> ptext SLIT("is not in scope")
 781 \end{code}