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
165 -- This data type is used to help tie the knot
166 -- when type checking type and class declarations
167 data TyThingDetails = SynTyDetails Type
168 | DataTyDetails ClassContext [DataCon] [Class]
169 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
173 %************************************************************************
175 \subsection{Basic lookups}
177 %************************************************************************
180 lookup_global :: TcEnv -> Name -> Maybe TyThing
181 -- Try the global envt and then the global symbol table
182 lookup_global env name
183 = case lookupNameEnv (tcGEnv env) name of
184 Just thing -> Just thing
185 Nothing -> lookupTypeEnv (tcGST env) name
187 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
188 -- Try the local envt and then try the global
189 lookup_local env name
190 = case lookupNameEnv (tcLEnv env) name of
191 Just thing -> Just thing
192 Nothing -> case lookup_global env name of
193 Just thing -> Just (AGlobal thing)
196 explicitLookupId :: TcEnv -> Name -> Maybe Id
197 explicitLookupId env name = case lookup_global env name of
198 Just (AnId id) -> Just id
203 %************************************************************************
205 \subsection{Random useful functions}
207 %************************************************************************
211 -- A useful function that takes an occurrence of a global thing
212 -- and instantiates its type with fresh type variables
214 -> NF_TcM ([TcTyVar], -- It's instantiated type
219 (tyvars, rho) = splitForAllTys (idType id)
221 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
223 rho' = substTy tenv rho
224 (theta', tau') = splitRhoTy rho'
226 returnNF_Tc (tyvars', theta', tau')
228 tcAddImportedIdInfo :: TcEnv -> Id -> Id
229 tcAddImportedIdInfo unf_env id
230 | isLocallyDefined id -- Don't look up locally defined Ids, because they
231 -- have explicit local definitions, so we get a black hole!
234 = id `lazySetIdInfo` new_info
235 -- The Id must be returned without a data dependency on maybe_id
237 new_info = case explicitLookupId unf_env (getName id) of
238 Nothing -> vanillaIdInfo
239 Just imported_id -> idInfo imported_id
240 -- ToDo: could check that types are the same
244 %************************************************************************
246 \subsection{Making new Ids}
248 %************************************************************************
253 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
254 newLocalId name ty loc
255 = tcGetUnique `thenNF_Tc` \ uniq ->
256 returnNF_Tc (mkUserLocal name uniq ty loc)
258 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
259 newSpecPragmaId name ty
260 = tcGetUnique `thenNF_Tc` \ uniq ->
261 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
264 Make a name for the dict fun for an instance decl
267 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
268 newDFunName mod clas (ty:_) loc
269 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
270 tcGetUnique `thenNF_Tc` \ uniq ->
271 returnNF_Tc (mkGlobalName uniq mod
272 (mkDFunOcc dfun_string inst_uniq)
275 -- Any string that is somewhat unique will do
276 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
278 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
279 newDefaultMethodName op_name loc
280 = tcGetUnique `thenNF_Tc` \ uniq ->
281 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
282 (mkDefaultMethodOcc (getOccName op_name))
287 %************************************************************************
289 \subsection{The global environment}
291 %************************************************************************
294 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
295 tcExtendGlobalEnv bindings thing_inside
296 = tcGetEnv `thenNF_Tc` \ env ->
298 ge' = extendNameEnvList (tcGEnv env) bindings
300 tcSetEnv (env {tcGEnv = ge'}) thing_inside
302 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
303 tcExtendGlobalValEnv ids thing_inside
304 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
309 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
310 tcLookupGlobal_maybe name
311 = tcGetEnv `thenNF_Tc` \ env ->
312 returnNF_Tc (lookup_global env name)
315 A variety of global lookups, when we know what we are looking for.
318 tcLookupGlobal :: Name -> NF_TcM TyThing
320 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
322 Just thing -> returnNF_Tc thing
323 other -> notFound "tcLookupGlobal:" name
325 tcLookupGlobalId :: Name -> NF_TcM Id
326 tcLookupGlobalId name
327 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
329 Just (AnId clas) -> returnNF_Tc clas
330 other -> notFound "tcLookupGlobalId:" name
332 tcLookupDataCon :: Name -> TcM DataCon
333 tcLookupDataCon con_name
334 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
335 case isDataConWrapId_maybe con_id of
336 Just data_con -> returnTc data_con
337 Nothing -> failWithTc (badCon con_id)
340 tcLookupClass :: Name -> NF_TcM Class
342 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
344 Just (AClass clas) -> returnNF_Tc clas
345 other -> notFound "tcLookupClass:" name
347 tcLookupTyCon :: Name -> NF_TcM TyCon
349 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
351 Just (ATyCon tc) -> returnNF_Tc tc
352 other -> notFound "tcLookupTyCon:" name
356 %************************************************************************
358 \subsection{The local environment}
360 %************************************************************************
363 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
365 = tcGetEnv `thenNF_Tc` \ env ->
366 returnNF_Tc (lookup_local env name)
368 tcLookup :: Name -> NF_TcM TcTyThing
370 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
372 Just thing -> returnNF_Tc thing
373 other -> notFound "tcLookup:" name
374 -- Extract the IdInfo from an IfaceSig imported from an interface file
379 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
380 tcExtendKindEnv pairs thing_inside
381 = tcGetEnv `thenNF_Tc` \ env ->
383 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
384 -- No need to extend global tyvars for kind checking
386 tcSetEnv (env {tcLEnv = le'}) thing_inside
388 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
389 tcExtendTyVarEnv tyvars thing_inside
390 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
392 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
393 new_tv_set = mkVarSet tyvars
395 -- It's important to add the in-scope tyvars to the global tyvar set
397 -- f (x::r) = let g y = y::r in ...
398 -- Here, g mustn't be generalised. This is also important during
399 -- class and instance decls, when we mustn't generalise the class tyvars
400 -- when typechecking the methods.
401 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
402 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
404 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
405 -- the signature tyvars contain the original names
406 -- the instance tyvars are what those names should be mapped to
407 -- It's needed when typechecking the method bindings of class and instance decls
408 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
410 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
411 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
412 = tcGetEnv `thenNF_Tc` \ env ->
414 le' = extendNameEnvList (tcLEnv env) stuff
415 stuff = [ (getName sig_tv, ATyVar inst_tv)
416 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
419 tcSetEnv (env {tcLEnv = le'}) thing_inside
424 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
425 tcExtendLocalValEnv names_w_ids thing_inside
426 = tcGetEnv `thenNF_Tc` \ env ->
428 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
429 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
430 le' = extendNameEnvList (tcLEnv env) extra_env
432 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
433 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
437 %************************************************************************
439 \subsection{The global tyvars}
441 %************************************************************************
444 tcExtendGlobalTyVars extra_global_tvs thing_inside
445 = tcGetEnv `thenNF_Tc` \ env ->
446 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
447 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
449 tc_extend_gtvs gtvs extra_global_tvs
450 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
451 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
454 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
455 To improve subsequent calls to the same function it writes the zonked set back into
459 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
461 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
462 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
463 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
465 global_tvs' = (tyVarsOfTypes global_tys')
467 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
468 returnNF_Tc global_tvs'
472 %************************************************************************
474 \subsection{The instance environment}
476 %************************************************************************
479 tcGetInstEnv :: NF_TcM InstEnv
480 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
481 returnNF_Tc (tcInsts env)
483 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
484 tcSetInstEnv ie thing_inside
485 = tcGetEnv `thenNF_Tc` \ env ->
486 tcSetEnv (env {tcInsts = ie}) thing_inside
490 %************************************************************************
494 %************************************************************************
497 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
499 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
500 ptext SLIT("is not in scope"))