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 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, getSrcLoc,
58 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
61 import Unique ( pprUnique10, Unique, Uniquable(..) )
62 import FiniteMap ( lookupFM, addToFM )
64 import Unique ( Uniquable(..) )
65 import Util ( zipEqual, zipWith3Equal, mapAccumL )
66 import Bag ( bagToList )
67 import Maybes ( maybeToBool )
68 import SrcLoc ( SrcLoc )
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 -> -- This can happen if an interface-file
269 -- unfolding is screwed up
270 failWithTc (tyNameOutOfScope name)
273 tcLookupClass :: Name -> NF_TcM s Class
275 = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) ->
278 tcLookupTyCon :: Name -> NF_TcM s TyCon
280 = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) ->
283 tcLookupClassByKey :: Unique -> NF_TcM s Class
284 tcLookupClassByKey key
285 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
286 case lookupUFM_Directly te key of
287 Just (_, _, AClass cl) -> returnNF_Tc cl
288 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
290 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
291 tcLookupTyConByKey key
292 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
293 case lookupUFM_Directly te key of
294 Just (_, _, ATyCon tc) -> returnNF_Tc tc
295 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
301 %************************************************************************
303 \subsection{The value environment}
305 %************************************************************************
308 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
309 tcExtendGlobalValEnv ids scope
310 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
312 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
314 tcSetEnv (TcEnv te ve' gtvs) scope
316 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
317 tcExtendLocalValEnv names_w_ids scope
318 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
319 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
321 ve' = addListToUFM ve names_w_ids
322 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
324 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
325 tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
330 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
332 = case maybeWiredInIdName name of
333 Just id -> returnNF_Tc id
334 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
335 returnNF_Tc (lookupWithDefaultUFM ve def name)
337 def = pprPanic "tcLookupValue:" (ppr name)
339 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
340 tcLookupValueMaybe name
341 = case maybeWiredInIdName name of
342 Just id -> returnNF_Tc (Just id)
343 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
344 returnNF_Tc (lookupUFM ve name)
346 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
347 tcLookupValueByKey key
348 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
349 returnNF_Tc (explicitLookupValueByKey ve key)
351 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
352 tcLookupValueByKeyMaybe key
353 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
354 returnNF_Tc (lookupUFM_Directly ve key)
356 tcGetValueEnv :: NF_TcM s ValueEnv
358 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
361 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
362 tcSetValueEnv ve scope
363 = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
364 tcSetEnv (TcEnv te ve gtvs) scope
366 -- Non-monadic version, environment given explicitly
367 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
368 explicitLookupValueByKey ve key
369 = lookupWithDefaultUFM_Directly ve def key
371 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
373 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
374 explicitLookupValue ve name
375 = case maybeWiredInIdName name of
377 Nothing -> lookupUFM ve name
379 -- Extract the IdInfo from an IfaceSig imported from an interface file
380 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
381 tcAddImportedIdInfo unf_env id
382 | isLocallyDefined id -- Don't look up locally defined Ids, because they
383 -- have explicit local definitions, so we get a black hole!
386 = id `setIdInfo` new_info
387 -- The Id must be returned without a data dependency on maybe_id
389 new_info = -- pprTrace "tcAdd" (ppr id) $
390 case explicitLookupValue unf_env (getName id) of
392 Just imported_id -> idInfo imported_id
393 -- ToDo: could check that types are the same
397 %************************************************************************
399 \subsection{Constructing new Ids}
401 %************************************************************************
404 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
405 newLocalId name ty loc
406 = tcGetUnique `thenNF_Tc` \ uniq ->
407 returnNF_Tc (mkUserLocal name uniq ty loc)
409 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
410 newSpecPragmaId name ty
411 = tcGetUnique `thenNF_Tc` \ uniq ->
412 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
416 %************************************************************************
420 %************************************************************************
424 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
426 = quotes (ppr op) <+> ptext SLIT("is not a primop")
428 tyNameOutOfScope name
429 = quotes (ppr name) <+> ptext SLIT("is not in scope")