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