3 TcId, TcIdSet, tcInstId,
6 TcEnv, ValueEnv, TcTyThing(..),
8 initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
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, lazySetIdInfo, idInfo, tyVarKind
38 import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
39 tcInstTyVars, zonkTcTyVars,
44 import Type ( Kind, superKind,
45 tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
46 splitForAllTys, splitRhoTy, splitFunTys,
47 splitAlgTyConApp_maybe, getTyVar
49 import Subst ( substTy )
50 import UsageSPUtils ( unannotTy )
51 import DataCon ( DataCon )
52 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
53 import Class ( Class, classTyCon )
57 import BasicTypes ( Arity )
58 import IdInfo ( vanillaIdInfo )
59 import Name ( Name, OccName, nameOccName, getSrcLoc,
60 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
63 import Unique ( pprUnique10, Unique, Uniquable(..) )
64 import FiniteMap ( lookupFM, addToFM )
66 import Unique ( Uniquable(..) )
67 import Util ( zipEqual, zipWith3Equal, mapAccumL )
68 import Bag ( bagToList )
69 import Maybes ( maybeToBool, catMaybes )
70 import SrcLoc ( SrcLoc )
71 import FastString ( FastString )
75 %************************************************************************
79 %************************************************************************
83 type TcId = Id -- Type may be a TcType
86 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
87 tcLookupDataCon con_name
88 = tcLookupValue con_name `thenNF_Tc` \ con_id ->
89 case isDataConId_maybe con_id of {
90 Nothing -> failWithTc (badCon con_id);
93 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
94 -- Ignore the con_theta; overloaded constructors only
95 -- behave differently when called, not when used for
98 (arg_tys, result_ty) = splitFunTys con_tau
100 ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
101 returnTc (data_con, arg_tys, result_ty) }
103 -- A useful function that takes an occurrence of a global thing
104 -- and instantiates its type with fresh type variables
106 -> NF_TcM s ([TcTyVar], -- It's instantiated type
111 (tyvars, rho) = splitForAllTys (unannotTy (idType id))
113 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
115 rho' = substTy tenv rho
116 (theta', tau') = splitRhoTy rho'
118 returnNF_Tc (tyvars', theta', tau')
121 Between the renamer and the first invocation of the UsageSP inference,
122 identifiers read from interface files will have usage information in
123 their types, whereas other identifiers will not. The unannotTy here
124 in @tcInstId@ prevents this information from pointlessly propagating
125 further prior to the first usage inference.
128 %************************************************************************
132 %************************************************************************
134 Data type declarations
135 ~~~~~~~~~~~~~~~~~~~~~
141 (TcTyVarSet, -- The in-scope TyVars
142 TcRef TcTyVarSet) -- Free type variables of the value env
143 -- ...why mutable? see notes with tcGetGlobalTyVars
144 -- Includes the in-scope tyvars
146 type NameEnv val = UniqFM val -- Keyed by Names
148 type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
149 type ValueEnv = NameEnv Id
151 data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
152 -- if the kind is mutable, the tyvar must be so that
158 initEnv :: TcRef TcTyVarSet -> TcEnv
159 initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
161 getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
162 getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
163 getAllEnvTyCons (TcEnv te _ _) = catMaybes (map gettc (eltsUFM te))
165 gettc (_,_, ATyCon tc) = Just tc
166 gettc (_,_, AClass cl) = Just (classTyCon cl)
173 Extending the type environment.
176 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
177 tcExtendTyVarEnv tyvars scope
178 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
180 extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
183 te' = addListToUFM te extend_list
184 new_tv_set = mkVarSet tyvars
185 in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
187 -- It's important to add the in-scope tyvars to the global tyvar set
189 -- f (x::r) = let g y = y::r in ...
190 -- Here, g mustn't be generalised. This is also important during
191 -- class and instance decls, when we mustn't generalise the class tyvars
192 -- when typechecking the methods.
193 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
194 tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
196 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
197 -- the signature tyvars contain the original names
198 -- the instance tyvars are what those names should be mapped to
199 -- It's needed when typechecking the method bindings of class and instance decls
200 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
202 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
203 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
204 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
206 te' = addListToUFM te stuff
208 tcSetEnv (TcEnv te' ve gtvs) thing_inside
210 stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
211 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
214 tcExtendGlobalTyVars extra_global_tvs scope
215 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
216 tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
217 tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
219 tc_extend_gtvs gtvs extra_global_tvs
220 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
222 new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
224 tcNewMutVar new_global_tyvars
227 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
228 To improve subsequent calls to the same function it writes the zonked set back into
232 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
234 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
235 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
236 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
238 global_tvs' = (tyVarsOfTypes global_tys')
240 tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
241 returnNF_Tc global_tvs'
243 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
245 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
246 returnNF_Tc (varSetElems in_scope_tvs)
250 Type constructors and classes
253 tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
254 tcExtendTypeEnv bindings scope
255 = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
256 -- Not for tyvars; use tcExtendTyVarEnv
257 tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
259 te' = addListToUFM te bindings
261 tcSetEnv (TcEnv te' ve gtvs) scope
265 Looking up in the environments.
268 tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
270 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
271 case lookupUFM te name of {
272 Just thing -> returnNF_Tc thing ;
275 case maybeWiredInTyConName name of
276 Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc)
278 maybe_arity | isSynTyCon tc = Just (tyConArity tc)
279 | otherwise = Nothing
281 Nothing -> -- This can happen if an interface-file
282 -- unfolding is screwed up
283 failWithTc (tyNameOutOfScope name)
286 tcLookupClass :: Name -> NF_TcM s Class
288 = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) ->
291 tcLookupTyCon :: Name -> NF_TcM s TyCon
293 = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) ->
296 tcLookupClassByKey :: Unique -> NF_TcM s Class
297 tcLookupClassByKey key
298 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
299 case lookupUFM_Directly te key of
300 Just (_, _, AClass cl) -> returnNF_Tc cl
301 other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
303 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
304 tcLookupTyConByKey key
305 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
306 case lookupUFM_Directly te key of
307 Just (_, _, ATyCon tc) -> returnNF_Tc tc
308 other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
314 %************************************************************************
316 \subsection{The value environment}
318 %************************************************************************
321 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
322 tcExtendGlobalValEnv ids scope
323 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
325 ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
327 tcSetEnv (TcEnv te ve' gtvs) scope
329 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
330 tcExtendLocalValEnv names_w_ids scope
331 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
332 tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
334 ve' = addListToUFM ve names_w_ids
335 extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
337 tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
338 tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
343 tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
345 = case maybeWiredInIdName name of
346 Just id -> returnNF_Tc id
347 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
348 returnNF_Tc (lookupWithDefaultUFM ve def name)
350 def = pprPanic "tcLookupValue:" (ppr name)
352 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
353 tcLookupValueMaybe name
354 = case maybeWiredInIdName name of
355 Just id -> returnNF_Tc (Just id)
356 Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
357 returnNF_Tc (lookupUFM ve name)
359 tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
360 tcLookupValueByKey key
361 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
362 returnNF_Tc (explicitLookupValueByKey ve key)
364 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
365 tcLookupValueByKeyMaybe key
366 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
367 returnNF_Tc (lookupUFM_Directly ve key)
369 tcGetValueEnv :: NF_TcM s ValueEnv
371 = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
374 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
375 tcSetValueEnv ve scope
376 = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
377 tcSetEnv (TcEnv te ve gtvs) scope
379 -- Non-monadic version, environment given explicitly
380 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
381 explicitLookupValueByKey ve key
382 = lookupWithDefaultUFM_Directly ve def key
384 def = pprPanic "lookupValueByKey:" (pprUnique10 key)
386 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
387 explicitLookupValue ve name
388 = case maybeWiredInIdName name of
390 Nothing -> lookupUFM ve name
392 -- Extract the IdInfo from an IfaceSig imported from an interface file
393 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
394 tcAddImportedIdInfo unf_env id
395 | isLocallyDefined id -- Don't look up locally defined Ids, because they
396 -- have explicit local definitions, so we get a black hole!
399 = id `lazySetIdInfo` new_info
400 -- The Id must be returned without a data dependency on maybe_id
402 new_info = -- pprTrace "tcAdd" (ppr id) $
403 case explicitLookupValue unf_env (getName id) of
404 Nothing -> vanillaIdInfo
405 Just imported_id -> idInfo imported_id
406 -- ToDo: could check that types are the same
410 %************************************************************************
412 \subsection{Constructing new Ids}
414 %************************************************************************
417 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
418 newLocalId name ty loc
419 = tcGetUnique `thenNF_Tc` \ uniq ->
420 returnNF_Tc (mkUserLocal name uniq ty loc)
422 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
423 newSpecPragmaId name ty
424 = tcGetUnique `thenNF_Tc` \ uniq ->
425 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
429 %************************************************************************
433 %************************************************************************
437 = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
439 = quotes (ppr op) <+> ptext SLIT("is not a primop")
441 tyNameOutOfScope name
442 = quotes (ppr name) <+> ptext SLIT("is not in scope")