ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
   4
   5         TcEnv,
   6
   7         initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
   8
   9         tcExtendTyVarEnv, tcLookupTyVar,
  10
  11         tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
  12         tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
  13         tcGetTyConsAndClasses,
  14
  15         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  16         tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
  17         tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
  18         tcAddImportedIdInfo, tcExplicitLookupGlobal,
  19         tcLookupGlobalValueByKeyMaybe,
  20
  21         newMonoIds, newLocalIds, newLocalId,
  22         tcGetGlobalTyVars, tcExtendGlobalTyVars
  23   ) where
  24
  25 #include "HsVersions.h"
  26
  27 import MkId     ( mkUserLocal, mkUserId )
  28 import Id       ( Id, GenId, idType, replaceIdInfo, idInfo )
  29 import TcKind   ( TcKind, kindToTcKind, Kind )
  30 import TcType   ( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType,
  31                   newTyVarTys, tcInstTyVars, zonkTcTyVars, tcInstType
  32                 )
  33 import TyVar    ( mkTyVarSet, unionTyVarSets, emptyTyVarSet, TyVar )
  34 import Type     ( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy )
  35 import TyCon    ( TyCon, tyConKind, tyConArity, isSynTyCon, Arity )
  36 import Class    ( Class )
  37
  38 import TcMonad
  39
  40 import IdInfo           ( noIdInfo )
  41 import Name             ( Name, OccName(..),
  42                           maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
  43                           NamedThing(..)
  44                         )
  45 import Unique           ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
  46 import UniqFM
  47 import Util             ( zipEqual, zipWithEqual, zipWith3Equal )
  48 import Maybes           ( maybeToBool )
  49 import Outputable
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection{TcId, TcIdOcc}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58
  59 \begin{code}
  60 type TcIdBndr s = GenId  (TcType s)     -- Binders are all TcTypes
  61 data TcIdOcc  s = TcId   (TcIdBndr s)   -- Bindees may be either
  62                 | RealId Id
  63
  64 instance Eq (TcIdOcc s) where
  65   (TcId id1)   == (TcId id2)   = id1 == id2
  66   (RealId id1) == (RealId id2) = id1 == id2
  67   _            == _            = False
  68
  69 instance Ord (TcIdOcc s) where
  70   (TcId id1)   `compare` (TcId id2)   = id1 `compare` id2
  71   (RealId id1) `compare` (RealId id2) = id1 `compare` id2
  72   (TcId _)     `compare` (RealId _)   = LT
  73   (RealId _)   `compare` (TcId _)     = GT
  74
  75 instance Outputable (TcIdOcc s) where
  76   ppr (TcId id)   = ppr id
  77   ppr (RealId id) = ppr id
  78
  79 instance NamedThing (TcIdOcc s) where
  80   getName (TcId id)   = getName id
  81   getName (RealId id) = getName id
  82
  83
  84 tcIdType :: TcIdOcc s -> TcType s
  85 tcIdType (TcId   id) = idType id
  86 tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id)
  87
  88 tcIdTyVars (TcId id)  = tyVarsOfType (idType id)
  89 tcIdTyVars (RealId _) = emptyTyVarSet           -- Top level Ids have no free type variables
  90
  91
  92 -- A useful function that takes an occurrence of a global thing
  93 -- and instantiates its type with fresh type variables
  94 tcInstId :: Id
  95          -> NF_TcM s ([TcTyVar s],      -- It's instantiated type
  96                       TcThetaType s,    --
  97                       TcType s)         --
  98
  99 tcInstId id
 100   = let
 101       (tyvars, rho) = splitForAllTys (idType id)
 102     in
 103     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 104     tcInstType tenv rho         `thenNF_Tc` \ rho' ->
 105     let
 106         (theta', tau') = splitRhoTy rho'
 107     in
 108     returnNF_Tc (tyvars', theta', tau')
 109 \end{code}
 110
 111
 112 %************************************************************************
 113 %*                                                                      *
 114 \subsection{TcEnv}
 115 %*                                                                      *
 116 %************************************************************************
 117
 118 Data type declarations
 119 ~~~~~~~~~~~~~~~~~~~~~
 120
 121 \begin{code}
 122 data TcEnv s = TcEnv
 123                   (TyVarEnv s)
 124                   (TyConEnv s)
 125                   (ClassEnv s)
 126                   (ValueEnv Id)                 -- Globals
 127                   (ValueEnv (TcIdBndr s))       -- Locals
 128                   (TcRef s (TcTyVarSet s))      -- Free type variables of locals
 129                                                 -- ...why mutable? see notes with tcGetGlobalTyVars
 130
 131 type TyVarEnv s  = UniqFM (TcKind s, TyVar)
 132 type TyConEnv s  = UniqFM (TcKind s, Maybe Arity, TyCon)        -- Arity present for Synonyms only
 133 type ClassEnv s  = UniqFM ([TcKind s], Class)           -- The kinds are the kinds of the args
 134                                                         -- to the class
 135 type ValueEnv id = UniqFM id
 136
 137 initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s
 138 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
 139
 140 getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
 141 getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
 142 getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
 143 \end{code}
 144
 145 Type variable env
 146 ~~~~~~~~~~~~~~~~~
 147 \begin{code}
 148 tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
 149 tcExtendTyVarEnv names kinds_w_types scope
 150   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 151     let
 152         tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
 153     in
 154     tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
 155 \end{code}
 156
 157 The Kind, TyVar, Class and TyCon envs
 158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 159
 160 Extending the environments.
 161
 162 \begin{code}
 163 tcExtendTyConEnv :: [(Name, (TcKind s, Maybe Arity, TyCon))] -> TcM s r -> TcM s r
 164
 165 tcExtendTyConEnv bindings scope
 166   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 167     let
 168         tce' = addListToUFM tce bindings
 169     in
 170     tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
 171
 172
 173 tcExtendClassEnv :: [(Name, ([TcKind s], Class))] -> TcM s r -> TcM s r
 174 tcExtendClassEnv bindings scope
 175   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 176     let
 177         ce' = addListToUFM ce bindings
 178     in
 179     tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
 180 \end{code}
 181
 182
 183 Looking up in the environments.
 184
 185 \begin{code}
 186 tcLookupTyVar name
 187   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 188     returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name)
 189
 190
 191 tcLookupTyCon name
 192   =     -- Try for a wired-in tycon
 193     case maybeWiredInTyConName name of {
 194         Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
 195                 | otherwise     -> returnTc (kind, Nothing,              tc)
 196                 where {
 197                   kind = kindToTcKind (tyConKind tc)
 198                 };
 199
 200         Nothing ->
 201
 202             -- Try in the environment
 203           tcGetEnv      `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 204           case lookupUFM tce name of {
 205               Just stuff -> returnTc stuff;
 206
 207               Nothing    ->
 208
 209                 -- Could be that he's using a class name as a type constructor
 210                case lookupUFM ce name of
 211                  Just _  -> failWithTc (classAsTyConErr name)
 212                  Nothing -> pprPanic "tcLookupTyCon:" (ppr name)
 213             } }
 214
 215 tcLookupTyConByKey uniq
 216   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 217     let
 218        (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce
 219                                         (pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq))
 220                                         uniq
 221     in
 222     returnNF_Tc tycon
 223
 224 tcLookupClass name
 225   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 226     case lookupUFM ce name of
 227         Just stuff         -- Common case: it's ok
 228           -> returnTc stuff
 229
 230         Nothing            -- Could be that he's using a type constructor as a class
 231           |  maybeToBool (maybeWiredInTyConName name)
 232           || maybeToBool (lookupUFM tce name)
 233           -> failWithTc (tyConAsClassErr name)
 234
 235           | otherwise      -- Wierd!  Renamer shouldn't let this happen
 236           -> pprPanic "tcLookupClass" (ppr name)
 237
 238 tcLookupClassByKey uniq
 239   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 240     let
 241         (kind, clas) = lookupWithDefaultUFM_Directly ce
 242                                 (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
 243                                 uniq
 244     in
 245     returnNF_Tc clas
 246
 247 tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
 248 tcGetTyConsAndClasses
 249   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 250     returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
 251                  [c  | (_, c)     <- eltsUFM ce])
 252 \end{code}
 253
 254
 255
 256 Extending and consulting the value environment
 257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 258 \begin{code}
 259 tcExtendGlobalValEnv ids scope
 260   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 261     let
 262         gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
 263     in
 264     tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
 265
 266 tcExtendLocalValEnv names ids scope
 267   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 268     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 269     let
 270         lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
 271         extra_global_tyvars = tyVarsOfTypes (map idType ids)
 272         new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
 273     in
 274     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 275
 276     tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
 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 s)
 285 tcGetGlobalTyVars
 286   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 287     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 288     zonkTcTyVars global_tvs             `thenNF_Tc` \ global_tvs' ->
 289     tcWriteMutVar gtvs global_tvs'      `thenNF_Tc_`
 290     returnNF_Tc global_tvs'
 291
 292 tcExtendGlobalTyVars extra_global_tvs scope
 293   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 294     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 295     let
 296         new_global_tyvars = global_tvs `unionTyVarSets` mkTyVarSet extra_global_tvs
 297     in
 298     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 299     tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
 300 \end{code}
 301
 302 \begin{code}
 303 tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
 304 tcLookupLocalValue name
 305   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 306     returnNF_Tc (lookupUFM lve name)
 307
 308 tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
 309 tcLookupLocalValueByKey uniq
 310   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 311     returnNF_Tc (lookupUFM_Directly lve uniq)
 312
 313 tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
 314 tcLookupLocalValueOK err name
 315   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 316     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 317
 318
 319 tcLookupGlobalValue :: Name -> NF_TcM s Id
 320 tcLookupGlobalValue name
 321   = case maybeWiredInIdName name of
 322         Just id -> returnNF_Tc id
 323         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 324                    returnNF_Tc (lookupWithDefaultUFM gve def name)
 325   where
 326     def = pprPanic "tcLookupGlobalValue:" (ppr name)
 327
 328 tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
 329 tcLookupGlobalValueMaybe name
 330   = case maybeWiredInIdName name of
 331         Just id -> returnNF_Tc (Just id)
 332         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 333                    returnNF_Tc (lookupUFM gve name)
 334
 335
 336 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 337 tcLookupGlobalValueByKey uniq
 338   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 339     returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
 340   where
 341 #ifdef DEBUG
 342     def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
 343 #else
 344     def = panic "tcLookupGlobalValueByKey"
 345 #endif
 346
 347 tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 348 tcLookupGlobalValueByKeyMaybe uniq
 349   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 350     returnNF_Tc (lookupUFM_Directly gve uniq)
 351
 352
 353 -- Non-monadic version, environment given explicitly
 354 tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
 355 tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
 356   = case maybeWiredInIdName name of
 357         Just id -> Just id
 358         Nothing -> lookupUFM gve name
 359
 360         -- Extract the IdInfo from an IfaceSig imported from an interface file
 361 tcAddImportedIdInfo :: TcEnv s -> Id -> Id
 362 tcAddImportedIdInfo unf_env id
 363   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 364                                 -- have explicit local definitions, so we get a black hole!
 365   = id
 366   | otherwise
 367   = id `replaceIdInfo` new_info
 368         -- The Id must be returned without a data dependency on maybe_id
 369   where
 370     new_info = -- pprTrace "tcAdd" (ppr id) $
 371                case tcExplicitLookupGlobal unf_env (getName id) of
 372                      Nothing          -> noIdInfo
 373                      Just imported_id -> idInfo imported_id
 374                 -- ToDo: could check that types are the same
 375 \end{code}
 376
 377
 378 Constructing new Ids
 379 ~~~~~~~~~~~~~~~~~~~~
 380
 381 \begin{code}
 382 -- Uses the Name as the Name of the Id
 383 newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 384
 385 newMonoIds names kind m
 386   = newTyVarTys no_of_names kind        `thenNF_Tc` \ tys ->
 387     let
 388         new_ids       = zipWithEqual "newMonoIds" mk_id names tys
 389         mk_id name ty = mkUserId name ty
 390     in
 391     tcExtendLocalValEnv names new_ids (m new_ids)
 392   where
 393     no_of_names = length names
 394
 395 newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
 396 newLocalId name ty
 397   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 398     tcGetUnique         `thenNF_Tc` \ uniq ->
 399     returnNF_Tc (mkUserLocal name uniq ty loc)
 400
 401 newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 402 newLocalIds names tys
 403   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 404     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
 405     let
 406         new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
 407         mk_id name uniq ty = mkUserLocal name uniq ty loc
 408     in
 409     returnNF_Tc new_ids
 410 \end{code}
 411
 412
 413 \begin{code}
 414 classAsTyConErr name
 415   = ptext SLIT("Class used as a type constructor:") <+> ppr name
 416
 417 tyConAsClassErr name
 418   = ptext SLIT("Type constructor used as a class:") <+> ppr name
 419 \end{code}