4 TyThing(..), TyThingDetails(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
10 -- Instance environment
11 tcGetInstEnv, tcSetInstEnv,
14 tcExtendGlobalEnv, tcExtendGlobalValEnv,
15 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
20 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
23 -- Global type variables
24 tcGetGlobalTyVars, tcExtendGlobalTyVars,
26 -- Random useful things
27 tcAddImportedIdInfo, tcInstId,
30 newLocalId, newSpecPragmaId,
31 newDefaultMethodName, newDFunName
34 #include "HsVersions.h"
37 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
38 tcInstTyVars, zonkTcTyVars,
40 import Id ( mkUserLocal, isDataConWrapId_maybe )
41 import IdInfo ( vanillaIdInfo )
42 import MkId ( mkSpecPragmaId )
43 import Var ( TyVar, Id, setVarName,
44 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
47 import VarEnv ( TyVarSubstEnv )
48 import Type ( Kind, Type, superKind,
49 tyVarsOfType, tyVarsOfTypes,
50 splitForAllTys, splitRhoTy, splitFunTys,
51 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
53 import DataCon ( DataCon )
54 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
55 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
56 import Subst ( substTy )
57 import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
58 nameOccName, nameModule, getSrcLoc, mkGlobalName,
60 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
61 extendNameEnv, extendNameEnvList
63 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
64 import Module ( Module )
65 import Unify ( unifyTyListsX, matchTys )
66 import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
68 import Unique ( pprUnique10, Unique, Uniquable(..) )
70 import Unique ( Uniquable(..) )
71 import Util ( zipEqual, zipWith3Equal, mapAccumL )
72 import SrcLoc ( SrcLoc )
73 import FastString ( FastString )
76 import IOExts ( newIORef )
79 %************************************************************************
83 %************************************************************************
86 type TcId = Id -- Type may be a TcType
91 tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
93 tcInsts :: InstEnv, -- All instances (both imported and in this module)
95 tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while
96 -- compiling this module:
97 -- types and classes (both imported and local)
99 -- (Ids defined in this module are in the local envt)
101 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
102 -- defined in this module
104 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
105 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
106 -- mentioned in the types of Ids bound in tcLEnv
107 -- Why mutable? see notes with tcGetGlobalTyVars
112 The Global-Env/Local-Env story
113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
114 During type checking, we keep in the GlobalEnv
115 * All types and classes
116 * All Ids derived from types and classes (constructors, selectors)
119 At the end of type checking, we zonk the local bindings,
120 and as we do so we add to the GlobalEnv
121 * Locally defined top-level Ids
123 Why? Because they are now Ids not TcIds. This final GlobalEnv is
125 a) fed back (via the knot) to typechecking the
126 unfoldings of interface signatures
128 b) used to augment the GlobalSymbolTable
133 = AGlobal TyThing -- Used only in the return type of a lookup
134 | ATcId TcId -- Ids defined in this module
135 | ATyVar TyVar -- Type variables
136 | AThing TcKind -- Used temporarily, during kind checking
137 -- Here's an example of how the AThing guy is used
138 -- Suppose we are checking (forall a. T a Int):
139 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
140 -- 2. Then we kind-check the (T a Int) part.
141 -- 3. Then we zonk the kind variable.
142 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
144 initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv
145 initTcEnv gst inst_env
146 = do { gtv_var <- newIORef emptyVarSet ;
147 return (TcEnv { tcGST = gst,
148 tcGEnv = emptyNameEnv,
150 tcLEnv = emptyNameEnv,
154 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
155 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
156 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
157 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
158 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
160 -- This data type is used to help tie the knot
161 -- when type checking type and class declarations
162 data TyThingDetails = SynTyDetails Type
163 | DataTyDetails ClassContext [DataCon] [Class]
164 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
168 %************************************************************************
170 \subsection{Basic lookups}
172 %************************************************************************
175 lookup_global :: TcEnv -> Name -> Maybe TyThing
176 -- Try the global envt and then the global symbol table
177 lookup_global env name
178 = case lookupNameEnv (tcGEnv env) name of
179 Just thing -> Just thing
180 Nothing -> lookupTypeEnv (tcGST env) name
182 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
183 -- Try the local envt and then try the global
184 lookup_local env name
185 = case lookupNameEnv (tcLEnv env) name of
186 Just thing -> Just thing
187 Nothing -> case lookup_global env name of
188 Just thing -> Just (AGlobal thing)
191 explicitLookupId :: TcEnv -> Name -> Maybe Id
192 explicitLookupId env name = case lookup_global env name of
193 Just (AnId id) -> Just id
198 %************************************************************************
200 \subsection{Random useful functions}
202 %************************************************************************
206 -- A useful function that takes an occurrence of a global thing
207 -- and instantiates its type with fresh type variables
209 -> NF_TcM ([TcTyVar], -- It's instantiated type
214 (tyvars, rho) = splitForAllTys (idType id)
216 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
218 rho' = substTy tenv rho
219 (theta', tau') = splitRhoTy rho'
221 returnNF_Tc (tyvars', theta', tau')
223 tcAddImportedIdInfo :: TcEnv -> Id -> Id
224 tcAddImportedIdInfo unf_env id
225 | isLocallyDefined id -- Don't look up locally defined Ids, because they
226 -- have explicit local definitions, so we get a black hole!
229 = id `lazySetIdInfo` new_info
230 -- The Id must be returned without a data dependency on maybe_id
232 new_info = case explicitLookupId unf_env (getName id) of
233 Nothing -> vanillaIdInfo
234 Just imported_id -> idInfo imported_id
235 -- ToDo: could check that types are the same
239 %************************************************************************
241 \subsection{Making new Ids}
243 %************************************************************************
248 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
249 newLocalId name ty loc
250 = tcGetUnique `thenNF_Tc` \ uniq ->
251 returnNF_Tc (mkUserLocal name uniq ty loc)
253 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
254 newSpecPragmaId name ty
255 = tcGetUnique `thenNF_Tc` \ uniq ->
256 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
259 Make a name for the dict fun for an instance decl
262 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
263 newDFunName mod clas (ty:_) loc
264 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
265 tcGetUnique `thenNF_Tc` \ uniq ->
266 returnNF_Tc (mkGlobalName uniq mod
267 (mkDFunOcc dfun_string inst_uniq)
270 -- Any string that is somewhat unique will do
271 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
273 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
274 newDefaultMethodName op_name loc
275 = tcGetUnique `thenNF_Tc` \ uniq ->
276 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
277 (mkDefaultMethodOcc (getOccName op_name))
282 %************************************************************************
284 \subsection{The global environment}
286 %************************************************************************
289 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
290 tcExtendGlobalEnv bindings thing_inside
291 = tcGetEnv `thenNF_Tc` \ env ->
293 ge' = extendNameEnvList (tcGEnv env) bindings
295 tcSetEnv (env {tcGEnv = ge'}) thing_inside
297 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
298 tcExtendGlobalValEnv ids thing_inside
299 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
304 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
305 tcLookupGlobal_maybe name
306 = tcGetEnv `thenNF_Tc` \ env ->
307 returnNF_Tc (lookup_global env name)
310 A variety of global lookups, when we know what we are looking for.
313 tcLookupGlobal :: Name -> NF_TcM TyThing
315 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
317 Just thing -> returnNF_Tc thing
318 other -> notFound "tcLookupGlobal:" name
320 tcLookupGlobalId :: Name -> NF_TcM Id
321 tcLookupGlobalId name
322 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
324 Just (AnId clas) -> returnNF_Tc clas
325 other -> notFound "tcLookupGlobalId:" name
327 tcLookupDataCon :: Name -> TcM DataCon
328 tcLookupDataCon con_name
329 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
330 case isDataConWrapId_maybe con_id of
331 Just data_con -> returnTc data_con
332 Nothing -> failWithTc (badCon con_id)
335 tcLookupClass :: Name -> NF_TcM Class
337 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
339 Just (AClass clas) -> returnNF_Tc clas
340 other -> notFound "tcLookupClass:" name
342 tcLookupTyCon :: Name -> NF_TcM TyCon
344 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
346 Just (ATyCon tc) -> returnNF_Tc tc
347 other -> notFound "tcLookupTyCon:" name
351 %************************************************************************
353 \subsection{The local environment}
355 %************************************************************************
358 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
360 = tcGetEnv `thenNF_Tc` \ env ->
361 returnNF_Tc (lookup_local env name)
363 tcLookup :: Name -> NF_TcM TcTyThing
365 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
367 Just thing -> returnNF_Tc thing
368 other -> notFound "tcLookup:" name
369 -- Extract the IdInfo from an IfaceSig imported from an interface file
374 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
375 tcExtendKindEnv pairs thing_inside
376 = tcGetEnv `thenNF_Tc` \ env ->
378 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
379 -- No need to extend global tyvars for kind checking
381 tcSetEnv (env {tcLEnv = le'}) thing_inside
383 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
384 tcExtendTyVarEnv tyvars thing_inside
385 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
387 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
388 new_tv_set = mkVarSet tyvars
390 -- It's important to add the in-scope tyvars to the global tyvar set
392 -- f (x::r) = let g y = y::r in ...
393 -- Here, g mustn't be generalised. This is also important during
394 -- class and instance decls, when we mustn't generalise the class tyvars
395 -- when typechecking the methods.
396 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
397 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
399 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
400 -- the signature tyvars contain the original names
401 -- the instance tyvars are what those names should be mapped to
402 -- It's needed when typechecking the method bindings of class and instance decls
403 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
405 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
406 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
407 = tcGetEnv `thenNF_Tc` \ env ->
409 le' = extendNameEnvList (tcLEnv env) stuff
410 stuff = [ (getName sig_tv, ATyVar inst_tv)
411 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
414 tcSetEnv (env {tcLEnv = le'}) thing_inside
419 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
420 tcExtendLocalValEnv names_w_ids thing_inside
421 = tcGetEnv `thenNF_Tc` \ env ->
423 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
424 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
425 le' = extendNameEnvList (tcLEnv env) extra_env
427 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
428 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
432 %************************************************************************
434 \subsection{The global tyvars}
436 %************************************************************************
439 tcExtendGlobalTyVars extra_global_tvs thing_inside
440 = tcGetEnv `thenNF_Tc` \ env ->
441 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
442 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
444 tc_extend_gtvs gtvs extra_global_tvs
445 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
446 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
449 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
450 To improve subsequent calls to the same function it writes the zonked set back into
454 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
456 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
457 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
458 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
460 global_tvs' = (tyVarsOfTypes global_tys')
462 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
463 returnNF_Tc global_tvs'
467 %************************************************************************
469 \subsection{The instance environment}
471 %************************************************************************
474 tcGetInstEnv :: NF_TcM InstEnv
475 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
476 returnNF_Tc (tcInsts env)
478 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
479 tcSetInstEnv ie thing_inside
480 = tcGetEnv `thenNF_Tc` \ env ->
481 tcSetEnv (env {tcInsts = ie}) thing_inside
485 %************************************************************************
489 %************************************************************************
492 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
494 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
495 ptext SLIT("is not in scope"))