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 Id       ( Id, GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo )
  28 import PragmaInfo ( PragmaInfo(..) )
  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 PprType  ( GenTyVar )
  35 import Type     ( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy )
  36 import TyCon    ( TyCon, tyConKind, tyConArity, isSynTyCon, Arity )
  37 import Class    ( Class )
  38
  39 import TcMonad
  40
  41 import IdInfo           ( noIdInfo )
  42 import Name             ( Name, OccName(..),
  43                           maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
  44                           NamedThing(..)
  45                         )
  46 import Unique           ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
  47 import UniqFM
  48 import Util             ( zipEqual, zipWithEqual, zipWith3Equal )
  49 import Maybes           ( maybeToBool )
  50 import Outputable
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{TcId, TcIdOcc}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59
  60 \begin{code}
  61 type TcIdBndr s = GenId  (TcType s)     -- Binders are all TcTypes
  62 data TcIdOcc  s = TcId   (TcIdBndr s)   -- Bindees may be either
  63                 | RealId Id
  64
  65 instance Eq (TcIdOcc s) where
  66   (TcId id1)   == (TcId id2)   = id1 == id2
  67   (RealId id1) == (RealId id2) = id1 == id2
  68   _            == _            = False
  69
  70 instance Ord (TcIdOcc s) where
  71   (TcId id1)   `compare` (TcId id2)   = id1 `compare` id2
  72   (RealId id1) `compare` (RealId id2) = id1 `compare` id2
  73   (TcId _)     `compare` (RealId _)   = LT
  74   (RealId _)   `compare` (TcId _)     = GT
  75
  76 instance Outputable (TcIdOcc s) where
  77   ppr (TcId id)   = ppr id
  78   ppr (RealId id) = ppr id
  79
  80 instance NamedThing (TcIdOcc s) where
  81   getName (TcId id)   = getName id
  82   getName (RealId id) = getName id
  83
  84
  85 tcIdType :: TcIdOcc s -> TcType s
  86 tcIdType (TcId   id) = idType id
  87 tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id)
  88
  89 tcIdTyVars (TcId id)  = tyVarsOfType (idType id)
  90 tcIdTyVars (RealId _) = emptyTyVarSet           -- Top level Ids have no free type variables
  91
  92
  93 -- A useful function that takes an occurrence of a global thing
  94 -- and instantiates its type with fresh type variables
  95 tcInstId :: Id
  96          -> NF_TcM s ([TcTyVar s],      -- It's instantiated type
  97                       TcThetaType s,    --
  98                       TcType s)         --
  99
 100 tcInstId id
 101   = let
 102       (tyvars, rho) = splitForAllTys (idType id)
 103     in
 104     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 105     tcInstType tenv rho         `thenNF_Tc` \ rho' ->
 106     let
 107         (theta', tau') = splitRhoTy rho'
 108     in
 109     returnNF_Tc (tyvars', theta', tau')
 110 \end{code}
 111
 112
 113 %************************************************************************
 114 %*                                                                      *
 115 \subsection{TcEnv}
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 Data type declarations
 120 ~~~~~~~~~~~~~~~~~~~~~
 121
 122 \begin{code}
 123 data TcEnv s = TcEnv
 124                   (TyVarEnv s)
 125                   (TyConEnv s)
 126                   (ClassEnv s)
 127                   (ValueEnv Id)                 -- Globals
 128                   (ValueEnv (TcIdBndr s))       -- Locals
 129                   (TcRef s (TcTyVarSet s))      -- Free type variables of locals
 130                                                 -- ...why mutable? see notes with tcGetGlobalTyVars
 131
 132 type TyVarEnv s  = UniqFM (TcKind s, TyVar)
 133 type TyConEnv s  = UniqFM (TcKind s, Maybe Arity, TyCon)        -- Arity present for Synonyms only
 134 type ClassEnv s  = UniqFM ([TcKind s], Class)           -- The kinds are the kinds of the args
 135                                                         -- to the class
 136 type ValueEnv id = UniqFM id
 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
 354 -- Non-monadic version, environment given explicitly
 355 tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
 356 tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
 357   = case maybeWiredInIdName name of
 358         Just id -> Just id
 359         Nothing -> lookupUFM gve name
 360
 361         -- Extract the IdInfo from an IfaceSig imported from an interface file
 362 tcAddImportedIdInfo :: TcEnv s -> Id -> Id
 363 tcAddImportedIdInfo unf_env id
 364   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 365                                 -- have explicit local definitions, so we get a black hole!
 366   = id
 367   | otherwise
 368   = id `replaceIdInfo` new_info
 369         -- The Id must be returned without a data dependency on maybe_id
 370   where
 371     new_info = -- pprTrace "tcAdd" (ppr id) $
 372                case tcExplicitLookupGlobal unf_env (getName id) of
 373                      Nothing          -> noIdInfo
 374                      Just imported_id -> getIdInfo imported_id
 375                 -- ToDo: could check that types are the same
 376 \end{code}
 377
 378
 379 Constructing new Ids
 380 ~~~~~~~~~~~~~~~~~~~~
 381
 382 \begin{code}
 383 -- Uses the Name as the Name of the Id
 384 newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 385
 386 newMonoIds names kind m
 387   = newTyVarTys no_of_names kind        `thenNF_Tc` \ tys ->
 388     let
 389         new_ids       = zipWithEqual "newMonoIds" mk_id names tys
 390         mk_id name ty = mkUserId name ty NoPragmaInfo
 391     in
 392     tcExtendLocalValEnv names new_ids (m new_ids)
 393   where
 394     no_of_names = length names
 395
 396 newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
 397 newLocalId name ty
 398   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 399     tcGetUnique         `thenNF_Tc` \ uniq ->
 400     returnNF_Tc (mkUserLocal name uniq ty loc)
 401
 402 newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 403 newLocalIds names tys
 404   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 405     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
 406     let
 407         new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
 408         mk_id name uniq ty = mkUserLocal name uniq ty loc
 409     in
 410     returnNF_Tc new_ids
 411 \end{code}
 412
 413
 414 \begin{code}
 415 classAsTyConErr name
 416   = ptext SLIT("Class used as a type constructor:") <+> ppr name
 417
 418 tyConAsClassErr name
 419   = ptext SLIT("Type constructor used as a class:") <+> ppr name
 420 \end{code}