4 TyThing(..), TyThingDetails(..), TcTyThing(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
11 -- Instance environment
12 tcGetInstEnv, tcSetInstEnv,
15 tcExtendGlobalEnv, tcExtendGlobalValEnv,
16 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
17 tcLookupGlobal_maybe, tcLookupGlobal,
21 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
22 tcExtendLocalValEnv, tcLookup,
24 -- Global type variables
25 tcGetGlobalTyVars, tcExtendGlobalTyVars,
27 -- Random useful things
28 tcAddImportedIdInfo, tcInstId,
31 newLocalId, newSpecPragmaId,
32 newDefaultMethodName, newDFunName,
35 tcSetEnv, explicitLookupId
38 #include "HsVersions.h"
41 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
42 tcInstTyVars, zonkTcTyVars,
44 import Id ( mkUserLocal, isDataConWrapId_maybe )
45 import IdInfo ( vanillaIdInfo )
46 import MkId ( mkSpecPragmaId )
47 import Var ( TyVar, Id, setVarName,
48 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
51 import Type ( Kind, Type, superKind,
52 tyVarsOfType, tyVarsOfTypes,
53 splitForAllTys, splitRhoTy, splitFunTys,
54 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
56 import DataCon ( DataCon )
57 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
58 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
59 import Subst ( substTy )
60 import Name ( Name, OccName, NamedThing(..),
61 nameOccName, nameModule, getSrcLoc, mkGlobalName,
63 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
64 extendNameEnv, extendNameEnvList
66 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
67 import Module ( Module )
68 import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
69 GlobalSymbolTable, Provenance(..) )
70 import Unique ( pprUnique10, Unique, Uniquable(..) )
72 import Unique ( Uniquable(..) )
73 import Util ( zipEqual, zipWith3Equal, mapAccumL )
74 import SrcLoc ( SrcLoc )
75 import FastString ( FastString )
77 import TcInstUtil ( emptyInstEnv )
79 import IOExts ( newIORef )
82 %************************************************************************
86 %************************************************************************
89 type TcId = Id -- Type may be a TcType
94 tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
96 tcInsts :: InstEnv, -- All instances (both imported and in this module)
98 tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while
99 {- TypeEnv -} -- compiling this module:
100 -- types and classes (both imported and local)
102 -- (Ids defined in this module are in the local envt)
104 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
105 -- defined in this module
107 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
108 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
109 -- mentioned in the types of Ids bound in tcLEnv
110 -- Why mutable? see notes with tcGetGlobalTyVars
115 The Global-Env/Local-Env story
116 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 During type checking, we keep in the GlobalEnv
118 * All types and classes
119 * All Ids derived from types and classes (constructors, selectors)
122 At the end of type checking, we zonk the local bindings,
123 and as we do so we add to the GlobalEnv
124 * Locally defined top-level Ids
126 Why? Because they are now Ids not TcIds. This final GlobalEnv is
128 a) fed back (via the knot) to typechecking the
129 unfoldings of interface signatures
131 b) used to augment the GlobalSymbolTable
136 = AGlobal TyThing -- Used only in the return type of a lookup
137 | ATcId TcId -- Ids defined in this module
138 | ATyVar TyVar -- Type variables
139 | AThing TcKind -- Used temporarily, during kind checking
140 -- Here's an example of how the AThing guy is used
141 -- Suppose we are checking (forall a. T a Int):
142 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
143 -- 2. Then we kind-check the (T a Int) part.
144 -- 3. Then we zonk the kind variable.
145 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
147 initTcEnv :: GlobalSymbolTable -> IO TcEnv
149 = do { gtv_var <- newIORef emptyVarSet ;
150 return (TcEnv { tcGST = gst,
151 tcGEnv = emptyNameEnv,
152 tcInsts = emptyInstEnv,
153 tcLEnv = emptyNameEnv,
157 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
158 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
159 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
160 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
161 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
163 getTcGST (TcEnv { tcGST = gst }) = gst
164 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
166 -- This data type is used to help tie the knot
167 -- when type checking type and class declarations
168 data TyThingDetails = SynTyDetails Type
169 | DataTyDetails ClassContext [DataCon] [Class]
170 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
174 %************************************************************************
176 \subsection{Basic lookups}
178 %************************************************************************
181 lookup_global :: TcEnv -> Name -> Maybe TyThing
182 -- Try the global envt and then the global symbol table
183 lookup_global env name
184 = case lookupNameEnv (tcGEnv env) name of
185 Just thing -> Just thing
186 Nothing -> lookupTypeEnv (tcGST env) name
188 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
189 -- Try the local envt and then try the global
190 lookup_local env name
191 = case lookupNameEnv (tcLEnv env) name of
192 Just thing -> Just thing
193 Nothing -> case lookup_global env name of
194 Just thing -> Just (AGlobal thing)
197 explicitLookupId :: TcEnv -> Name -> Maybe Id
198 explicitLookupId env name = case lookup_global env name of
199 Just (AnId id) -> Just id
204 %************************************************************************
206 \subsection{Random useful functions}
208 %************************************************************************
212 -- A useful function that takes an occurrence of a global thing
213 -- and instantiates its type with fresh type variables
215 -> NF_TcM ([TcTyVar], -- It's instantiated type
220 (tyvars, rho) = splitForAllTys (idType id)
222 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
224 rho' = substTy tenv rho
225 (theta', tau') = splitRhoTy rho'
227 returnNF_Tc (tyvars', theta', tau')
229 tcAddImportedIdInfo :: TcEnv -> Id -> Id
230 tcAddImportedIdInfo unf_env id
231 | isLocallyDefined id -- Don't look up locally defined Ids, because they
232 -- have explicit local definitions, so we get a black hole!
235 = id `lazySetIdInfo` new_info
236 -- The Id must be returned without a data dependency on maybe_id
238 new_info = case explicitLookupId unf_env (getName id) of
239 Nothing -> vanillaIdInfo
240 Just imported_id -> idInfo imported_id
241 -- ToDo: could check that types are the same
245 %************************************************************************
247 \subsection{Making new Ids}
249 %************************************************************************
254 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
255 newLocalId name ty loc
256 = tcGetUnique `thenNF_Tc` \ uniq ->
257 returnNF_Tc (mkUserLocal name uniq ty loc)
259 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
260 newSpecPragmaId name ty
261 = tcGetUnique `thenNF_Tc` \ uniq ->
262 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
265 Make a name for the dict fun for an instance decl
268 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
269 newDFunName mod clas (ty:_) loc
270 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
271 tcGetUnique `thenNF_Tc` \ uniq ->
272 returnNF_Tc (mkGlobalName uniq mod
273 (mkDFunOcc dfun_string inst_uniq)
276 -- Any string that is somewhat unique will do
277 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
279 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
280 newDefaultMethodName op_name loc
281 = tcGetUnique `thenNF_Tc` \ uniq ->
282 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
283 (mkDefaultMethodOcc (getOccName op_name))
288 %************************************************************************
290 \subsection{The global environment}
292 %************************************************************************
295 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
296 tcExtendGlobalEnv bindings thing_inside
297 = tcGetEnv `thenNF_Tc` \ env ->
299 ge' = extendNameEnvList (tcGEnv env) bindings
301 tcSetEnv (env {tcGEnv = ge'}) thing_inside
303 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
304 tcExtendGlobalValEnv ids thing_inside
305 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
310 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
311 tcLookupGlobal_maybe name
312 = tcGetEnv `thenNF_Tc` \ env ->
313 returnNF_Tc (lookup_global env name)
316 A variety of global lookups, when we know what we are looking for.
319 tcLookupGlobal :: Name -> NF_TcM TyThing
321 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
323 Just thing -> returnNF_Tc thing
324 other -> notFound "tcLookupGlobal:" name
326 tcLookupGlobalId :: Name -> NF_TcM Id
327 tcLookupGlobalId name
328 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
330 Just (AnId clas) -> returnNF_Tc clas
331 other -> notFound "tcLookupGlobalId:" name
333 tcLookupDataCon :: Name -> TcM DataCon
334 tcLookupDataCon con_name
335 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
336 case isDataConWrapId_maybe con_id of
337 Just data_con -> returnTc data_con
338 Nothing -> failWithTc (badCon con_id)
341 tcLookupClass :: Name -> NF_TcM Class
343 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
345 Just (AClass clas) -> returnNF_Tc clas
346 other -> notFound "tcLookupClass:" name
348 tcLookupTyCon :: Name -> NF_TcM TyCon
350 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
352 Just (ATyCon tc) -> returnNF_Tc tc
353 other -> notFound "tcLookupTyCon:" name
357 %************************************************************************
359 \subsection{The local environment}
361 %************************************************************************
364 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
366 = tcGetEnv `thenNF_Tc` \ env ->
367 returnNF_Tc (lookup_local env name)
369 tcLookup :: Name -> NF_TcM TcTyThing
371 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
373 Just thing -> returnNF_Tc thing
374 other -> notFound "tcLookup:" name
375 -- Extract the IdInfo from an IfaceSig imported from an interface file
380 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
381 tcExtendKindEnv pairs thing_inside
382 = tcGetEnv `thenNF_Tc` \ env ->
384 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
385 -- No need to extend global tyvars for kind checking
387 tcSetEnv (env {tcLEnv = le'}) thing_inside
389 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
390 tcExtendTyVarEnv tyvars thing_inside
391 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
393 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
394 new_tv_set = mkVarSet tyvars
396 -- It's important to add the in-scope tyvars to the global tyvar set
398 -- f (x::r) = let g y = y::r in ...
399 -- Here, g mustn't be generalised. This is also important during
400 -- class and instance decls, when we mustn't generalise the class tyvars
401 -- when typechecking the methods.
402 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
403 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
405 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
406 -- the signature tyvars contain the original names
407 -- the instance tyvars are what those names should be mapped to
408 -- It's needed when typechecking the method bindings of class and instance decls
409 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
411 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
412 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
413 = tcGetEnv `thenNF_Tc` \ env ->
415 le' = extendNameEnvList (tcLEnv env) stuff
416 stuff = [ (getName sig_tv, ATyVar inst_tv)
417 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
420 tcSetEnv (env {tcLEnv = le'}) thing_inside
425 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
426 tcExtendLocalValEnv names_w_ids thing_inside
427 = tcGetEnv `thenNF_Tc` \ env ->
429 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
430 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
431 le' = extendNameEnvList (tcLEnv env) extra_env
433 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
434 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
438 %************************************************************************
440 \subsection{The global tyvars}
442 %************************************************************************
445 tcExtendGlobalTyVars extra_global_tvs thing_inside
446 = tcGetEnv `thenNF_Tc` \ env ->
447 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
448 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
450 tc_extend_gtvs gtvs extra_global_tvs
451 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
452 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
455 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
456 To improve subsequent calls to the same function it writes the zonked set back into
460 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
462 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
463 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
464 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
466 global_tvs' = (tyVarsOfTypes global_tys')
468 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
469 returnNF_Tc global_tvs'
473 %************************************************************************
475 \subsection{The instance environment}
477 %************************************************************************
480 tcGetInstEnv :: NF_TcM InstEnv
481 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
482 returnNF_Tc (tcInsts env)
484 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
485 tcSetInstEnv ie thing_inside
486 = tcGetEnv `thenNF_Tc` \ env ->
487 tcSetEnv (env {tcInsts = ie}) thing_inside
491 %************************************************************************
495 %************************************************************************
498 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
500 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
501 ptext SLIT("is not in scope"))