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