ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
   4
   5         TcEnv, GlobalValueEnv,
   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, tcGetGlobalValEnv, tcSetGlobalValEnv,
  16         tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
  17         tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
  18         tcAddImportedIdInfo, tcExplicitLookupGlobal,
  19         tcLookupGlobalValueByKeyMaybe,
  20
  21         newMonoIds, newLocalIds, newLocalId, newSpecPragmaId,
  22         tcGetGlobalTyVars, tcExtendGlobalTyVars
  23   ) where
  24
  25 #include "HsVersions.h"
  26
  27 import MkId     ( mkUserLocal, mkUserId, mkSpecPragmaId )
  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(..), nameOccName,
  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                   GlobalValueEnv
 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 type GlobalValueEnv = ValueEnv Id                       -- Globals
 137
 138 initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s
 139 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
 140
 141 getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
 142 getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
 143 getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
 144 \end{code}
 145
 146 Type variable env
 147 ~~~~~~~~~~~~~~~~~
 148 \begin{code}
 149 tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
 150 tcExtendTyVarEnv names kinds_w_types scope
 151   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 152     let
 153         tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
 154     in
 155     tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
 156 \end{code}
 157
 158 The Kind, TyVar, Class and TyCon envs
 159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 160
 161 Extending the environments.
 162
 163 \begin{code}
 164 tcExtendTyConEnv :: [(Name, (TcKind s, Maybe Arity, TyCon))] -> TcM s r -> TcM s r
 165
 166 tcExtendTyConEnv bindings scope
 167   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 168     let
 169         tce' = addListToUFM tce bindings
 170     in
 171     tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
 172
 173
 174 tcExtendClassEnv :: [(Name, ([TcKind s], Class))] -> TcM s r -> TcM s r
 175 tcExtendClassEnv bindings scope
 176   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 177     let
 178         ce' = addListToUFM ce bindings
 179     in
 180     tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
 181 \end{code}
 182
 183
 184 Looking up in the environments.
 185
 186 \begin{code}
 187 tcLookupTyVar name
 188   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 189     returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name)
 190
 191
 192 tcLookupTyCon name
 193   =     -- Try for a wired-in tycon
 194     case maybeWiredInTyConName name of {
 195         Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
 196                 | otherwise     -> returnTc (kind, Nothing,              tc)
 197                 where {
 198                   kind = kindToTcKind (tyConKind tc)
 199                 };
 200
 201         Nothing ->
 202
 203             -- Try in the environment
 204           tcGetEnv      `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 205           case lookupUFM tce name of {
 206               Just stuff -> returnTc stuff;
 207
 208               Nothing    ->
 209
 210                 -- Could be that he's using a class name as a type constructor
 211                case lookupUFM ce name of
 212                  Just _  -> failWithTc (classAsTyConErr name)
 213                  Nothing -> pprPanic "tcLookupTyCon:" (ppr name)
 214             } }
 215
 216 tcLookupTyConByKey uniq
 217   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 218     let
 219        (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce
 220                                         (pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq))
 221                                         uniq
 222     in
 223     returnNF_Tc tycon
 224
 225 tcLookupClass name
 226   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 227     case lookupUFM ce name of
 228         Just stuff         -- Common case: it's ok
 229           -> returnTc stuff
 230
 231         Nothing            -- Could be that he's using a type constructor as a class
 232           |  maybeToBool (maybeWiredInTyConName name)
 233           || maybeToBool (lookupUFM tce name)
 234           -> failWithTc (tyConAsClassErr name)
 235
 236           | otherwise      -- Wierd!  Renamer shouldn't let this happen
 237           -> pprPanic "tcLookupClass" (ppr name)
 238
 239 tcLookupClassByKey uniq
 240   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 241     let
 242         (kind, clas) = lookupWithDefaultUFM_Directly ce
 243                                 (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
 244                                 uniq
 245     in
 246     returnNF_Tc clas
 247
 248 tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
 249 tcGetTyConsAndClasses
 250   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 251     returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
 252                  [c  | (_, c)     <- eltsUFM ce])
 253 \end{code}
 254
 255
 256
 257 Extending and consulting the value environment
 258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 259 \begin{code}
 260 tcExtendGlobalValEnv ids scope
 261   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 262     let
 263         gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
 264     in
 265     tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
 266
 267 tcExtendLocalValEnv names ids scope
 268   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 269     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 270     let
 271         lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
 272         extra_global_tyvars = tyVarsOfTypes (map idType ids)
 273         new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
 274     in
 275     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 276
 277     tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
 278 \end{code}
 279
 280 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 281 To improve subsequent calls to the same function it writes the zonked set back into
 282 the environment.
 283
 284 \begin{code}
 285 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
 286 tcGetGlobalTyVars
 287   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 288     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 289     zonkTcTyVars global_tvs             `thenNF_Tc` \ global_tvs' ->
 290     tcWriteMutVar gtvs global_tvs'      `thenNF_Tc_`
 291     returnNF_Tc global_tvs'
 292
 293 tcExtendGlobalTyVars extra_global_tvs scope
 294   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 295     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 296     let
 297         new_global_tyvars = global_tvs `unionTyVarSets` mkTyVarSet extra_global_tvs
 298     in
 299     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 300     tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
 301 \end{code}
 302
 303 \begin{code}
 304 tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
 305 tcLookupLocalValue name
 306   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 307     returnNF_Tc (lookupUFM lve name)
 308
 309 tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
 310 tcLookupLocalValueByKey uniq
 311   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 312     returnNF_Tc (lookupUFM_Directly lve uniq)
 313
 314 tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
 315 tcLookupLocalValueOK err name
 316   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 317     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 318
 319
 320 tcLookupGlobalValue :: Name -> NF_TcM s Id
 321 tcLookupGlobalValue name
 322   = case maybeWiredInIdName name of
 323         Just id -> returnNF_Tc id
 324         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 325                    returnNF_Tc (lookupWithDefaultUFM gve def name)
 326   where
 327     def = pprPanic "tcLookupGlobalValue:" (ppr name)
 328
 329 tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
 330 tcLookupGlobalValueMaybe name
 331   = case maybeWiredInIdName name of
 332         Just id -> returnNF_Tc (Just id)
 333         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 334                    returnNF_Tc (lookupUFM gve name)
 335
 336
 337 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 338 tcLookupGlobalValueByKey uniq
 339   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 340     returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
 341   where
 342 #ifdef DEBUG
 343     def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
 344 #else
 345     def = panic "tcLookupGlobalValueByKey"
 346 #endif
 347
 348 tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 349 tcLookupGlobalValueByKeyMaybe uniq
 350   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 351     returnNF_Tc (lookupUFM_Directly gve uniq)
 352
 353 tcGetGlobalValEnv :: NF_TcM s GlobalValueEnv
 354 tcGetGlobalValEnv
 355   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 356     returnNF_Tc gve
 357
 358 tcSetGlobalValEnv :: GlobalValueEnv -> TcM s a -> TcM s a
 359 tcSetGlobalValEnv gve scope
 360   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce _ lve gtvs) ->
 361     tcSetEnv (TcEnv tve tce ce gve lve gtvs) scope
 362
 363
 364 -- Non-monadic version, environment given explicitly
 365 tcExplicitLookupGlobal :: GlobalValueEnv -> Name -> Maybe Id
 366 tcExplicitLookupGlobal gve name
 367   = case maybeWiredInIdName name of
 368         Just id -> Just id
 369         Nothing -> lookupUFM gve name
 370
 371         -- Extract the IdInfo from an IfaceSig imported from an interface file
 372 tcAddImportedIdInfo :: GlobalValueEnv -> Id -> Id
 373 tcAddImportedIdInfo unf_env id
 374   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 375                                 -- have explicit local definitions, so we get a black hole!
 376   = id
 377   | otherwise
 378   = id `replaceIdInfo` new_info
 379         -- The Id must be returned without a data dependency on maybe_id
 380   where
 381     new_info = -- pprTrace "tcAdd" (ppr id) $
 382                case tcExplicitLookupGlobal unf_env (getName id) of
 383                      Nothing          -> noIdInfo
 384                      Just imported_id -> idInfo imported_id
 385                 -- ToDo: could check that types are the same
 386 \end{code}
 387
 388
 389 Constructing new Ids
 390 ~~~~~~~~~~~~~~~~~~~~
 391
 392 \begin{code}
 393 -- Uses the Name as the Name of the Id
 394 newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 395
 396 newMonoIds names kind m
 397   = newTyVarTys no_of_names kind        `thenNF_Tc` \ tys ->
 398     let
 399         new_ids       = zipWithEqual "newMonoIds" mk_id names tys
 400         mk_id name ty = mkUserId name ty
 401     in
 402     tcExtendLocalValEnv names new_ids (m new_ids)
 403   where
 404     no_of_names = length names
 405
 406 newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
 407 newLocalId name ty
 408   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 409     tcGetUnique         `thenNF_Tc` \ uniq ->
 410     returnNF_Tc (mkUserLocal name uniq ty loc)
 411
 412 newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 413 newLocalIds names tys
 414   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 415     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
 416     let
 417         new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
 418         mk_id name uniq ty = mkUserLocal name uniq ty loc
 419     in
 420     returnNF_Tc new_ids
 421
 422 newSpecPragmaId :: Name -> TcType s -> NF_TcM s (TcIdBndr s)
 423 newSpecPragmaId name ty
 424   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 425     tcGetUnique         `thenNF_Tc` \ uniq ->
 426     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty loc)
 427 \end{code}
 428
 429
 430 \begin{code}
 431 classAsTyConErr name
 432   = ptext SLIT("Class used as a type constructor:") <+> ppr name
 433
 434 tyConAsClassErr name
 435   = ptext SLIT("Type constructor used as a class:") <+> ppr name
 436 \end{code}