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 )
74 import qualified PrelNames
77 import IOExts ( newIORef )
80 %************************************************************************
84 %************************************************************************
87 type TcId = Id -- Type may be a TcType
92 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
94 tcInsts :: InstEnv, -- All instances (both imported and in this module)
96 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
97 {- NameEnv TyThing-} -- compiling this module:
98 -- types and classes (both imported and local)
100 -- (Ids defined in this module start in the local envt,
101 -- though they move to the global envt during zonking)
103 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
104 -- defined in this module
106 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
107 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
108 -- mentioned in the types of Ids bound in tcLEnv
109 -- Why mutable? see notes with tcGetGlobalTyVars
114 The Global-Env/Local-Env story
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 During type checking, we keep in the GlobalEnv
117 * All types and classes
118 * All Ids derived from types and classes (constructors, selectors)
121 At the end of type checking, we zonk the local bindings,
122 and as we do so we add to the GlobalEnv
123 * Locally defined top-level Ids
125 Why? Because they are now Ids not TcIds. This final GlobalEnv is
127 a) fed back (via the knot) to typechecking the
128 unfoldings of interface signatures
130 b) used to augment the GlobalSymbolTable
135 = AGlobal TyThing -- Used only in the return type of a lookup
136 | ATcId TcId -- Ids defined in this module
137 | ATyVar TyVar -- Type variables
138 | AThing TcKind -- Used temporarily, during kind checking
139 -- Here's an example of how the AThing guy is used
140 -- Suppose we are checking (forall a. T a Int):
141 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
142 -- 2. Then we kind-check the (T a Int) part.
143 -- 3. Then we zonk the kind variable.
144 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
146 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
148 = do { gtv_var <- newIORef emptyVarSet ;
149 return (TcEnv { tcGST = lookup,
150 tcGEnv = emptyNameEnv,
151 tcInsts = emptyInstEnv,
152 tcLEnv = emptyNameEnv,
156 lookup name | isLocalName name = Nothing
157 | otherwise = lookupType hst pte name
160 tcEnvClasses env = typeEnvClasses (tcGEnv env)
161 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
162 tcEnvIds env = typeEnvIds (tcGEnv env)
163 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
164 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
166 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
168 tcInLocalScope :: TcEnv -> Name -> Bool
169 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
171 -- This data type is used to help tie the knot
172 -- when type checking type and class declarations
173 data TyThingDetails = SynTyDetails Type
174 | DataTyDetails ThetaType [DataCon] [Id]
175 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
176 | 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 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
211 tcAddImportedIdInfo env id
212 = id `lazySetIdInfo` new_info
213 -- The Id must be returned without a data dependency on maybe_id
215 new_info = case tcLookupRecId_maybe env (idName id) of
216 Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
217 Just imported_id -> idInfo imported_id
218 -- ToDo: could check that types are the same
220 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
221 tcLookupRecId_maybe env name = case lookup_global env name of
222 Just (AnId id) -> Just id
225 tcLookupRecId :: RecTcEnv -> Name -> Id
226 tcLookupRecId env name = case lookup_global env name of
228 Nothing -> pprPanic "tcLookupRecId" (ppr name)
231 %************************************************************************
233 \subsection{Making new Ids}
235 %************************************************************************
240 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
241 newLocalId name ty loc
242 = tcGetUnique `thenNF_Tc` \ uniq ->
243 returnNF_Tc (mkUserLocal name uniq ty loc)
245 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
246 newSpecPragmaId name ty
247 = tcGetUnique `thenNF_Tc` \ uniq ->
248 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
251 Make a name for the dict fun for an instance decl.
252 It's a *local* name for the moment. The CoreTidy pass
256 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
257 newDFunName clas (ty:_) loc
258 = tcGetUnique `thenNF_Tc` \ uniq ->
259 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
261 -- Any string that is somewhat unique will do
262 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
264 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
268 isLocalThing :: NamedThing a => Module -> a -> Bool
269 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
272 %************************************************************************
274 \subsection{The global environment}
276 %************************************************************************
279 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
280 tcExtendGlobalEnv things thing_inside
281 = tcGetEnv `thenNF_Tc` \ env ->
283 ge' = extendTypeEnvList (tcGEnv env) things
285 tcSetEnv (env {tcGEnv = ge'}) thing_inside
288 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
289 tcExtendGlobalTypeEnv extra_env thing_inside
290 = tcGetEnv `thenNF_Tc` \ env ->
292 ge' = tcGEnv env `plusNameEnv` extra_env
294 tcSetEnv (env {tcGEnv = ge'}) thing_inside
296 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
297 tcExtendGlobalValEnv ids thing_inside
298 = tcGetEnv `thenNF_Tc` \ env ->
300 ge' = extendTypeEnvWithIds (tcGEnv env) ids
302 tcSetEnv (env {tcGEnv = ge'}) thing_inside
307 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
308 tcLookupGlobal_maybe name
309 = tcGetEnv `thenNF_Tc` \ env ->
310 returnNF_Tc (lookup_global env name)
313 A variety of global lookups, when we know what we are looking for.
316 tcLookupGlobal :: Name -> NF_TcM TyThing
318 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
320 Just thing -> returnNF_Tc thing
321 other -> notFound "tcLookupGlobal" name
323 tcLookupGlobalId :: Name -> NF_TcM Id
324 tcLookupGlobalId name
325 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
327 Just (AnId id) -> returnNF_Tc id
328 other -> notFound "tcLookupGlobalId" name
330 tcLookupDataCon :: Name -> TcM DataCon
331 tcLookupDataCon con_name
332 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
333 case isDataConWrapId_maybe con_id of
334 Just data_con -> returnTc data_con
335 Nothing -> failWithTc (badCon con_id)
338 tcLookupClass :: Name -> NF_TcM Class
340 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
342 Just (AClass clas) -> returnNF_Tc clas
343 other -> notFound "tcLookupClass" name
345 tcLookupTyCon :: Name -> NF_TcM TyCon
347 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
349 Just (ATyCon tc) -> returnNF_Tc tc
350 other -> notFound "tcLookupTyCon" name
352 tcLookupId :: Name -> NF_TcM Id
354 = tcLookup name `thenNF_Tc` \ thing ->
356 ATcId tc_id -> returnNF_Tc tc_id
357 AGlobal (AnId id) -> returnNF_Tc id
358 other -> pprPanic "tcLookupId" (ppr name)
360 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
362 = tcGetEnv `thenNF_Tc` \ env ->
363 returnNF_Tc (map (lookup (tcLEnv env)) ns)
365 lookup lenv name = case lookupNameEnv lenv name of
366 Just (ATcId id) -> id
367 other -> pprPanic "tcLookupLocalIds" (ppr name)
371 %************************************************************************
373 \subsection{The local environment}
375 %************************************************************************
378 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
380 = tcGetEnv `thenNF_Tc` \ env ->
381 returnNF_Tc (lookup_local env name)
383 tcLookup :: Name -> NF_TcM TcTyThing
385 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
387 Just thing -> returnNF_Tc thing
388 other -> notFound "tcLookup" name
389 -- Extract the IdInfo from an IfaceSig imported from an interface file
394 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
395 tcExtendKindEnv pairs thing_inside
396 = tcGetEnv `thenNF_Tc` \ env ->
398 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
399 -- No need to extend global tyvars for kind checking
401 tcSetEnv (env {tcLEnv = le'}) thing_inside
403 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
404 tcExtendTyVarEnv tyvars thing_inside
405 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
407 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
408 new_tv_set = mkVarSet tyvars
410 -- It's important to add the in-scope tyvars to the global tyvar set
412 -- f (x::r) = let g y = y::r in ...
413 -- Here, g mustn't be generalised. This is also important during
414 -- class and instance decls, when we mustn't generalise the class tyvars
415 -- when typechecking the methods.
416 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
417 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
419 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
420 -- the signature tyvars contain the original names
421 -- the instance tyvars are what those names should be mapped to
422 -- It's needed when typechecking the method bindings of class and instance decls
423 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
425 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
426 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
427 = tcGetEnv `thenNF_Tc` \ env ->
429 le' = extendNameEnvList (tcLEnv env) stuff
430 stuff = [ (getName sig_tv, ATyVar inst_tv)
431 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
434 tcSetEnv (env {tcLEnv = le'}) thing_inside
439 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
440 tcExtendLocalValEnv names_w_ids thing_inside
441 = tcGetEnv `thenNF_Tc` \ env ->
443 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
444 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
445 le' = extendNameEnvList (tcLEnv env) extra_env
447 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
448 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
452 %************************************************************************
454 \subsection{The global tyvars}
456 %************************************************************************
459 tcExtendGlobalTyVars extra_global_tvs thing_inside
460 = tcGetEnv `thenNF_Tc` \ env ->
461 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
462 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
464 tc_extend_gtvs gtvs extra_global_tvs
465 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
466 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
469 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
470 To improve subsequent calls to the same function it writes the zonked set back into
474 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
476 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
477 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
478 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
479 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
484 %************************************************************************
486 \subsection{The instance environment}
488 %************************************************************************
491 tcGetInstEnv :: NF_TcM InstEnv
492 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
493 returnNF_Tc (tcInsts env)
495 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
496 tcSetInstEnv ie thing_inside
497 = tcGetEnv `thenNF_Tc` \ env ->
498 tcSetEnv (env {tcInsts = ie}) thing_inside
502 %************************************************************************
504 \subsection{The InstInfo type}
506 %************************************************************************
508 The InstInfo type summarises the information in an instance declaration
510 instance c => k (t tvs) where b
515 iDFunId :: DFunId, -- The dfun id
516 iBinds :: RenamedMonoBinds, -- Bindings, b
517 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
520 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
521 nest 4 (ppr (iBinds info))]
523 simpleInstInfoTy :: InstInfo -> Type
524 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
525 (_, _, _, [ty]) -> ty
527 simpleInstInfoTyCon :: InstInfo -> TyCon
528 -- Gets the type constructor for a simple instance declaration,
529 -- i.e. one of the form instance (...) => C (T a b c) where ...
530 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
534 %************************************************************************
538 %************************************************************************
541 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
543 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
544 ptext SLIT("is not in scope"))