ghc/compiler/typecheck/TcEnv.lhs

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