4 TyThing(..), TyThingDetails(..), TcTyThing(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
10 -- Instance environment
11 tcGetInstEnv, tcSetInstEnv,
14 tcExtendGlobalEnv, tcExtendGlobalValEnv,
15 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
16 tcLookupGlobal_maybe, tcLookupGlobal,
20 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
21 tcExtendLocalValEnv, tcLookup,
23 -- Global type variables
24 tcGetGlobalTyVars, tcExtendGlobalTyVars,
26 -- Random useful things
27 tcAddImportedIdInfo, tcInstId,
30 newLocalId, newSpecPragmaId,
31 newDefaultMethodName, newDFunName,
34 tcSetEnv, explicitLookupId
37 #include "HsVersions.h"
40 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
41 tcInstTyVars, zonkTcTyVars,
43 import Id ( mkUserLocal, isDataConWrapId_maybe )
44 import IdInfo ( vanillaIdInfo )
45 import MkId ( mkSpecPragmaId )
46 import Var ( TyVar, Id, setVarName,
47 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
50 import Type ( Kind, Type, superKind,
51 tyVarsOfType, tyVarsOfTypes,
52 splitForAllTys, splitRhoTy, splitFunTys,
53 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
55 import DataCon ( DataCon )
56 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
57 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
58 import Subst ( substTy )
59 import Name ( Name, OccName, NamedThing(..),
60 nameOccName, nameModule, getSrcLoc, mkGlobalName,
62 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
63 extendNameEnv, extendNameEnvList
65 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
66 import Module ( Module )
67 import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
68 GlobalSymbolTable, Provenance(..) )
69 import Unique ( pprUnique10, Unique, Uniquable(..) )
71 import Unique ( Uniquable(..) )
72 import Util ( zipEqual, zipWith3Equal, mapAccumL )
73 import SrcLoc ( SrcLoc )
74 import FastString ( FastString )
76 import TcInstUtil ( emptyInstEnv )
78 import IOExts ( newIORef )
81 %************************************************************************
85 %************************************************************************
88 type TcId = Id -- Type may be a TcType
93 tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
95 tcInsts :: InstEnv, -- All instances (both imported and in this module)
97 tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while
98 {- TypeEnv -} -- compiling this module:
99 -- types and classes (both imported and local)
101 -- (Ids defined in this module are in the local envt)
103 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
104 -- defined in this module
106 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
107 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
108 -- mentioned in the types of Ids bound in tcLEnv
109 -- Why mutable? see notes with tcGetGlobalTyVars
114 The Global-Env/Local-Env story
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 During type checking, we keep in the GlobalEnv
117 * All types and classes
118 * All Ids derived from types and classes (constructors, selectors)
121 At the end of type checking, we zonk the local bindings,
122 and as we do so we add to the GlobalEnv
123 * Locally defined top-level Ids
125 Why? Because they are now Ids not TcIds. This final GlobalEnv is
127 a) fed back (via the knot) to typechecking the
128 unfoldings of interface signatures
130 b) used to augment the GlobalSymbolTable
135 = AGlobal TyThing -- Used only in the return type of a lookup
136 | ATcId TcId -- Ids defined in this module
137 | ATyVar TyVar -- Type variables
138 | AThing TcKind -- Used temporarily, during kind checking
139 -- Here's an example of how the AThing guy is used
140 -- Suppose we are checking (forall a. T a Int):
141 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
142 -- 2. Then we kind-check the (T a Int) part.
143 -- 3. Then we zonk the kind variable.
144 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
146 initTcEnv :: GlobalSymbolTable -> IO TcEnv
148 = do { gtv_var <- newIORef emptyVarSet ;
149 return (TcEnv { tcGST = gst,
150 tcGEnv = emptyNameEnv,
151 tcInsts = emptyInstEnv,
152 tcLEnv = emptyNameEnv,
156 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
157 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
158 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
159 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
160 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
162 -- This data type is used to help tie the knot
163 -- when type checking type and class declarations
164 data TyThingDetails = SynTyDetails Type
165 | DataTyDetails ClassContext [DataCon] [Class]
166 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
170 %************************************************************************
172 \subsection{Basic lookups}
174 %************************************************************************
177 lookup_global :: TcEnv -> Name -> Maybe TyThing
178 -- Try the global envt and then the global symbol table
179 lookup_global env name
180 = case lookupNameEnv (tcGEnv env) name of
181 Just thing -> Just thing
182 Nothing -> lookupTypeEnv (tcGST env) name
184 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
185 -- Try the local envt and then try the global
186 lookup_local env name
187 = case lookupNameEnv (tcLEnv env) name of
188 Just thing -> Just thing
189 Nothing -> case lookup_global env name of
190 Just thing -> Just (AGlobal thing)
193 explicitLookupId :: TcEnv -> Name -> Maybe Id
194 explicitLookupId env name = case lookup_global env name of
195 Just (AnId id) -> Just id
200 %************************************************************************
202 \subsection{Random useful functions}
204 %************************************************************************
208 -- A useful function that takes an occurrence of a global thing
209 -- and instantiates its type with fresh type variables
211 -> NF_TcM ([TcTyVar], -- It's instantiated type
216 (tyvars, rho) = splitForAllTys (idType id)
218 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
220 rho' = substTy tenv rho
221 (theta', tau') = splitRhoTy rho'
223 returnNF_Tc (tyvars', theta', tau')
225 tcAddImportedIdInfo :: TcEnv -> Id -> Id
226 tcAddImportedIdInfo unf_env id
227 | isLocallyDefined id -- Don't look up locally defined Ids, because they
228 -- have explicit local definitions, so we get a black hole!
231 = id `lazySetIdInfo` new_info
232 -- The Id must be returned without a data dependency on maybe_id
234 new_info = case explicitLookupId unf_env (getName id) of
235 Nothing -> vanillaIdInfo
236 Just imported_id -> idInfo imported_id
237 -- ToDo: could check that types are the same
241 %************************************************************************
243 \subsection{Making new Ids}
245 %************************************************************************
250 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
251 newLocalId name ty loc
252 = tcGetUnique `thenNF_Tc` \ uniq ->
253 returnNF_Tc (mkUserLocal name uniq ty loc)
255 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
256 newSpecPragmaId name ty
257 = tcGetUnique `thenNF_Tc` \ uniq ->
258 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
261 Make a name for the dict fun for an instance decl
264 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
265 newDFunName mod clas (ty:_) loc
266 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
267 tcGetUnique `thenNF_Tc` \ uniq ->
268 returnNF_Tc (mkGlobalName uniq mod
269 (mkDFunOcc dfun_string inst_uniq)
272 -- Any string that is somewhat unique will do
273 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
275 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
276 newDefaultMethodName op_name loc
277 = tcGetUnique `thenNF_Tc` \ uniq ->
278 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
279 (mkDefaultMethodOcc (getOccName op_name))
284 %************************************************************************
286 \subsection{The global environment}
288 %************************************************************************
291 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
292 tcExtendGlobalEnv bindings thing_inside
293 = tcGetEnv `thenNF_Tc` \ env ->
295 ge' = extendNameEnvList (tcGEnv env) bindings
297 tcSetEnv (env {tcGEnv = ge'}) thing_inside
299 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
300 tcExtendGlobalValEnv ids thing_inside
301 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
306 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
307 tcLookupGlobal_maybe name
308 = tcGetEnv `thenNF_Tc` \ env ->
309 returnNF_Tc (lookup_global env name)
312 A variety of global lookups, when we know what we are looking for.
315 tcLookupGlobal :: Name -> NF_TcM TyThing
317 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
319 Just thing -> returnNF_Tc thing
320 other -> notFound "tcLookupGlobal:" name
322 tcLookupGlobalId :: Name -> NF_TcM Id
323 tcLookupGlobalId name
324 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
326 Just (AnId clas) -> returnNF_Tc clas
327 other -> notFound "tcLookupGlobalId:" name
329 tcLookupDataCon :: Name -> TcM DataCon
330 tcLookupDataCon con_name
331 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
332 case isDataConWrapId_maybe con_id of
333 Just data_con -> returnTc data_con
334 Nothing -> failWithTc (badCon con_id)
337 tcLookupClass :: Name -> NF_TcM Class
339 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
341 Just (AClass clas) -> returnNF_Tc clas
342 other -> notFound "tcLookupClass:" name
344 tcLookupTyCon :: Name -> NF_TcM TyCon
346 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
348 Just (ATyCon tc) -> returnNF_Tc tc
349 other -> notFound "tcLookupTyCon:" name
353 %************************************************************************
355 \subsection{The local environment}
357 %************************************************************************
360 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
362 = tcGetEnv `thenNF_Tc` \ env ->
363 returnNF_Tc (lookup_local env name)
365 tcLookup :: Name -> NF_TcM TcTyThing
367 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
369 Just thing -> returnNF_Tc thing
370 other -> notFound "tcLookup:" name
371 -- Extract the IdInfo from an IfaceSig imported from an interface file
376 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
377 tcExtendKindEnv pairs thing_inside
378 = tcGetEnv `thenNF_Tc` \ env ->
380 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
381 -- No need to extend global tyvars for kind checking
383 tcSetEnv (env {tcLEnv = le'}) thing_inside
385 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
386 tcExtendTyVarEnv tyvars thing_inside
387 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
389 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
390 new_tv_set = mkVarSet tyvars
392 -- It's important to add the in-scope tyvars to the global tyvar set
394 -- f (x::r) = let g y = y::r in ...
395 -- Here, g mustn't be generalised. This is also important during
396 -- class and instance decls, when we mustn't generalise the class tyvars
397 -- when typechecking the methods.
398 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
399 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
401 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
402 -- the signature tyvars contain the original names
403 -- the instance tyvars are what those names should be mapped to
404 -- It's needed when typechecking the method bindings of class and instance decls
405 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
407 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
408 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
409 = tcGetEnv `thenNF_Tc` \ env ->
411 le' = extendNameEnvList (tcLEnv env) stuff
412 stuff = [ (getName sig_tv, ATyVar inst_tv)
413 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
416 tcSetEnv (env {tcLEnv = le'}) thing_inside
421 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
422 tcExtendLocalValEnv names_w_ids thing_inside
423 = tcGetEnv `thenNF_Tc` \ env ->
425 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
426 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
427 le' = extendNameEnvList (tcLEnv env) extra_env
429 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
430 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
434 %************************************************************************
436 \subsection{The global tyvars}
438 %************************************************************************
441 tcExtendGlobalTyVars extra_global_tvs thing_inside
442 = tcGetEnv `thenNF_Tc` \ env ->
443 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
444 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
446 tc_extend_gtvs gtvs extra_global_tvs
447 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
448 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
451 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
452 To improve subsequent calls to the same function it writes the zonked set back into
456 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
458 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
459 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
460 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
462 global_tvs' = (tyVarsOfTypes global_tys')
464 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
465 returnNF_Tc global_tvs'
469 %************************************************************************
471 \subsection{The instance environment}
473 %************************************************************************
476 tcGetInstEnv :: NF_TcM InstEnv
477 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
478 returnNF_Tc (tcInsts env)
480 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
481 tcSetInstEnv ie thing_inside
482 = tcGetEnv `thenNF_Tc` \ env ->
483 tcSetEnv (env {tcInsts = ie}) thing_inside
487 %************************************************************************
491 %************************************************************************
494 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
496 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
497 ptext SLIT("is not in scope"))