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         tcGetTyConsAndClasses,
  14
  15         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  16         tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
  17         tcLookupGlobalValue, tcLookupGlobalValueByKey,
  18
  19         newMonoIds, newLocalIds, newLocalId,
  20         tcGetGlobalTyVars, tcExtendGlobalTyVars
  21   ) where
  22
  23
  24 IMP_Ubiq()
  25 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
  26
  27 import Id       ( SYN_IE(Id), GenId, idType, mkUserLocal )
  28 import TcHsSyn  ( SYN_IE(TcIdBndr), TcIdOcc(..) )
  29 import TcKind   ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
  30 import TcType   ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  31                   newTyVarTys, tcInstTyVars, zonkTcTyVars
  32                 )
  33 import TyVar    ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
  34 import Type     ( tyVarsOfTypes, splitForAllTy )
  35 import TyCon    ( TyCon, tyConKind, synTyConArity )
  36 import Class    ( SYN_IE(Class), GenClass, classSig )
  37
  38 import TcMonad          hiding ( rnMtoTcM )
  39
  40 import Name             ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
  41 import PprStyle
  42 import Pretty
  43 import RnHsSyn          ( RnName(..) )
  44 import Unique           ( pprUnique10, pprUnique{-ToDo:rm-} )
  45 import UniqFM
  46 import Util             ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
  47                           panic, pprPanic, pprTrace{-ToDo:rm-}
  48                         )
  49 \end{code}
  50
  51 Data type declarations
  52 ~~~~~~~~~~~~~~~~~~~~~
  53
  54 \begin{code}
  55 data TcEnv s = TcEnv
  56                   (TyVarEnv s)
  57                   (TyConEnv s)
  58                   (ClassEnv s)
  59                   (ValueEnv Id)                 -- Globals
  60                   (ValueEnv (TcIdBndr s))       -- Locals
  61                   (MutableVar s (TcTyVarSet s)) -- Free type variables of locals
  62                                                 -- ...why mutable? see notes with tcGetGlobalTyVars
  63
  64 type TyVarEnv s  = UniqFM (TcKind s, TyVar)
  65 type TyConEnv s  = UniqFM (TcKind s, Maybe Arity, TyCon)        -- Arity present for Synonyms only
  66 type ClassEnv s  = UniqFM (TcKind s, Class)
  67 type ValueEnv id = UniqFM id
  68
  69 initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
  70 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
  71
  72 getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
  73 getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
  74 getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
  75 \end{code}
  76
  77 Making new TcTyVars, with knot tying!
  78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  79 \begin{code}
  80 tcTyVarScopeGivenKinds
  81         :: [Name]               -- Names of some type variables
  82         -> [TcKind s]
  83         -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
  84         -> TcM s a              -- Result
  85
  86 tcTyVarScopeGivenKinds names kinds thing_inside
  87   = fixTc (\ ~(rec_tyvars, _) ->
  88                 -- Ok to look at names, kinds, but not tyvars!
  89
  90         tcGetEnv                                `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
  91         let
  92             tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars))
  93         in
  94         tcSetEnv (TcEnv tve' tce ce gve lve gtvs)
  95                  (thing_inside rec_tyvars)      `thenTc` \ result ->
  96
  97                 -- Get the tyvar's Kinds from their TcKinds
  98         mapNF_Tc tcDefaultKind kinds            `thenNF_Tc` \ kinds' ->
  99
 100                 -- Construct the real TyVars
 101         let
 102           tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds'
 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))
 129                                   <- zipEqual "tcExtendTyConEnv" names_w_arities (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 (zipEqual "tcExtendClassEnv" names (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 (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) 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 (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) 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:" (pprUnique10 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 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $
 177 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $
 178     returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name)
 179
 180 tcLookupClassByKey uniq
 181   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 182     let
 183         (kind, clas) = lookupWithDefaultUFM_Directly ce
 184                                 (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
 185                                 uniq
 186     in
 187     returnNF_Tc clas
 188
 189 tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
 190 tcGetTyConsAndClasses
 191   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 192     returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
 193                  [c  | (_, c)     <- eltsUFM ce])
 194 \end{code}
 195
 196
 197
 198 Extending and consulting the value environment
 199 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 200 \begin{code}
 201 tcExtendGlobalValEnv ids scope
 202   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 203     let
 204         gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
 205     in
 206     tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
 207
 208 tcExtendLocalValEnv names ids scope
 209   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 210     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 211     let
 212         lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
 213         extra_global_tyvars = tyVarsOfTypes (map idType ids)
 214         new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
 215     in
 216     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 217
 218     tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
 219 \end{code}
 220
 221 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 222 To improve subsequent calls to the same function it writes the zonked set back into
 223 the environment.
 224
 225 \begin{code}
 226 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
 227 tcGetGlobalTyVars
 228   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 229     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 230     zonkTcTyVars global_tvs             `thenNF_Tc` \ global_tvs' ->
 231     tcWriteMutVar gtvs global_tvs'      `thenNF_Tc_`
 232     returnNF_Tc global_tvs'
 233
 234 tcExtendGlobalTyVars extra_global_tvs scope
 235   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 236     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 237     let
 238         new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tvs
 239     in
 240     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 241     tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
 242 \end{code}
 243
 244 \begin{code}
 245 tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s))
 246 tcLookupLocalValue name
 247   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 248     returnNF_Tc (lookupUFM lve name)
 249
 250 tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
 251 tcLookupLocalValueByKey uniq
 252   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 253     returnNF_Tc (lookupUFM_Directly lve uniq)
 254
 255 tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s)
 256 tcLookupLocalValueOK err name
 257   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 258     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 259
 260
 261 tcLookupGlobalValue :: RnName -> NF_TcM s Id
 262
 263 tcLookupGlobalValue (WiredInId id)      -- wired in ids
 264   = returnNF_Tc id
 265
 266 tcLookupGlobalValue name
 267   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 268     returnNF_Tc (lookupWithDefaultUFM gve def name)
 269   where
 270 #ifdef DEBUG
 271     def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
 272 #else
 273     def = panic "tcLookupGlobalValue"
 274 #endif
 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:" (pprUnique10 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 "newMonoIds" mk_id names uniqs tys
 301
 302         mk_id name uniq ty
 303           = let
 304                 name_str = case (getOccName name) of { Unqual n -> n; Qual m 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 "newLocalIds" 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