4 TyThing(..), TyThingDetails(..), TcTyThing(..),
6 -- Getting stuff from the environment
8 tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
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, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe,
33 newLocalId, newSpecPragmaId,
37 isLocalThing, tcSetEnv
40 #include "HsVersions.h"
42 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
44 import TcMType ( zonkTcTyVarsAndFV )
45 import TcType ( Type, ThetaType,
46 tyVarsOfTypes, tcSplitDFunTy,
47 getDFunTyKey, tcTyConAppTyCon
49 import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
50 import IdInfo ( vanillaIdInfo )
51 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
53 import DataCon ( DataCon )
54 import TyCon ( TyCon )
55 import Class ( Class, ClassOpItem )
56 import Name ( Name, OccName, NamedThing(..),
57 nameOccName, getSrcLoc, mkLocalName, isLocalName,
60 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
61 extendNameEnvList, emptyNameEnv, plusNameEnv )
62 import OccName ( mkDFunOcc, occNameString )
63 import HscTypes ( DFunId,
64 PackageTypeEnv, TypeEnv,
65 extendTypeEnvList, extendTypeEnvWithIds,
66 typeEnvTyCons, typeEnvClasses, typeEnvIds,
69 import Module ( Module )
70 import InstEnv ( InstEnv, emptyInstEnv )
71 import HscTypes ( lookupType, TyThing(..) )
72 import Util ( zipEqual )
73 import SrcLoc ( SrcLoc )
76 import IOExts ( newIORef )
79 %************************************************************************
83 %************************************************************************
86 type TcId = Id -- Type may be a TcType
91 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
93 tcInsts :: InstEnv, -- All instances (both imported and in this module)
95 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
96 {- NameEnv TyThing-} -- compiling this module:
97 -- types and classes (both imported and local)
99 -- (Ids defined in this module start in the local envt,
100 -- though they move to the global envt during zonking)
102 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
103 -- defined in this module
105 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
106 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
107 -- mentioned in the types of Ids bound in tcLEnv
108 -- Why mutable? see notes with tcGetGlobalTyVars
113 The Global-Env/Local-Env story
114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
115 During type checking, we keep in the GlobalEnv
116 * All types and classes
117 * All Ids derived from types and classes (constructors, selectors)
120 At the end of type checking, we zonk the local bindings,
121 and as we do so we add to the GlobalEnv
122 * Locally defined top-level Ids
124 Why? Because they are now Ids not TcIds. This final GlobalEnv is
126 a) fed back (via the knot) to typechecking the
127 unfoldings of interface signatures
129 b) used to augment the GlobalSymbolTable
134 = AGlobal TyThing -- Used only in the return type of a lookup
135 | ATcId TcId -- Ids defined in this module
136 | ATyVar TyVar -- Type variables
137 | AThing TcKind -- Used temporarily, during kind checking
138 -- Here's an example of how the AThing guy is used
139 -- Suppose we are checking (forall a. T a Int):
140 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
141 -- 2. Then we kind-check the (T a Int) part.
142 -- 3. Then we zonk the kind variable.
143 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
145 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
147 = do { gtv_var <- newIORef emptyVarSet ;
148 return (TcEnv { tcGST = lookup,
149 tcGEnv = emptyNameEnv,
150 tcInsts = emptyInstEnv,
151 tcLEnv = emptyNameEnv,
155 lookup name | isLocalName name = Nothing
156 | otherwise = lookupType hst pte name
159 tcEnvClasses env = typeEnvClasses (tcGEnv env)
160 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
161 tcEnvIds env = typeEnvIds (tcGEnv env)
162 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
163 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
165 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
167 tcInLocalScope :: TcEnv -> Name -> Bool
168 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
170 -- This data type is used to help tie the knot
171 -- when type checking type and class declarations
172 data TyThingDetails = SynTyDetails Type
173 | DataTyDetails ThetaType [DataCon] [Id]
174 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
175 | ForeignTyDetails -- Nothing yet
179 %************************************************************************
181 \subsection{Basic lookups}
183 %************************************************************************
186 lookup_global :: TcEnv -> Name -> Maybe TyThing
187 -- Try the global envt and then the global symbol table
188 lookup_global env name
189 = case lookupNameEnv (tcGEnv env) name of
190 Just thing -> Just thing
191 Nothing -> tcGST env name
193 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
194 -- Try the local envt and then try the global
195 lookup_local env name
196 = case lookupNameEnv (tcLEnv env) name of
197 Just thing -> Just thing
198 Nothing -> case lookup_global env name of
199 Just thing -> Just (AGlobal thing)
204 type RecTcEnv = TcEnv
205 -- This environment is used for getting the 'right' IdInfo
206 -- on imported things and for looking up Ids in unfoldings
207 -- The environment doesn't have any local Ids in it
209 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
210 tcAddImportedIdInfo env id
211 = id `lazySetIdInfo` new_info
212 -- The Id must be returned without a data dependency on maybe_id
214 new_info = case tcLookupRecId_maybe env (idName id) of
215 Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
216 Just imported_id -> idInfo imported_id
217 -- ToDo: could check that types are the same
219 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
220 tcLookupRecId_maybe env name = case lookup_global env name of
221 Just (AnId id) -> Just id
224 tcLookupRecId :: RecTcEnv -> Name -> Id
225 tcLookupRecId env name = case lookup_global env name of
227 Nothing -> pprPanic "tcLookupRecId" (ppr name)
230 %************************************************************************
232 \subsection{Making new Ids}
234 %************************************************************************
239 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
240 newLocalId name ty loc
241 = tcGetUnique `thenNF_Tc` \ uniq ->
242 returnNF_Tc (mkUserLocal name uniq ty loc)
244 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
245 newSpecPragmaId name ty
246 = tcGetUnique `thenNF_Tc` \ uniq ->
247 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
250 Make a name for the dict fun for an instance decl.
251 It's a *local* name for the moment. The CoreTidy pass
255 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
256 newDFunName clas (ty:_) loc
257 = tcGetUnique `thenNF_Tc` \ uniq ->
258 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
260 -- Any string that is somewhat unique will do
261 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
263 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
267 isLocalThing :: NamedThing a => Module -> a -> Bool
268 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
271 %************************************************************************
273 \subsection{The global environment}
275 %************************************************************************
278 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
279 tcExtendGlobalEnv things thing_inside
280 = tcGetEnv `thenNF_Tc` \ env ->
282 ge' = extendTypeEnvList (tcGEnv env) things
284 tcSetEnv (env {tcGEnv = ge'}) thing_inside
287 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
288 tcExtendGlobalTypeEnv extra_env thing_inside
289 = tcGetEnv `thenNF_Tc` \ env ->
291 ge' = tcGEnv env `plusNameEnv` extra_env
293 tcSetEnv (env {tcGEnv = ge'}) thing_inside
295 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
296 tcExtendGlobalValEnv ids thing_inside
297 = tcGetEnv `thenNF_Tc` \ env ->
299 ge' = extendTypeEnvWithIds (tcGEnv env) ids
301 tcSetEnv (env {tcGEnv = ge'}) thing_inside
306 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
307 tcLookupGlobal_maybe name
308 = tcGetEnv `thenNF_Tc` \ env ->
309 returnNF_Tc (lookup_global env name)
312 A variety of global lookups, when we know what we are looking for.
315 tcLookupGlobal :: Name -> NF_TcM TyThing
317 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
319 Just thing -> returnNF_Tc thing
320 other -> notFound "tcLookupGlobal" name
322 tcLookupGlobalId :: Name -> NF_TcM Id
323 tcLookupGlobalId name
324 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
326 Just (AnId id) -> returnNF_Tc id
327 other -> notFound "tcLookupGlobalId" name
329 tcLookupDataCon :: Name -> TcM DataCon
330 tcLookupDataCon con_name
331 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
332 case isDataConWrapId_maybe con_id of
333 Just data_con -> returnTc data_con
334 Nothing -> failWithTc (badCon con_id)
337 tcLookupClass :: Name -> NF_TcM Class
339 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
341 Just (AClass clas) -> returnNF_Tc clas
342 other -> notFound "tcLookupClass" name
344 tcLookupTyCon :: Name -> NF_TcM TyCon
346 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
348 Just (ATyCon tc) -> returnNF_Tc tc
349 other -> notFound "tcLookupTyCon" name
351 tcLookupId :: Name -> NF_TcM Id
353 = tcLookup name `thenNF_Tc` \ thing ->
355 ATcId tc_id -> returnNF_Tc tc_id
356 AGlobal (AnId id) -> returnNF_Tc id
357 other -> pprPanic "tcLookupId" (ppr name)
359 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
361 = tcGetEnv `thenNF_Tc` \ env ->
362 returnNF_Tc (map (lookup (tcLEnv env)) ns)
364 lookup lenv name = case lookupNameEnv lenv name of
365 Just (ATcId id) -> id
366 other -> pprPanic "tcLookupLocalIds" (ppr name)
370 %************************************************************************
372 \subsection{The local environment}
374 %************************************************************************
377 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
379 = tcGetEnv `thenNF_Tc` \ env ->
380 returnNF_Tc (lookup_local env name)
382 tcLookup :: Name -> NF_TcM TcTyThing
384 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
386 Just thing -> returnNF_Tc thing
387 other -> notFound "tcLookup" name
388 -- Extract the IdInfo from an IfaceSig imported from an interface file
393 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
394 tcExtendKindEnv pairs thing_inside
395 = tcGetEnv `thenNF_Tc` \ env ->
397 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
398 -- No need to extend global tyvars for kind checking
400 tcSetEnv (env {tcLEnv = le'}) thing_inside
402 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
403 tcExtendTyVarEnv tyvars thing_inside
404 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
406 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
407 new_tv_set = mkVarSet tyvars
409 -- It's important to add the in-scope tyvars to the global tyvar set
411 -- f (x::r) = let g y = y::r in ...
412 -- Here, g mustn't be generalised. This is also important during
413 -- class and instance decls, when we mustn't generalise the class tyvars
414 -- when typechecking the methods.
415 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
416 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
418 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
419 -- the signature tyvars contain the original names
420 -- the instance tyvars are what those names should be mapped to
421 -- It's needed when typechecking the method bindings of class and instance decls
422 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
424 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
425 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
426 = tcGetEnv `thenNF_Tc` \ env ->
428 le' = extendNameEnvList (tcLEnv env) stuff
429 stuff = [ (getName sig_tv, ATyVar inst_tv)
430 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
433 tcSetEnv (env {tcLEnv = le'}) thing_inside
438 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
439 tcExtendLocalValEnv names_w_ids thing_inside
440 = tcGetEnv `thenNF_Tc` \ env ->
442 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
443 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
444 le' = extendNameEnvList (tcLEnv env) extra_env
446 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
447 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
451 %************************************************************************
453 \subsection{The global tyvars}
455 %************************************************************************
458 tcExtendGlobalTyVars extra_global_tvs thing_inside
459 = tcGetEnv `thenNF_Tc` \ env ->
460 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
461 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
463 tc_extend_gtvs gtvs extra_global_tvs
464 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
465 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
468 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
469 To improve subsequent calls to the same function it writes the zonked set back into
473 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
475 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
476 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
477 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
478 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
483 %************************************************************************
485 \subsection{The instance environment}
487 %************************************************************************
490 tcGetInstEnv :: NF_TcM InstEnv
491 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
492 returnNF_Tc (tcInsts env)
494 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
495 tcSetInstEnv ie thing_inside
496 = tcGetEnv `thenNF_Tc` \ env ->
497 tcSetEnv (env {tcInsts = ie}) thing_inside
501 %************************************************************************
503 \subsection{The InstInfo type}
505 %************************************************************************
507 The InstInfo type summarises the information in an instance declaration
509 instance c => k (t tvs) where b
514 iDFunId :: DFunId, -- The dfun id
515 iBinds :: RenamedMonoBinds, -- Bindings, b
516 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
519 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
520 nest 4 (ppr (iBinds info))]
522 simpleInstInfoTy :: InstInfo -> Type
523 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
524 (_, _, _, [ty]) -> ty
526 simpleInstInfoTyCon :: InstInfo -> TyCon
527 -- Gets the type constructor for a simple instance declaration,
528 -- i.e. one of the form instance (...) => C (T a b c) where ...
529 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
533 %************************************************************************
537 %************************************************************************
540 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
542 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
543 ptext SLIT("is not in scope"))