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, tcLookupLocalIds, tcInLocalScope,
23 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
24 tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId,
26 -- Global type variables
27 tcGetGlobalTyVars, tcExtendGlobalTyVars,
29 -- Random useful things
30 RecTcEnv, tcLookupRecId, tcLookupRecId_maybe,
33 newLocalName, newDFunName,
36 isLocalThing, tcSetEnv
39 #include "HsVersions.h"
41 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
43 import TcMType ( zonkTcTyVarsAndFV )
44 import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
45 tyVarsOfTypes, tcSplitDFunTy,
46 getDFunTyKey, tcTyConAppTyCon
48 import Id ( isDataConWrapId_maybe )
49 import Var ( TyVar, Id, idType )
51 import DataCon ( DataCon )
52 import TyCon ( TyCon )
53 import Class ( Class, ClassOpItem )
54 import Name ( Name, NamedThing(..),
55 getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom
57 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
58 extendNameEnvList, emptyNameEnv, plusNameEnv )
59 import OccName ( mkDFunOcc, occNameString )
60 import HscTypes ( DFunId,
61 PackageTypeEnv, TypeEnv,
62 extendTypeEnvList, extendTypeEnvWithIds,
63 typeEnvTyCons, typeEnvClasses, typeEnvIds,
66 import Module ( Module )
67 import InstEnv ( InstEnv, emptyInstEnv )
68 import HscTypes ( lookupType, TyThing(..) )
69 import Util ( zipEqual )
70 import SrcLoc ( SrcLoc )
73 import IOExts ( 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 | isLocalName 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 [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 (mkLocalName 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 (mkLocalName 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 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` \ gbl_tvs ->
463 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
464 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
469 %************************************************************************
471 \subsection{The instance environment}
473 %************************************************************************
476 tcGetInstEnv :: NF_TcM InstEnv
477 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
478 returnNF_Tc (tcInsts env)
480 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
481 tcSetInstEnv ie thing_inside
482 = tcGetEnv `thenNF_Tc` \ env ->
483 tcSetEnv (env {tcInsts = ie}) thing_inside
487 %************************************************************************
489 \subsection{The InstInfo type}
491 %************************************************************************
493 The InstInfo type summarises the information in an instance declaration
495 instance c => k (t tvs) where b
497 It is used just for *local* instance decls (not ones from interface files).
498 But local instance decls includes
501 as well as explicit user written ones.
506 iDFunId :: DFunId, -- The dfun id
507 iBinds :: RenamedMonoBinds, -- Bindings, b
508 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
511 | NewTypeDerived { -- Used for deriving instances of newtypes, where the
512 -- witness dictionary is identical to the argument dictionary
513 -- Hence no bindings.
514 iDFunId :: DFunId -- The dfun id
517 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
519 simpleInstInfoTy :: InstInfo -> Type
520 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
521 (_, _, _, [ty]) -> ty
523 simpleInstInfoTyCon :: InstInfo -> TyCon
524 -- Gets the type constructor for a simple instance declaration,
525 -- i.e. one of the form instance (...) => C (T a b c) where ...
526 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
530 %************************************************************************
534 %************************************************************************
537 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
539 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
540 ptext SLIT("is not in scope"))