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