4 TyThing(..), TyThingDetails(..), TcTyThing(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts,
11 -- Instance environment, and InstInfo type
12 tcGetInstEnv, tcSetInstEnv,
13 InstInfo(..), pprInstInfo,
14 simpleInstInfoTy, simpleInstInfoTyCon,
17 tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
18 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19 tcLookupGlobal_maybe, tcLookupGlobal,
22 tcExtendKindEnv, tcInLocalScope,
23 tcExtendTyVarEnv, tcExtendTyVarEnv2,
24 tcExtendLocalValEnv, tcExtendLocalValEnv2,
25 tcLookup, tcLookupLocalIds, tcLookup_maybe, tcLookupId,
27 -- Global type variables
30 -- Random useful things
31 RecTcEnv, tcLookupRecId, tcLookupRecId_maybe,
34 newLocalName, newDFunName,
37 isLocalThing, tcSetEnv
40 #include "HsVersions.h"
42 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
44 import TcMType ( zonkTcTyVarsAndFV )
45 import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
46 tyVarsOfTypes, tcSplitDFunTy,
47 getDFunTyKey, tcTyConAppTyCon
49 import Id ( idName, isDataConWrapId_maybe )
50 import Var ( TyVar, Id, idType )
52 import DataCon ( DataCon )
53 import TyCon ( TyCon, DataConDetails )
54 import Class ( Class, ClassOpItem )
55 import Name ( Name, NamedThing(..),
56 getSrcLoc, mkInternalName, isInternalName, nameIsLocalOrFrom
58 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
59 extendNameEnvList, emptyNameEnv, plusNameEnv )
60 import OccName ( mkDFunOcc, occNameString )
61 import HscTypes ( DFunId,
62 PackageTypeEnv, TypeEnv,
63 extendTypeEnvList, extendTypeEnvWithIds,
64 typeEnvTyCons, typeEnvClasses, typeEnvIds,
67 import Module ( Module )
68 import InstEnv ( InstEnv, emptyInstEnv )
69 import HscTypes ( lookupType, TyThing(..) )
70 import SrcLoc ( SrcLoc )
73 import DATA_IOREF ( newIORef )
76 %************************************************************************
80 %************************************************************************
83 type TcId = Id -- Type may be a TcType
88 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
90 tcInsts :: InstEnv, -- All instances (both imported and in this module)
92 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
93 {- NameEnv TyThing-} -- compiling this module:
94 -- types and classes (both imported and local)
96 -- (Ids defined in this module start in the local envt,
97 -- though they move to the global envt during zonking)
99 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
100 -- defined in this module
102 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
103 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
104 -- mentioned in the types of Ids bound in tcLEnv
105 -- Why mutable? see notes with tcGetGlobalTyVars
110 The Global-Env/Local-Env story
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
112 During type checking, we keep in the GlobalEnv
113 * All types and classes
114 * All Ids derived from types and classes (constructors, selectors)
117 At the end of type checking, we zonk the local bindings,
118 and as we do so we add to the GlobalEnv
119 * Locally defined top-level Ids
121 Why? Because they are now Ids not TcIds. This final GlobalEnv is
123 a) fed back (via the knot) to typechecking the
124 unfoldings of interface signatures
126 b) used to augment the GlobalSymbolTable
130 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
132 = do { gtv_var <- newIORef emptyVarSet ;
133 return (TcEnv { tcGST = lookup,
134 tcGEnv = emptyNameEnv,
135 tcInsts = emptyInstEnv,
136 tcLEnv = emptyNameEnv,
140 lookup name | isInternalName name = Nothing
141 | otherwise = lookupType hst pte name
144 tcEnvClasses env = typeEnvClasses (tcGEnv env)
145 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
146 tcEnvIds env = typeEnvIds (tcGEnv env)
147 tcLEnvElts env = nameEnvElts (tcLEnv env)
149 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
151 tcInLocalScope :: TcEnv -> Name -> Bool
152 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
157 = AGlobal TyThing -- Used only in the return type of a lookup
158 | ATcId TcId -- Ids defined in this module
159 | ATyVar TyVar -- Type variables
160 | AThing TcKind -- Used temporarily, during kind checking
161 -- Here's an example of how the AThing guy is used
162 -- Suppose we are checking (forall a. T a Int):
163 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
164 -- 2. Then we kind-check the (T a Int) part.
165 -- 3. Then we zonk the kind variable.
166 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
170 This data type is used to help tie the knot
171 when type checking type and class declarations
174 data TyThingDetails = SynTyDetails Type
175 | DataTyDetails ThetaType (DataConDetails DataCon) [Id]
176 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
177 | ForeignTyDetails -- Nothing yet
180 %************************************************************************
182 \subsection{Basic lookups}
184 %************************************************************************
187 lookup_global :: TcEnv -> Name -> Maybe TyThing
188 -- Try the global envt and then the global symbol table
189 lookup_global env name
190 = case lookupNameEnv (tcGEnv env) name of
191 Just thing -> Just thing
192 Nothing -> tcGST env name
194 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
195 -- Try the local envt and then try the global
196 lookup_local env name
197 = case lookupNameEnv (tcLEnv env) name of
198 Just thing -> Just thing
199 Nothing -> case lookup_global env name of
200 Just thing -> Just (AGlobal thing)
205 type RecTcEnv = TcEnv
206 -- This environment is used for getting the 'right' IdInfo
207 -- on imported things and for looking up Ids in unfoldings
208 -- The environment doesn't have any local Ids in it
210 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
211 tcLookupRecId_maybe env name = case lookup_global env name of
212 Just (AnId id) -> Just id
215 tcLookupRecId :: RecTcEnv -> Name -> Id
216 tcLookupRecId env name = case lookup_global env name of
218 Nothing -> pprPanic "tcLookupRecId" (ppr name)
221 %************************************************************************
223 \subsection{Making new Ids}
225 %************************************************************************
230 newLocalName :: Name -> NF_TcM Name
231 newLocalName name -- Make a clone
232 = tcGetUnique `thenNF_Tc` \ uniq ->
233 returnNF_Tc (mkInternalName uniq (getOccName name) (getSrcLoc name))
236 Make a name for the dict fun for an instance decl.
237 It's a *local* name for the moment. The CoreTidy pass
241 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
242 newDFunName clas (ty:_) loc
243 = tcGetUnique `thenNF_Tc` \ uniq ->
244 returnNF_Tc (mkInternalName uniq (mkDFunOcc dfun_string) loc)
246 -- Any string that is somewhat unique will do
247 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
249 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
253 isLocalThing :: NamedThing a => Module -> a -> Bool
254 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
257 %************************************************************************
259 \subsection{The global environment}
261 %************************************************************************
264 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
265 tcExtendGlobalEnv things thing_inside
266 = tcGetEnv `thenNF_Tc` \ env ->
268 ge' = extendTypeEnvList (tcGEnv env) things
270 tcSetEnv (env {tcGEnv = ge'}) thing_inside
273 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
274 tcExtendGlobalTypeEnv extra_env thing_inside
275 = tcGetEnv `thenNF_Tc` \ env ->
277 ge' = tcGEnv env `plusNameEnv` extra_env
279 tcSetEnv (env {tcGEnv = ge'}) thing_inside
281 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
282 tcExtendGlobalValEnv ids thing_inside
283 = tcGetEnv `thenNF_Tc` \ env ->
285 ge' = extendTypeEnvWithIds (tcGEnv env) ids
287 tcSetEnv (env {tcGEnv = ge'}) thing_inside
292 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
293 tcLookupGlobal_maybe name
294 = tcGetEnv `thenNF_Tc` \ env ->
295 returnNF_Tc (lookup_global env name)
298 A variety of global lookups, when we know what we are looking for.
301 tcLookupGlobal :: Name -> NF_TcM TyThing
303 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
305 Just thing -> returnNF_Tc thing
306 other -> notFound "tcLookupGlobal" name
308 tcLookupGlobalId :: Name -> NF_TcM Id
309 tcLookupGlobalId name
310 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
312 Just (AnId id) -> returnNF_Tc id
313 other -> notFound "tcLookupGlobalId" name
315 tcLookupDataCon :: Name -> TcM DataCon
316 tcLookupDataCon con_name
317 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
318 case isDataConWrapId_maybe con_id of
319 Just data_con -> returnTc data_con
320 Nothing -> failWithTc (badCon con_id)
323 tcLookupClass :: Name -> NF_TcM Class
325 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
327 Just (AClass clas) -> returnNF_Tc clas
328 other -> notFound "tcLookupClass" name
330 tcLookupTyCon :: Name -> NF_TcM TyCon
332 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
334 Just (ATyCon tc) -> returnNF_Tc tc
335 other -> notFound "tcLookupTyCon" name
337 tcLookupId :: Name -> NF_TcM Id
339 = tcLookup name `thenNF_Tc` \ thing ->
341 ATcId tc_id -> returnNF_Tc tc_id
342 AGlobal (AnId id) -> returnNF_Tc id
343 other -> pprPanic "tcLookupId" (ppr name)
345 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
347 = tcGetEnv `thenNF_Tc` \ env ->
348 returnNF_Tc (map (lookup (tcLEnv env)) ns)
350 lookup lenv name = case lookupNameEnv lenv name of
351 Just (ATcId id) -> id
352 other -> pprPanic "tcLookupLocalIds" (ppr 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 tvs thing_inside
390 = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
392 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
393 tcExtendTyVarEnv2 tv_pairs thing_inside
394 = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
395 [tv | (_,tv) <- tv_pairs]
398 tc_extend_tv_env binds tyvars thing_inside
399 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
401 le' = extendNameEnvList le binds
402 new_tv_set = mkVarSet tyvars
404 -- It's important to add the in-scope tyvars to the global tyvar set
406 -- f (x::r) = let g y = y::r in ...
407 -- Here, g mustn't be generalised. This is also important during
408 -- class and instance decls, when we mustn't generalise the class tyvars
409 -- when typechecking the methods.
410 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
411 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
416 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
417 tcExtendLocalValEnv ids thing_inside
418 = tcGetEnv `thenNF_Tc` \ env ->
420 extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
421 extra_env = [(idName id, ATcId id) | id <- ids]
422 le' = extendNameEnvList (tcLEnv env) extra_env
424 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
425 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
427 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
428 tcExtendLocalValEnv2 names_w_ids thing_inside
429 = tcGetEnv `thenNF_Tc` \ env ->
431 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
432 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
433 le' = extendNameEnvList (tcLEnv env) extra_env
435 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
436 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
440 %************************************************************************
442 \subsection{The global tyvars}
444 %************************************************************************
447 tc_extend_gtvs gtvs extra_global_tvs
448 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
449 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
452 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
453 To improve subsequent calls to the same function it writes the zonked set back into
457 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
459 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
460 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
461 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
462 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
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 %************************************************************************
487 \subsection{The InstInfo type}
489 %************************************************************************
491 The InstInfo type summarises the information in an instance declaration
493 instance c => k (t tvs) where b
495 It is used just for *local* instance decls (not ones from interface files).
496 But local instance decls includes
499 as well as explicit user written ones.
504 iDFunId :: DFunId, -- The dfun id
505 iBinds :: RenamedMonoBinds, -- Bindings, b
506 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
509 | NewTypeDerived { -- Used for deriving instances of newtypes, where the
510 -- witness dictionary is identical to the argument dictionary
511 -- Hence no bindings.
512 iDFunId :: DFunId -- The dfun id
515 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
517 simpleInstInfoTy :: InstInfo -> Type
518 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
519 (_, _, _, [ty]) -> ty
521 simpleInstInfoTyCon :: InstInfo -> TyCon
522 -- Gets the type constructor for a simple instance declaration,
523 -- i.e. one of the form instance (...) => C (T a b c) where ...
524 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
528 %************************************************************************
532 %************************************************************************
535 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
537 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
538 ptext SLIT("is not in scope"))