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