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