2 #include "HsVersions.h"
7 initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
9 tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar,
11 tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
12 tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
14 tcExtendGlobalValEnv, tcExtendLocalValEnv,
15 tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
16 tcLookupGlobalValue, tcLookupGlobalValueByKey,
18 newMonoIds, newLocalIds, newLocalId,
24 import TcMLoop -- for paranoia checking
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 )
37 import Name ( Name(..), getNameShortName )
40 import Unique ( Unique )
42 import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic )
45 Data type declarations
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
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
63 initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
64 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
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]
71 Making new TcTyVars, with knot tying!
72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
74 tcTyVarScopeGivenKinds
75 :: [Name] -- Names of some type variables
77 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
80 tcTyVarScopeGivenKinds names kinds thing_inside
81 = fixTc (\ ~(rec_tyvars, _) ->
82 -- Ok to look at names, kinds, but not tyvars!
84 tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
86 tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars))
88 tcSetEnv (TcEnv tve' tce ce gve lve gtvs)
89 (thing_inside rec_tyvars) `thenTc` \ result ->
91 -- Get the tyvar's Kinds from their TcKinds
92 mapNF_Tc tcKindToKind kinds `thenNF_Tc` \ kinds' ->
94 -- Construct the real TyVars
96 tyvars = zipWithEqual mk_tyvar names kinds'
97 mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
99 returnTc (tyvars, result)
100 ) `thenTc` \ (_,result) ->
103 tcTyVarScope names thing_inside
104 = newKindVars (length names) `thenNF_Tc` \ kinds ->
105 tcTyVarScopeGivenKinds names kinds thing_inside
109 The Kind, TyVar, Class and TyCon envs
110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
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) ->
121 tce' = addListToUFM tce [ (name, (kind, arity, tycon))
122 | ((name,arity), (kind,tycon)) <- names_w_arities `zip`
123 (kinds `zipLazy` tycons)
126 tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
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) ->
133 ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes))
135 tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
139 Looking up in the environments.
143 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
144 returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
147 tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
148 = returnNF_Tc (kindToTcKind (getTyConKind tc), getSynTyConArity tc, tc)
151 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
152 returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name)
154 tcLookupTyConByKey uniq
155 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
157 (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce (panic "tcLookupTyCon") uniq
162 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
163 returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name)
165 tcLookupClassByKey uniq
166 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
168 (kind, clas) = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
175 Extending and consulting the value environment
176 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
178 tcExtendGlobalValEnv ids scope
179 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
181 gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
183 tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
185 tcExtendLocalValEnv names ids scope
186 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
187 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
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
193 tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
195 tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
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
203 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
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'
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)
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)
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)
229 tcLookupGlobalValue :: Name -> NF_TcM s Id
231 tcLookupGlobalValue (WiredInVal id) -- wired in ids
234 tcLookupGlobalValue name
235 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
236 returnNF_Tc (lookupWithDefaultUFM gve def name)
239 def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name))
241 def = panic "tcLookupGlobalValue"
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)
251 def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq))
253 def = panic "tcLookupGlobalValueByKey"
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 ->
268 new_ids = zipWith3Equal mk_id names uniqs tys
269 mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
272 tcExtendLocalValEnv names new_ids (m new_ids)
274 no_of_names = length names
276 newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s)
278 = tcGetSrcLoc `thenNF_Tc` \ loc ->
279 tcGetUnique `thenNF_Tc` \ uniq ->
280 returnNF_Tc (TcId (mkUserLocal name uniq ty loc))
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 ->
287 new_ids = zipWith3Equal mk_id names uniqs tys
288 mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)