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