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