3 TcId, TcIdSet, tcInstId,
6 TcEnv, ValueEnv, TcTyThing(..),
8 initEnv, getEnvTyCons, getEnvClasses,
10 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
13 tcLookupTyCon, tcLookupTyConByKey,
14 tcLookupClass, tcLookupClassByKey,
16 tcExtendGlobalValEnv, tcExtendLocalValEnv,
17 tcGetValueEnv, tcSetValueEnv,
20 tcLookupValue, tcLookupValueMaybe,
21 tcLookupValueByKey, tcLookupValueByKeyMaybe,
22 explicitLookupValueByKey, explicitLookupValue,
24 newLocalIds, newLocalId, newSpecPragmaId,
25 tcGetGlobalTyVars, tcExtendGlobalTyVars,
30 #include "HsVersions.h"
32 import HsTypes ( HsTyVar, getTyVarName )
33 import Id ( mkUserLocal, isDataConId_maybe )
34 import MkId ( mkSpecPragmaId )
35 import Var ( TyVar, Id, setVarName,
36 idType, setIdInfo, idInfo, tyVarKind
38 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
39 tcInstTyVars, zonkTcTyVars,
44 import Type ( Kind, superKind,
45 tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
46 splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
47 splitAlgTyConApp_maybe, getTyVar
49 import DataCon ( DataCon )
50 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
51 import Class ( Class )
55 import BasicTypes ( Arity )
56 import IdInfo ( noIdInfo )
57 import Name ( Name, OccName, nameOccName, occNameString, mkLocalName,
58 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
62 import Unique ( pprUnique10, Unique, Uniquable(..) )
63 import FiniteMap ( lookupFM, addToFM )
65 import Unique ( Uniquable(..) )
66 import Util ( zipEqual, zipWith3Equal, mapAccumL )
67 import Bag ( bagToList )
68 import Maybes ( maybeToBool )
69 import FastString ( FastString )
73 %************************************************************************
77 %************************************************************************
81 type TcId = Id -- Type may be a TcType
84 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
85 tcLookupDataCon con_name
86 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
87 case isDataConId_maybe con_id of {
88 Nothing -> failWithTc (badCon con_id);
91 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
92 -- Ignore the con_theta; overloaded constructors only
93 -- behave differently when called, not when used for
96 (arg_tys, result_ty) = splitFunTys con_tau
98 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
99 returnTc (data_con, arg_tys, result_ty) }
101 -- A useful function that takes an occurrence of a global thing
102 -- and instantiates its type with fresh type variables
104 -> NF_TcM s ([TcTyVar], -- It's instantiated type
109 (tyvars, rho) = splitForAllTys (idType id)
111 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
113 rho' = substTopTy tenv rho
114 (theta', tau') = splitRhoTy rho'
116 returnNF_Tc (tyvars', theta', tau')
120 %************************************************************************
124 %************************************************************************
126 Data type declarations
127 ~~~~~~~~~~~~~~~~~~~~~
133 (TcTyVarSet, -- The in-scope TyVars
134 TcRef TcTyVarSet) -- Free type variables of the value env
135 -- ...why mutable? see notes with tcGetGlobalTyVars
136 -- Includes the in-scope tyvars
138 type NameEnv val = UniqFM val -- Keyed by Names
140 type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
141 type ValueEnv = NameEnv Id
143 data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
144 -- if the kind is mutable, the tyvar must be so that
150 initEnv :: TcRef TcTyVarSet -> TcEnv
151 initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
153 getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
154 getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
160 Extending the type environment.
163 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
164 tcExtendTyVarEnv tyvars scope
165 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
167 extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
170 te' = addListToUFM te extend_list
171 new_tv_set = mkVarSet tyvars
172 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
174 -- It's important to add the in-scope tyvars to the global tyvar set
176 -- f (x::r) = let g y = y::r in ...
177 -- Here, g mustn't be generalised. This is also important during
178 -- class and instance decls, when we mustn't generalise the class tyvars
179 -- when typechecking the methods.
180 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
181 tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
183 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
184 -- the signature tyvars contain the original names
185 -- the instance tyvars are what those names should be mapped to
186 -- It's needed when typechecking the method bindings of class and instance decls
187 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
189 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
190 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
191 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
193 te' = addListToUFM te stuff
195 tcSetEnv (TcEnv te' ve gtvs) thing_inside
197 stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
198 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
201 tcExtendGlobalTyVars extra_global_tvs scope
202 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
203 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
204 tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
206 tc_extend_gtvs gtvs extra_global_tvs
207 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
209 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
211 tcNewMutVar new_global_tyvars
214 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
215 To improve subsequent calls to the same function it writes the zonked set back into
219 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
221 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
222 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
223 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
225 global_tvs' = (tyVarsOfTypes global_tys')
227 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
228 returnNF_Tc global_tvs'
230 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
232 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
233 returnNF_Tc (varSetElems in_scope_tvs)
237 Type constructors and classes
240 tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
241 tcExtendTypeEnv bindings scope
242 = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
243 -- Not for tyvars; use tcExtendTyVarEnv
244 tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
246 te' = addListToUFM te bindings
248 tcSetEnv (TcEnv te' ve gtvs) scope
252 Looking up in the environments.
255 tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
257 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
258 case lookupUFM te name of {
259 Just thing -> returnNF_Tc thing ;
262 case maybeWiredInTyConName name of
263 Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc)
265 maybe_arity | isSynTyCon tc = Just (tyConArity tc)
266 | otherwise = Nothing
268 Nothing -> pprPanic "tcLookupTy" (ppr name)
271 tcLookupClass :: Name -> NF_TcM s Class
273 = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) ->
276 tcLookupTyCon :: Name -> NF_TcM s TyCon
278 = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) ->
281 tcLookupClassByKey :: Unique -> NF_TcM s Class
282 tcLookupClassByKey key
283 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
284 case lookupUFM_Directly te key of
285 Just (_, _, AClass cl) -> returnNF_Tc cl
286 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
288 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
289 tcLookupTyConByKey key
290 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
291 case lookupUFM_Directly te key of
292 Just (_, _, ATyCon tc) -> returnNF_Tc tc
293 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
299 %************************************************************************
301 \subsection{The value environment}
303 %************************************************************************
306 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
307 tcExtendGlobalValEnv ids scope
308 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
310 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
312 tcSetEnv (TcEnv te ve' gtvs) scope
314 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
315 tcExtendLocalValEnv names_w_ids scope
316 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
317 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
319 ve' = addListToUFM ve names_w_ids
320 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
322 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
323 tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
328 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
330 = case maybeWiredInIdName name of
331 Just id -> returnNF_Tc id
332 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
333 returnNF_Tc (lookupWithDefaultUFM ve def name)
335 def = pprPanic "tcLookupValue:" (ppr name)
337 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
338 tcLookupValueMaybe name
339 = case maybeWiredInIdName name of
340 Just id -> returnNF_Tc (Just id)
341 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
342 returnNF_Tc (lookupUFM ve name)
344 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
345 tcLookupValueByKey key
346 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
347 returnNF_Tc (explicitLookupValueByKey ve key)
349 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
350 tcLookupValueByKeyMaybe key
351 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
352 returnNF_Tc (lookupUFM_Directly ve key)
354 tcGetValueEnv :: NF_TcM s ValueEnv
356 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
359 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
360 tcSetValueEnv ve scope
361 = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
362 tcSetEnv (TcEnv te ve gtvs) scope
364 -- Non-monadic version, environment given explicitly
365 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
366 explicitLookupValueByKey ve key
367 = lookupWithDefaultUFM_Directly ve def key
369 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
371 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
372 explicitLookupValue ve name
373 = case maybeWiredInIdName name of
375 Nothing -> lookupUFM ve name
377 -- Extract the IdInfo from an IfaceSig imported from an interface file
378 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
379 tcAddImportedIdInfo unf_env id
380 | isLocallyDefined id -- Don't look up locally defined Ids, because they
381 -- have explicit local definitions, so we get a black hole!
384 = id `setIdInfo` new_info
385 -- The Id must be returned without a data dependency on maybe_id
387 new_info = -- pprTrace "tcAdd" (ppr id) $
388 case explicitLookupValue unf_env (getName id) of
390 Just imported_id -> idInfo imported_id
391 -- ToDo: could check that types are the same
395 %************************************************************************
397 \subsection{Constructing new Ids}
399 %************************************************************************
402 newLocalId :: OccName -> TcType -> NF_TcM s TcId
404 = tcGetUnique `thenNF_Tc` \ uniq ->
405 returnNF_Tc (mkUserLocal name uniq ty)
407 newLocalIds :: [OccName] -> [TcType] -> NF_TcM s [TcId]
408 newLocalIds names tys
409 = tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
411 new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys
412 mk_id name uniq ty = mkUserLocal name uniq ty
416 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
417 newSpecPragmaId name ty
418 = tcGetUnique `thenNF_Tc` \ uniq ->
419 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty)
423 %************************************************************************
427 %************************************************************************
431 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
433 = quotes (ppr op) <+> ptext SLIT("is not a primop")