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, tcLookupClassByKey_maybe,
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, isDataConWrapId_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 isDataConWrapId_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 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
336 tcLookupClassByKey_maybe key
337 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
338 case lookupUFM_Directly te key of
339 Just (_, _, AClass cl) -> returnNF_Tc (Just cl)
340 other -> returnNF_Tc Nothing
342 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
343 tcLookupTyConByKey key
344 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
345 case lookupUFM_Directly te key of
346 Just (_, _, ATyCon tc) -> returnNF_Tc tc
347 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
353 %************************************************************************
355 \subsection{The value environment}
357 %************************************************************************
360 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
361 tcExtendGlobalValEnv ids scope
362 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
364 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
366 tcSetEnv (TcEnv ue te ve' gtvs) scope
368 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
369 tcExtendLocalValEnv names_w_ids scope
370 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
371 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
373 ve' = addListToUFM ve names_w_ids
374 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
376 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
377 tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
382 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
384 = case maybeWiredInIdName name of
385 Just id -> returnNF_Tc id
386 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
387 returnNF_Tc (lookupWithDefaultUFM ve def name)
389 def = pprPanic "tcLookupValue:" (ppr name)
391 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
392 tcLookupValueMaybe name
393 = case maybeWiredInIdName name of
394 Just id -> returnNF_Tc (Just id)
395 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
396 returnNF_Tc (lookupUFM ve name)
398 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
399 tcLookupValueByKey key
400 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
401 returnNF_Tc (explicitLookupValueByKey ve key)
403 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
404 tcLookupValueByKeyMaybe key
405 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
406 returnNF_Tc (lookupUFM_Directly ve key)
408 tcGetValueEnv :: NF_TcM s ValueEnv
410 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
413 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
414 tcSetValueEnv ve scope
415 = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
416 tcSetEnv (TcEnv ue te ve gtvs) scope
418 -- Non-monadic version, environment given explicitly
419 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
420 explicitLookupValueByKey ve key
421 = lookupWithDefaultUFM_Directly ve def key
423 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
425 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
426 explicitLookupValue ve name
427 = case maybeWiredInIdName name of
429 Nothing -> lookupUFM ve name
431 -- Extract the IdInfo from an IfaceSig imported from an interface file
432 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
433 tcAddImportedIdInfo unf_env id
434 | isLocallyDefined id -- Don't look up locally defined Ids, because they
435 -- have explicit local definitions, so we get a black hole!
438 = id `lazySetIdInfo` new_info
439 -- The Id must be returned without a data dependency on maybe_id
441 new_info = -- pprTrace "tcAdd" (ppr id) $
442 case explicitLookupValue unf_env (getName id) of
443 Nothing -> vanillaIdInfo
444 Just imported_id -> idInfo imported_id
445 -- ToDo: could check that types are the same
449 %************************************************************************
451 \subsection{Constructing new Ids}
453 %************************************************************************
456 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
457 newLocalId name ty loc
458 = tcGetUnique `thenNF_Tc` \ uniq ->
459 returnNF_Tc (mkUserLocal name uniq ty loc)
461 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
462 newSpecPragmaId name ty
463 = tcGetUnique `thenNF_Tc` \ uniq ->
464 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
468 %************************************************************************
472 %************************************************************************
476 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
478 = quotes (ppr op) <+> ptext SLIT("is not a primop")
480 uvNameOutOfScope name
481 = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
483 tyNameOutOfScope name
484 = quotes (ppr name) <+> ptext SLIT("is not in scope")