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, tcGlobalOcc,
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, tcDefaultKind, kindToTcKind )
29 import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
30 newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
32 import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
33 import Type ( tyVarsOfTypes )
34 import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
35 import Class ( Class(..), GenClass, getClassSig )
39 import Name ( Name(..), getNameShortName )
42 import Type ( splitForAllTy )
43 import Unique ( Unique )
45 import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
48 Data type declarations
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
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
66 initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
67 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
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]
74 Making new TcTyVars, with knot tying!
75 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
77 tcTyVarScopeGivenKinds
78 :: [Name] -- Names of some type variables
80 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
83 tcTyVarScopeGivenKinds names kinds thing_inside
84 = fixTc (\ ~(rec_tyvars, _) ->
85 -- Ok to look at names, kinds, but not tyvars!
87 tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
89 tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars))
91 tcSetEnv (TcEnv tve' tce ce gve lve gtvs)
92 (thing_inside rec_tyvars) `thenTc` \ result ->
94 -- Get the tyvar's Kinds from their TcKinds
95 mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
97 -- Construct the real TyVars
99 tyvars = zipWithEqual mk_tyvar names kinds'
100 mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
102 returnTc (tyvars, result)
103 ) `thenTc` \ (_,result) ->
106 tcTyVarScope names thing_inside
107 = newKindVars (length names) `thenNF_Tc` \ kinds ->
108 tcTyVarScopeGivenKinds names kinds thing_inside
112 The Kind, TyVar, Class and TyCon envs
113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
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) ->
124 tce' = addListToUFM tce [ (name, (kind, arity, tycon))
125 | ((name,arity), (kind,tycon)) <- names_w_arities `zip`
126 (kinds `zipLazy` tycons)
129 tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result ->
130 mapNF_Tc tcDefaultKind kinds `thenNF_Tc_`
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) ->
139 ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes))
141 tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result ->
142 mapNF_Tc tcDefaultKind kinds `thenNF_Tc_`
147 Looking up in the environments.
151 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
152 returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
155 tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
156 = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
159 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
160 returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name)
162 tcLookupTyConByKey uniq
163 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
165 (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce
166 (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq))
172 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
173 returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name)
175 tcLookupClassByKey uniq
176 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
178 (kind, clas) = lookupWithDefaultUFM_Directly ce
179 (pprPanic "tcLookupClas:" (ppr PprDebug uniq))
187 Extending and consulting the value environment
188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
190 tcExtendGlobalValEnv ids scope
191 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
193 gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
195 tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
197 tcExtendLocalValEnv names ids scope
198 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
199 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
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
205 tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
207 tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
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
215 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
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'
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)
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)
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)
241 tcLookupGlobalValue :: Name -> NF_TcM s Id
243 tcLookupGlobalValue (WiredInVal id) -- wired in ids
246 tcLookupGlobalValue name
247 = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
248 returnNF_Tc (lookupWithDefaultUFM gve def name)
251 def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
253 def = panic "tcLookupGlobalValue"
256 -- A useful function that takes an occurrence of a global thing
257 -- and instantiates its type with fresh type variables
259 -> NF_TcM s (Id, -- The Id
260 [TcType s], -- Instance types
261 TcType s) -- Rest of its type
264 = tcLookupGlobalValue name `thenNF_Tc` \ id ->
266 (tyvars, rho) = splitForAllTy (idType id)
268 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
269 tcInstType tenv rho `thenNF_Tc` \ rho' ->
270 returnNF_Tc (id, arg_tys, rho')
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)
279 def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq)
281 def = panic "tcLookupGlobalValueByKey"
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 ->
296 new_ids = zipWith3Equal mk_id names uniqs tys
297 mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
300 tcExtendLocalValEnv names new_ids (m new_ids)
302 no_of_names = length names
304 newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s)
306 = tcGetSrcLoc `thenNF_Tc` \ loc ->
307 tcGetUnique `thenNF_Tc` \ uniq ->
308 returnNF_Tc (TcId (mkUserLocal name uniq ty loc))
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 ->
315 new_ids = zipWith3Equal mk_id names uniqs tys
316 mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)