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