4 TyThing(..), TyThingDetails(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
10 -- Instance environment
11 tcGetInstEnv, tcSetInstEnv,
14 tcExtendGlobalEnv, tcExtendGlobalValEnv,
15 tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
22 -- Global type variables
23 tcGetGlobalTyVars, tcExtendGlobalTyVars,
25 -- Random useful things
26 tcAddImportedIdInfo, tcInstId,
29 newLocalId, newSpecPragmaId,
30 newDefaultMethodName, newDFunName
33 #include "HsVersions.h"
36 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
37 tcInstTyVars, zonkTcTyVars,
39 import Id ( mkUserLocal, isDataConWrapId_maybe )
40 import IdInfo ( vanillaIdInfo )
41 import MkId ( mkSpecPragmaId )
42 import Var ( TyVar, Id, setVarName,
43 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
46 import VarEnv ( TyVarSubstEnv )
47 import Type ( Kind, Type, superKind,
48 tyVarsOfType, tyVarsOfTypes,
49 splitForAllTys, splitRhoTy, splitFunTys,
50 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
52 import DataCon ( DataCon )
53 import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
54 import Class ( Class, ClassOpItem, ClassContext, classTyCon )
55 import Subst ( substTy )
56 import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
57 nameOccName, nameModule, getSrcLoc, mkGlobalName,
58 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
59 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
60 extendNameEnv, extendNameEnvList
62 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
63 import Module ( Module )
64 import Unify ( unifyTyListsX, matchTys )
65 import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv )
66 import Unique ( pprUnique10, Unique, Uniquable(..) )
68 import Unique ( Uniquable(..) )
69 import Util ( zipEqual, zipWith3Equal, mapAccumL )
70 import SrcLoc ( SrcLoc )
71 import FastString ( FastString )
76 %************************************************************************
80 %************************************************************************
83 type TcId = Id -- Type may be a TcType
88 tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
90 tcInsts :: InstEnv, -- All instances (both imported and in this module)
92 tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while
93 -- compiling this module:
94 -- types and classes (both imported and local)
96 -- (Ids defined in this module are in the local envt)
98 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
99 -- defined in this module
101 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
102 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
103 -- mentioned in the types of Ids bound in tcLEnv
104 -- Why mutable? see notes with tcGetGlobalTyVars
109 The Global-Env/Local-Env story
110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
111 During type checking, we keep in the GlobalEnv
112 * All types and classes
113 * All Ids derived from types and classes (constructors, selectors)
116 At the end of type checking, we zonk the local bindings,
117 and as we do so we add to the GlobalEnv
118 * Locally defined top-level Ids
120 Why? Because they are now Ids not TcIds. This final GlobalEnv is
122 a) fed back (via the knot) to typechecking the
123 unfoldings of interface signatures
125 b) used to augment the GlobalSymbolTable
130 = AGlobal TyThing -- Used only in the return type of a lookup
131 | ATcId TcId -- Ids defined in this module
132 | ATyVar TyVar -- Type variables
133 | AThing TcKind -- Used temporarily, during kind checking
134 -- Here's an example of how the AThing guy is used
135 -- Suppose we are checking (forall a. T a Int):
136 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
137 -- 2. Then we kind-check the (T a Int) part.
138 -- 3. Then we zonk the kind variable.
139 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
141 initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv
142 initTcEnv gst inst_env
143 = do { gtv_var <- newIORef emptyVarSet
144 return (TcEnv { tcGST = gst,
145 tcGEnv = emptyNameEnv,
147 tcLEnv = emptyNameEnv,
151 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
152 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
153 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
154 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
155 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
157 -- This data type is used to help tie the knot
158 -- when type checking type and class declarations
159 data TyThingDetails = SynTyDetails Type
160 | DataTyDetails ClassContext [DataCon] [Class]
161 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
165 %************************************************************************
167 \subsection{Basic lookups}
169 %************************************************************************
172 lookup_global :: TcEnv -> Name -> Maybe TyThing
173 -- Try the global envt and then the global symbol table
174 lookup_global env name
175 = case lookupNameEnv (tcGEnv env) name of
176 Just thing -> Just thing
177 Nothing -> lookupTypeEnv (tcGST env) name
179 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
180 -- Try the local envt and then try the global
181 lookup_local env name
182 = case lookupNameEnv (tcLEnv env) name of
183 Just thing -> Just thing
184 Nothing -> case lookup_global env name of
185 Just thing -> AGlobal thing
188 explicitLookupId :: TcEnv -> Name -> Maybe Id
189 explicitLookupId env name = case lookup_global env name of
190 Just (AnId id) -> Just id
195 %************************************************************************
197 \subsection{Random useful functions}
199 %************************************************************************
203 -- A useful function that takes an occurrence of a global thing
204 -- and instantiates its type with fresh type variables
206 -> NF_TcM ([TcTyVar], -- It's instantiated type
211 (tyvars, rho) = splitForAllTys (idType id)
213 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
215 rho' = substTy tenv rho
216 (theta', tau') = splitRhoTy rho'
218 returnNF_Tc (tyvars', theta', tau')
220 tcAddImportedIdInfo :: TcEnv -> Id -> Id
221 tcAddImportedIdInfo unf_env id
222 | isLocallyDefined id -- Don't look up locally defined Ids, because they
223 -- have explicit local definitions, so we get a black hole!
226 = id `lazySetIdInfo` new_info
227 -- The Id must be returned without a data dependency on maybe_id
229 new_info = case explicitLookupId unf_env (getName id) of
230 Nothing -> vanillaIdInfo
231 Just imported_id -> idInfo imported_id
232 -- ToDo: could check that types are the same
236 %************************************************************************
238 \subsection{Making new Ids}
240 %************************************************************************
245 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
246 newLocalId name ty loc
247 = tcGetUnique `thenNF_Tc` \ uniq ->
248 returnNF_Tc (mkUserLocal name uniq ty loc)
250 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
251 newSpecPragmaId name ty
252 = tcGetUnique `thenNF_Tc` \ uniq ->
253 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
256 Make a name for the dict fun for an instance decl
259 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
260 newDFunName mod clas (ty:_) loc
261 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
262 tcGetUnique `thenNF_Tc` \ uniq ->
263 returnNF_Tc (mkGlobalName uniq mod
264 (mkDFunOcc dfun_string inst_uniq)
265 (LocalDef loc Exported))
267 -- Any string that is somewhat unique will do
268 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
270 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
271 newDefaultMethodName op_name loc
272 = tcGetUnique `thenNF_Tc` \ uniq ->
273 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
274 (mkDefaultMethodOcc (getOccName op_name))
275 (LocalDef loc Exported))
279 %************************************************************************
281 \subsection{The global environment}
283 %************************************************************************
286 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
287 tcExtendGlobalEnv bindings thing_inside
288 = tcGetEnv `thenNF_Tc` \ env ->
290 ge' = extendNameEnvList (tcGEnv env) bindings
292 tcSetEnv (env {tcGEnv = ge'}) thing_inside
294 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
295 tcExtendGlobalValEnv ids thing_inside
296 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
301 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
302 tcLookupGlobal_maybe name
303 = tcGetEnv `thenNF_Tc` \ env ->
304 returnNF_Tc (lookup_global env name)
307 A variety of global lookups, when we know what we are looking for.
310 tcLookupGlobal :: Name -> NF_TcM TyThing
311 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
313 Just thing -> returnNF_Tc thing
314 other -> notFound "tcLookupGlobal:" name
316 tcLookupGlobalId :: Name -> NF_TcM Id
317 tcLookupGlobalId name
318 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
320 Just (AnId clas) -> returnNF_Tc id
321 other -> notFound "tcLookupGlobalId:" name
323 tcLookupDataCon :: Name -> TcM DataCon
324 tcLookupDataCon con_name
325 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
326 case isDataConWrapId_maybe con_id of
327 Just data_con -> returnTc data_con
328 Nothing -> failWithTc (badCon con_id)
331 tcLookupClass :: Name -> NF_TcM Class
333 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
335 Just (AClass clas) -> returnNF_Tc clas
336 other -> notFound "tcLookupClass:" name
338 tcLookupTyCon :: Name -> NF_TcM TyCon
340 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
342 Just (ATyCon tc) -> returnNF_Tc tc
343 other -> notFound "tcLookupTyCon:" name
347 %************************************************************************
349 \subsection{The local environment}
351 %************************************************************************
354 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
356 = tcGetEnv `thenNF_Tc` \ env ->
357 returnNF_Tc (lookup_local env name)
359 tcLookup :: Name -> NF_TcM TcTyThing
361 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
363 Just thing -> returnNF_Tc thing
364 other -> notFound "tcLookup:" name
365 -- Extract the IdInfo from an IfaceSig imported from an interface file
370 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
371 tcExtendKindEnv pairs thing_inside
372 = tcGetEnv `thenNF_Tc` \ env ->
374 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
375 -- No need to extend global tyvars for kind checking
377 tcSetEnv (env {tcLEnv = le'}) thing_inside
379 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
380 tcExtendTyVarEnv tyvars thing_inside
381 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
383 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
384 new_tv_set = mkVarSet tyvars
386 -- It's important to add the in-scope tyvars to the global tyvar set
388 -- f (x::r) = let g y = y::r in ...
389 -- Here, g mustn't be generalised. This is also important during
390 -- class and instance decls, when we mustn't generalise the class tyvars
391 -- when typechecking the methods.
392 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
393 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
395 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
396 -- the signature tyvars contain the original names
397 -- the instance tyvars are what those names should be mapped to
398 -- It's needed when typechecking the method bindings of class and instance decls
399 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
401 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
402 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
403 = tcGetEnv `thenNF_Tc` \ env ->
405 le' = extendNameEnvList (tcLEnv env) stuff
406 stuff = [ (getName sig_tv, ATyVar inst_tv)
407 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
410 tcSetEnv (env {tcLEnv = le'}) thing_inside
415 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
416 tcExtendLocalValEnv names_w_ids thing_inside
417 = tcGetEnv `thenNF_Tc` \ env ->
419 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
420 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
421 le' = extendNameEnvList (tcLEnv env) extra_env
423 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
424 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
428 %************************************************************************
430 \subsection{The global tyvars}
432 %************************************************************************
435 tcExtendGlobalTyVars extra_global_tvs thing_inside
436 = tcGetEnv `thenNF_Tc` \ env ->
437 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
438 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
440 tc_extend_gtvs gtvs extra_global_tvs
441 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
442 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
445 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
446 To improve subsequent calls to the same function it writes the zonked set back into
450 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
452 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
453 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
454 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
456 global_tvs' = (tyVarsOfTypes global_tys')
458 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
459 returnNF_Tc global_tvs'
463 %************************************************************************
465 \subsection{The instance environment}
467 %************************************************************************
470 tcGetInstEnv :: NF_TcM InstEnv
471 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
472 returnNF_Tc (tcInsts env)
474 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
475 tcSetInstEnv ie thing_inside
476 = tcGetEnv `thenNF_Tc` \ env ->
477 tcSetEnv (env {tcInsts = ie}) thing_inside
481 %************************************************************************
485 %************************************************************************
488 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
490 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
491 ptext SLIT("is not in scope"))