ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module TcEnv(
   5         TcEnv,
   6
   7         initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
   8
   9         tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv,
  10         tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey,
  11
  12         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  13         tcLookupLocalValue, tcLookupLocalValueOK,
  14         tcLookupGlobalValue, tcLookupGlobalValueByKey,
  15
  16         tcTyVarScope, newMonoIds, newLocalIds,
  17         tcGetGlobalTyVars
  18   ) where
  19
  20
  21 import Ubiq
  22 import TcMLoop  -- for paranoia checking
  23
  24 import Id       ( Id(..), GenId, idType, mkUserLocal )
  25 import TcHsSyn  ( TcIdBndr(..) )
  26 import TcKind   ( TcKind, newKindVars, tcKindToKind, kindToTcKind )
  27 import TcType   ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars )
  28 import TyVar    ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
  29 import Type     ( tyVarsOfTypes )
  30 import TyCon    ( TyCon, getTyConKind )
  31 import Class    ( Class(..), GenClass, getClassSig )
  32
  33 import TcMonad
  34
  35 import Name     ( Name(..), getNameShortName )
  36 import PprStyle
  37 import Pretty
  38 import Unique   ( Unique )
  39 import UniqFM
  40 import Util     ( zipWithEqual, zipWith3Equal, zipLazy, panic )
  41 \end{code}
  42
  43 Data type declarations
  44 ~~~~~~~~~~~~~~~~~~~~~
  45
  46 \begin{code}
  47 data TcEnv s = TcEnv
  48                   (TyVarEnv s)
  49                   (ValueEnv Id)                 -- Globals
  50                   (ValueEnv (TcIdBndr s))       -- Locals
  51                   (MutableVar s (TcTyVarSet s)) -- Free type variables of locals
  52                                                 -- ...why mutable? see notes with tcGetGlobalTyVars
  53                   (KindEnv s)                   -- Gives TcKinds of TyCons and Classes
  54                   TyConEnv
  55                   ClassEnv
  56
  57 type TyVarEnv s  = UniqFM (TcKind s, TyVar)
  58 type TyConEnv    = UniqFM TyCon
  59 type KindEnv s   = UniqFM (TcKind s)
  60 type ClassEnv    = UniqFM Class
  61 type ValueEnv id = UniqFM id
  62
  63 initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
  64 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM
  65
  66 getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls
  67 getEnv_TyCons   (TcEnv _ _ _ _ _ ts _) = ts
  68 getEnv_Classes  (TcEnv _ _ _ _ _ _ cs) = cs
  69 \end{code}
  70
  71 Making new TcTyVars, with knot tying!
  72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  73 \begin{code}
  74 tcTyVarScope :: [Name]                  -- Names of some type variables
  75              -> ([TyVar] -> TcM s a)    -- Thing to type check in their scope
  76              -> TcM s a                 -- Result
  77
  78 tcTyVarScope tyvar_names thing_inside
  79   = newKindVars (length tyvar_names)    `thenNF_Tc` \ tyvar_kinds ->
  80
  81     fixTc (\ ~(tyvars, _) ->
  82                 -- Ok to look at kinds, but not tyvars!
  83       tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) (
  84
  85                 -- Do the thing inside
  86         thing_inside tyvars                     `thenTc` \ result ->
  87
  88                 -- Get the tyvar's Kinds from their TcKinds
  89         mapNF_Tc tcKindToKind tyvar_kinds       `thenNF_Tc` \ tyvar_kinds' ->
  90
  91                 -- Construct the real TyVars
  92         let
  93           tyvars             = zipWithEqual mk_tyvar tyvar_names tyvar_kinds'
  94           mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
  95         in
  96         returnTc (tyvars, result)
  97     ))                                  `thenTc` \ (_,result) ->
  98     returnTc result
  99 \end{code}
 100
 101
 102 The Kind, TyVar, Class and TyCon envs
 103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 104
 105 Extending the environments
 106
 107 \begin{code}
 108 tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r
 109 tcExtendKindEnv names kinds scope
 110   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 111     let
 112         ke' = addListToUFM ke (names `zip` kinds)
 113     in
 114     tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope
 115
 116 tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
 117 tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope
 118   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 119     let
 120         tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars)
 121     in
 122     tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope
 123
 124 tcExtendTyConEnv tycons scope
 125   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 126     let
 127         tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons]
 128     in
 129     tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope
 130
 131 tcExtendClassEnv classes scope
 132   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 133     let
 134         ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes]
 135     in
 136     tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope
 137 \end{code}
 138
 139
 140 Looking up in the environments
 141
 142 \begin{code}
 143 tcLookupTyVar name
 144   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 145     returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
 146
 147
 148 tcLookupTyCon (WiredInTyCon tc)         -- wired in tycons
 149   = returnNF_Tc (kindToTcKind (getTyConKind tc), tc)
 150
 151 tcLookupTyCon name
 152   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 153     let
 154         tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon")             name
 155         kind  = lookupWithDefaultUFM ke  (kindToTcKind (getTyConKind tycon)) name
 156                 -- The KE will bind tycon in the current mutually-recursive set.
 157                 -- If the KE doesn't, then the tycon is already defined, and we
 158                 -- can safely grab the kind from the TyCon itself
 159     in
 160     returnNF_Tc (kind,tycon)
 161
 162
 163 tcLookupClass name
 164   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 165     let
 166         clas = lookupWithDefaultUFM ce (panic "tcLookupClass")             name
 167         (tyvar, _, _) = getClassSig clas
 168         kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name
 169     in
 170     returnNF_Tc (kind,clas)
 171
 172 tcLookupClassByKey uniq
 173   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 174     let
 175         clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
 176     in
 177     returnNF_Tc (clas)
 178 \end{code}
 179
 180
 181
 182 Extending and consulting the value environment
 183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 184 \begin{code}
 185 tcExtendGlobalValEnv ids scope
 186   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 187     let
 188         gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
 189     in
 190     tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope
 191
 192 tcExtendLocalValEnv names ids scope
 193   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 194     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 195     let
 196         lve' = addListToUFM lve (names `zip` ids)
 197         extra_global_tyvars = tyVarsOfTypes (map idType ids)
 198         new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
 199     in
 200     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 201
 202     tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope
 203 \end{code}
 204
 205 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 206 To improve subsequent calls to the same function it writes the zonked set back into
 207 the environment.
 208
 209 \begin{code}
 210 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
 211 tcGetGlobalTyVars
 212   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 213     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 214     zonkTcTyVars global_tvs             `thenNF_Tc` \ global_tvs' ->
 215     tcWriteMutVar gtvs global_tvs'      `thenNF_Tc_`
 216     returnNF_Tc global_tvs'
 217 \end{code}
 218
 219 \begin{code}
 220 tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
 221 tcLookupLocalValue name
 222   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 223     returnNF_Tc (lookupUFM lve name)
 224
 225 tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
 226 tcLookupLocalValueOK err name
 227   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 228     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 229
 230
 231 tcLookupGlobalValue :: Name -> NF_TcM s Id
 232
 233 tcLookupGlobalValue (WiredInVal id)     -- wired in ids
 234   = returnNF_Tc id
 235
 236 tcLookupGlobalValue name
 237   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 238     returnNF_Tc (lookupWithDefaultUFM gve def name)
 239   where
 240 #ifdef DEBUG
 241     def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name))
 242 #else
 243     def = panic "tcLookupGlobalValue"
 244 #endif
 245
 246
 247 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 248 tcLookupGlobalValueByKey uniq
 249   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
 250     returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
 251   where
 252 #ifdef DEBUG
 253     def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq))
 254 #else
 255     def = panic "tcLookupGlobalValueByKey"
 256 #endif
 257
 258 \end{code}
 259
 260
 261 Constructing new Ids
 262 ~~~~~~~~~~~~~~~~~~~~
 263
 264 \begin{code}
 265 newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 266 newMonoIds names kind m
 267   = newTyVarTys no_of_names kind        `thenNF_Tc` \ tys ->
 268     tcGetUniques no_of_names            `thenNF_Tc` \ uniqs ->
 269     let
 270         new_ids            = zipWith3Equal mk_id names uniqs tys
 271         mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
 272                                          (getSrcLoc name)
 273     in
 274     tcExtendLocalValEnv names new_ids (m new_ids)
 275   where
 276     no_of_names = length names
 277
 278 newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 279 newLocalIds names tys
 280   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 281     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
 282     let
 283         new_ids            = zipWith3Equal mk_id names uniqs tys
 284         mk_id name uniq ty = mkUserLocal name uniq ty loc
 285     in
 286     returnNF_Tc new_ids
 287 \end{code}
 288
 289