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, isHomePackageThing, 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 ( idName, isDataConWrapId_maybe )
49 import IdInfo ( vanillaIdInfo )
50 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
52 import DataCon ( DataCon )
53 import TyCon ( TyCon )
54 import Class ( Class, ClassOpItem )
55 import Name ( Name, NamedThing(..),
56 getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom,
59 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
60 extendNameEnvList, emptyNameEnv, plusNameEnv )
61 import OccName ( mkDFunOcc, occNameString )
62 import HscTypes ( DFunId,
63 PackageTypeEnv, TypeEnv,
64 extendTypeEnvList, extendTypeEnvWithIds,
65 typeEnvTyCons, typeEnvClasses, typeEnvIds,
68 import Module ( Module )
69 import InstEnv ( InstEnv, emptyInstEnv )
70 import HscTypes ( lookupType, TyThing(..) )
71 import Util ( zipEqual )
72 import SrcLoc ( SrcLoc )
75 import IOExts ( newIORef )
78 %************************************************************************
82 %************************************************************************
85 type TcId = Id -- Type may be a TcType
90 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
92 tcInsts :: InstEnv, -- All instances (both imported and in this module)
94 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
95 {- NameEnv TyThing-} -- compiling this module:
96 -- types and classes (both imported and local)
98 -- (Ids defined in this module start in the local envt,
99 -- though they move to the global envt during zonking)
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
132 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
134 = do { gtv_var <- newIORef emptyVarSet ;
135 return (TcEnv { tcGST = lookup,
136 tcGEnv = emptyNameEnv,
137 tcInsts = emptyInstEnv,
138 tcLEnv = emptyNameEnv,
142 lookup name | isLocalName name = Nothing
143 | otherwise = lookupType hst pte name
146 tcEnvClasses env = typeEnvClasses (tcGEnv env)
147 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
148 tcEnvIds env = typeEnvIds (tcGEnv env)
149 tcLEnvElts env = nameEnvElts (tcLEnv env)
151 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
153 tcInLocalScope :: TcEnv -> Name -> Bool
154 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
159 = AGlobal TyThing -- Used only in the return type of a lookup
160 | ATcId TcId -- Ids defined in this module
161 | ATyVar TyVar -- Type variables
162 | AThing TcKind -- Used temporarily, during kind checking
163 -- Here's an example of how the AThing guy is used
164 -- Suppose we are checking (forall a. T a Int):
165 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
166 -- 2. Then we kind-check the (T a Int) part.
167 -- 3. Then we zonk the kind variable.
168 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
172 This data type is used to help tie the knot
173 when type checking type and class declarations
176 data TyThingDetails = SynTyDetails Type
177 | DataTyDetails ThetaType [DataCon] [Id]
178 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
179 | ForeignTyDetails -- Nothing yet
182 %************************************************************************
184 \subsection{Basic lookups}
186 %************************************************************************
189 lookup_global :: TcEnv -> Name -> Maybe TyThing
190 -- Try the global envt and then the global symbol table
191 lookup_global env name
192 = case lookupNameEnv (tcGEnv env) name of
193 Just thing -> Just thing
194 Nothing -> tcGST env name
196 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
197 -- Try the local envt and then try the global
198 lookup_local env name
199 = case lookupNameEnv (tcLEnv env) name of
200 Just thing -> Just thing
201 Nothing -> case lookup_global env name of
202 Just thing -> Just (AGlobal thing)
207 type RecTcEnv = TcEnv
208 -- This environment is used for getting the 'right' IdInfo
209 -- on imported things and for looking up Ids in unfoldings
210 -- The environment doesn't have any local Ids in it
212 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
213 tcLookupRecId_maybe env name = case lookup_global env name of
214 Just (AnId id) -> Just id
217 tcLookupRecId :: RecTcEnv -> Name -> Id
218 tcLookupRecId env name = case lookup_global env name of
220 Nothing -> pprPanic "tcLookupRecId" (ppr name)
223 %************************************************************************
225 \subsection{Making new Ids}
227 %************************************************************************
232 newLocalName :: Name -> NF_TcM Name
233 newLocalName name -- Make a clone
234 = tcGetUnique `thenNF_Tc` \ uniq ->
235 returnNF_Tc (mkLocalName uniq (getOccName name) (getSrcLoc name))
238 Make a name for the dict fun for an instance decl.
239 It's a *local* name for the moment. The CoreTidy pass
243 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
244 newDFunName clas (ty:_) loc
245 = tcGetUnique `thenNF_Tc` \ uniq ->
246 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
248 -- Any string that is somewhat unique will do
249 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
251 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
255 isLocalThing :: NamedThing a => Module -> a -> Bool
256 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
258 isHomePackageThing :: NamedThing a => a -> Bool
259 isHomePackageThing thing = isHomePackageName (getName thing)
262 %************************************************************************
264 \subsection{The global environment}
266 %************************************************************************
269 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
270 tcExtendGlobalEnv things thing_inside
271 = tcGetEnv `thenNF_Tc` \ env ->
273 ge' = extendTypeEnvList (tcGEnv env) things
275 tcSetEnv (env {tcGEnv = ge'}) thing_inside
278 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
279 tcExtendGlobalTypeEnv extra_env thing_inside
280 = tcGetEnv `thenNF_Tc` \ env ->
282 ge' = tcGEnv env `plusNameEnv` extra_env
284 tcSetEnv (env {tcGEnv = ge'}) thing_inside
286 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
287 tcExtendGlobalValEnv ids thing_inside
288 = tcGetEnv `thenNF_Tc` \ env ->
290 ge' = extendTypeEnvWithIds (tcGEnv env) ids
292 tcSetEnv (env {tcGEnv = ge'}) thing_inside
297 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
298 tcLookupGlobal_maybe name
299 = tcGetEnv `thenNF_Tc` \ env ->
300 returnNF_Tc (lookup_global env name)
303 A variety of global lookups, when we know what we are looking for.
306 tcLookupGlobal :: Name -> NF_TcM TyThing
308 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
310 Just thing -> returnNF_Tc thing
311 other -> notFound "tcLookupGlobal" name
313 tcLookupGlobalId :: Name -> NF_TcM Id
314 tcLookupGlobalId name
315 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
317 Just (AnId id) -> returnNF_Tc id
318 other -> notFound "tcLookupGlobalId" name
320 tcLookupDataCon :: Name -> TcM DataCon
321 tcLookupDataCon con_name
322 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
323 case isDataConWrapId_maybe con_id of
324 Just data_con -> returnTc data_con
325 Nothing -> failWithTc (badCon con_id)
328 tcLookupClass :: Name -> NF_TcM Class
330 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
332 Just (AClass clas) -> returnNF_Tc clas
333 other -> notFound "tcLookupClass" name
335 tcLookupTyCon :: Name -> NF_TcM TyCon
337 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
339 Just (ATyCon tc) -> returnNF_Tc tc
340 other -> notFound "tcLookupTyCon" name
342 tcLookupId :: Name -> NF_TcM Id
344 = tcLookup name `thenNF_Tc` \ thing ->
346 ATcId tc_id -> returnNF_Tc tc_id
347 AGlobal (AnId id) -> returnNF_Tc id
348 other -> pprPanic "tcLookupId" (ppr name)
350 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
352 = tcGetEnv `thenNF_Tc` \ env ->
353 returnNF_Tc (map (lookup (tcLEnv env)) ns)
355 lookup lenv name = case lookupNameEnv lenv name of
356 Just (ATcId id) -> id
357 other -> pprPanic "tcLookupLocalIds" (ppr name)
361 %************************************************************************
363 \subsection{The local environment}
365 %************************************************************************
368 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
370 = tcGetEnv `thenNF_Tc` \ env ->
371 returnNF_Tc (lookup_local env name)
373 tcLookup :: Name -> NF_TcM TcTyThing
375 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
377 Just thing -> returnNF_Tc thing
378 other -> notFound "tcLookup" name
379 -- Extract the IdInfo from an IfaceSig imported from an interface file
384 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
385 tcExtendKindEnv pairs thing_inside
386 = tcGetEnv `thenNF_Tc` \ env ->
388 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
389 -- No need to extend global tyvars for kind checking
391 tcSetEnv (env {tcLEnv = le'}) thing_inside
393 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
394 tcExtendTyVarEnv tyvars thing_inside
395 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
397 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
398 new_tv_set = mkVarSet tyvars
400 -- It's important to add the in-scope tyvars to the global tyvar set
402 -- f (x::r) = let g y = y::r in ...
403 -- Here, g mustn't be generalised. This is also important during
404 -- class and instance decls, when we mustn't generalise the class tyvars
405 -- when typechecking the methods.
406 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
407 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
409 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
410 -- the signature tyvars contain the original names
411 -- the instance tyvars are what those names should be mapped to
412 -- It's needed when typechecking the method bindings of class and instance decls
413 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
415 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
416 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
417 = tcGetEnv `thenNF_Tc` \ env ->
419 le' = extendNameEnvList (tcLEnv env) stuff
420 stuff = [ (getName sig_tv, ATyVar inst_tv)
421 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
424 tcSetEnv (env {tcLEnv = le'}) thing_inside
429 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
430 tcExtendLocalValEnv names_w_ids thing_inside
431 = tcGetEnv `thenNF_Tc` \ env ->
433 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
434 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
435 le' = extendNameEnvList (tcLEnv env) extra_env
437 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
438 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
442 %************************************************************************
444 \subsection{The global tyvars}
446 %************************************************************************
449 tcExtendGlobalTyVars extra_global_tvs thing_inside
450 = tcGetEnv `thenNF_Tc` \ env ->
451 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
452 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
454 tc_extend_gtvs gtvs extra_global_tvs
455 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
456 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
459 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
460 To improve subsequent calls to the same function it writes the zonked set back into
464 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
466 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
467 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
468 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
469 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
474 %************************************************************************
476 \subsection{The instance environment}
478 %************************************************************************
481 tcGetInstEnv :: NF_TcM InstEnv
482 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
483 returnNF_Tc (tcInsts env)
485 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
486 tcSetInstEnv ie thing_inside
487 = tcGetEnv `thenNF_Tc` \ env ->
488 tcSetEnv (env {tcInsts = ie}) thing_inside
492 %************************************************************************
494 \subsection{The InstInfo type}
496 %************************************************************************
498 The InstInfo type summarises the information in an instance declaration
500 instance c => k (t tvs) where b
502 It is used just for *local* instance decls (not ones from interface files).
503 But local instance decls includes
506 as well as explicit user written ones.
511 iDFunId :: DFunId, -- The dfun id
512 iBinds :: RenamedMonoBinds, -- Bindings, b
513 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
516 | NewTypeDerived { -- Used for deriving instances of newtypes, where the
517 -- witness dictionary is identical to the argument dictionary
518 -- Hence no bindings.
519 iDFunId :: DFunId -- The dfun id
522 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
524 simpleInstInfoTy :: InstInfo -> Type
525 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
526 (_, _, _, [ty]) -> ty
528 simpleInstInfoTyCon :: InstInfo -> TyCon
529 -- Gets the type constructor for a simple instance declaration,
530 -- i.e. one of the form instance (...) => C (T a b c) where ...
531 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
535 %************************************************************************
539 %************************************************************************
542 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
544 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
545 ptext SLIT("is not in scope"))