3 TcId, TcIdSet, tcInstId,
6 TcEnv, ValueEnv, TcTyThing(..),
8 initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
10 tcExtendUVarEnv, tcLookupUVar,
12 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
15 tcLookupTyCon, tcLookupTyConByKey,
16 tcLookupClass, tcLookupClassByKey,
18 tcExtendGlobalValEnv, tcExtendLocalValEnv,
19 tcGetValueEnv, tcSetValueEnv,
22 tcLookupValue, tcLookupValueMaybe,
23 tcLookupValueByKey, tcLookupValueByKeyMaybe,
24 explicitLookupValueByKey, explicitLookupValue,
27 newLocalId, newSpecPragmaId,
28 tcGetGlobalTyVars, tcExtendGlobalTyVars,
33 #include "HsVersions.h"
35 import HsTypes ( HsTyVar, getTyVarName )
36 import Id ( mkUserLocal, isDataConId_maybe )
37 import MkId ( mkSpecPragmaId )
38 import Var ( TyVar, Id, setVarName,
39 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
41 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
42 tcInstTyVars, zonkTcTyVars,
47 import Type ( Kind, superKind,
48 tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
49 splitForAllTys, splitRhoTy, splitFunTys,
50 splitAlgTyConApp_maybe, getTyVar
52 import Subst ( substTy )
53 import UsageSPUtils ( unannotTy )
54 import DataCon ( DataCon )
55 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
56 import Class ( Class, classTyCon )
60 import BasicTypes ( Arity )
61 import IdInfo ( vanillaIdInfo )
62 import Name ( Name, OccName, nameOccName, getSrcLoc,
63 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
66 import Unique ( pprUnique10, Unique, Uniquable(..) )
67 import FiniteMap ( lookupFM, addToFM )
69 import Unique ( Uniquable(..) )
70 import Util ( zipEqual, zipWith3Equal, mapAccumL )
71 import Bag ( bagToList )
72 import Maybes ( maybeToBool, catMaybes )
73 import SrcLoc ( SrcLoc )
74 import FastString ( FastString )
78 %************************************************************************
82 %************************************************************************
86 type TcId = Id -- Type may be a TcType
89 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
90 tcLookupDataCon con_name
91 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
92 case isDataConId_maybe con_id of {
93 Nothing -> failWithTc (badCon con_id);
96 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
97 -- Ignore the con_theta; overloaded constructors only
98 -- behave differently when called, not when used for
101 (arg_tys, result_ty) = splitFunTys con_tau
103 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
104 returnTc (data_con, arg_tys, result_ty) }
106 -- A useful function that takes an occurrence of a global thing
107 -- and instantiates its type with fresh type variables
109 -> NF_TcM s ([TcTyVar], -- It's instantiated type
114 (tyvars, rho) = splitForAllTys (unannotTy (idType id))
116 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
118 rho' = substTy tenv rho
119 (theta', tau') = splitRhoTy rho'
121 returnNF_Tc (tyvars', theta', tau')
124 Between the renamer and the first invocation of the UsageSP inference,
125 identifiers read from interface files will have usage information in
126 their types, whereas other identifiers will not. The unannotTy here
127 in @tcInstId@ prevents this information from pointlessly propagating
128 further prior to the first usage inference.
131 %************************************************************************
135 %************************************************************************
137 Data type declarations
138 ~~~~~~~~~~~~~~~~~~~~~
145 (TcTyVarSet, -- The in-scope TyVars
146 TcRef TcTyVarSet) -- Free type variables of the value env
147 -- ...why mutable? see notes with tcGetGlobalTyVars
148 -- Includes the in-scope tyvars
150 type NameEnv val = UniqFM val -- Keyed by Names
152 type UsageEnv = NameEnv UVar
153 type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
154 type ValueEnv = NameEnv Id
156 valueEnvIds :: ValueEnv -> [Id]
157 valueEnvIds ve = eltsUFM ve
159 data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
160 -- if the kind is mutable, the tyvar must be so that
166 initEnv :: TcRef TcTyVarSet -> TcEnv
167 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
169 getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
170 getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
171 getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te))
173 gettc (_,_, ATyCon tc) = Just tc
174 gettc (_,_, AClass cl) = Just (classTyCon cl)
181 Extending the usage environment.
184 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
185 tcExtendUVarEnv uv_name uv scope
186 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
187 tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
190 Looking up in the environments.
193 tcLookupUVar :: Name -> NF_TcM s UVar
195 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
196 case lookupUFM ue uv_name of
197 Just uv -> returnNF_Tc uv
198 Nothing -> failWithTc (uvNameOutOfScope uv_name)
205 Extending the type environment.
208 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
209 tcExtendTyVarEnv tyvars scope
210 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
212 extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
215 te' = addListToUFM te extend_list
216 new_tv_set = mkVarSet tyvars
217 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
219 -- It's important to add the in-scope tyvars to the global tyvar set
221 -- f (x::r) = let g y = y::r in ...
222 -- Here, g mustn't be generalised. This is also important during
223 -- class and instance decls, when we mustn't generalise the class tyvars
224 -- when typechecking the methods.
225 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
226 tcSetEnv (TcEnv ue te' ve (in_scope_tvs', gtvs')) scope
228 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
229 -- the signature tyvars contain the original names
230 -- the instance tyvars are what those names should be mapped to
231 -- It's needed when typechecking the method bindings of class and instance decls
232 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
234 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
235 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
236 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
238 te' = addListToUFM te stuff
240 tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
242 stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
243 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
246 tcExtendGlobalTyVars extra_global_tvs scope
247 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope,gtvs)) ->
248 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
249 tcSetEnv (TcEnv ue te ve (in_scope,gtvs')) scope
251 tc_extend_gtvs gtvs extra_global_tvs
252 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
254 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
256 tcNewMutVar new_global_tyvars
259 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
260 To improve subsequent calls to the same function it writes the zonked set back into
264 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
266 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (_,gtvs)) ->
267 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
268 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
270 global_tvs' = (tyVarsOfTypes global_tys')
272 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
273 returnNF_Tc global_tvs'
275 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
277 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
278 returnNF_Tc (varSetElems in_scope_tvs)
282 Type constructors and classes
285 tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
286 tcExtendTypeEnv bindings scope
287 = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
288 -- Not for tyvars; use tcExtendTyVarEnv
289 tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
291 te' = addListToUFM te bindings
293 tcSetEnv (TcEnv ue te' ve gtvs) scope
297 Looking up in the environments.
300 tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
302 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
303 case lookupUFM te name of {
304 Just thing -> returnNF_Tc thing ;
307 case maybeWiredInTyConName name of
308 Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc)
310 maybe_arity | isSynTyCon tc = Just (tyConArity tc)
311 | otherwise = Nothing
313 Nothing -> -- This can happen if an interface-file
314 -- unfolding is screwed up
315 failWithTc (tyNameOutOfScope name)
318 tcLookupClass :: Name -> NF_TcM s Class
320 = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) ->
323 tcLookupTyCon :: Name -> NF_TcM s TyCon
325 = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) ->
328 tcLookupClassByKey :: Unique -> NF_TcM s Class
329 tcLookupClassByKey key
330 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
331 case lookupUFM_Directly te key of
332 Just (_, _, AClass cl) -> returnNF_Tc cl
333 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
335 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
336 tcLookupTyConByKey key
337 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
338 case lookupUFM_Directly te key of
339 Just (_, _, ATyCon tc) -> returnNF_Tc tc
340 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
346 %************************************************************************
348 \subsection{The value environment}
350 %************************************************************************
353 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
354 tcExtendGlobalValEnv ids scope
355 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
357 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
359 tcSetEnv (TcEnv ue te ve' gtvs) scope
361 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
362 tcExtendLocalValEnv names_w_ids scope
363 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
364 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
366 ve' = addListToUFM ve names_w_ids
367 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
369 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
370 tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
375 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
377 = case maybeWiredInIdName name of
378 Just id -> returnNF_Tc id
379 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
380 returnNF_Tc (lookupWithDefaultUFM ve def name)
382 def = pprPanic "tcLookupValue:" (ppr name)
384 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
385 tcLookupValueMaybe name
386 = case maybeWiredInIdName name of
387 Just id -> returnNF_Tc (Just id)
388 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
389 returnNF_Tc (lookupUFM ve name)
391 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
392 tcLookupValueByKey key
393 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
394 returnNF_Tc (explicitLookupValueByKey ve key)
396 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
397 tcLookupValueByKeyMaybe key
398 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
399 returnNF_Tc (lookupUFM_Directly ve key)
401 tcGetValueEnv :: NF_TcM s ValueEnv
403 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
406 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
407 tcSetValueEnv ve scope
408 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
409 tcSetEnv (TcEnv ue te ve gtvs) scope
411 -- Non-monadic version, environment given explicitly
412 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
413 explicitLookupValueByKey ve key
414 = lookupWithDefaultUFM_Directly ve def key
416 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
418 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
419 explicitLookupValue ve name
420 = case maybeWiredInIdName name of
422 Nothing -> lookupUFM ve name
424 -- Extract the IdInfo from an IfaceSig imported from an interface file
425 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
426 tcAddImportedIdInfo unf_env id
427 | isLocallyDefined id -- Don't look up locally defined Ids, because they
428 -- have explicit local definitions, so we get a black hole!
431 = id `lazySetIdInfo` new_info
432 -- The Id must be returned without a data dependency on maybe_id
434 new_info = -- pprTrace "tcAdd" (ppr id) $
435 case explicitLookupValue unf_env (getName id) of
436 Nothing -> vanillaIdInfo
437 Just imported_id -> idInfo imported_id
438 -- ToDo: could check that types are the same
442 %************************************************************************
444 \subsection{Constructing new Ids}
446 %************************************************************************
449 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
450 newLocalId name ty loc
451 = tcGetUnique `thenNF_Tc` \ uniq ->
452 returnNF_Tc (mkUserLocal name uniq ty loc)
454 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
455 newSpecPragmaId name ty
456 = tcGetUnique `thenNF_Tc` \ uniq ->
457 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
461 %************************************************************************
465 %************************************************************************
469 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
471 = quotes (ppr op) <+> ptext SLIT("is not a primop")
473 uvNameOutOfScope name
474 = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
476 tyNameOutOfScope name
477 = quotes (ppr name) <+> ptext SLIT("is not in scope")