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, tcLookupSyntaxId, tcLookupSyntaxName,
22 tcExtendKindEnv, tcLookupLocalIds,
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 TcType ( TcKind, TcType, TcTyVar, TcTyVarSet,
47 import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
48 import IdInfo ( vanillaIdInfo )
49 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
51 import Type ( Type, ThetaType,
52 tyVarsOfTypes, splitDFunTy,
53 getDFunTyKey, tyConAppTyCon
55 import DataCon ( DataCon )
56 import TyCon ( TyCon )
57 import Class ( Class, ClassOpItem )
58 import Name ( Name, OccName, NamedThing(..),
59 nameOccName, getSrcLoc, mkLocalName, isLocalName,
62 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts,
63 extendNameEnvList, emptyNameEnv, plusNameEnv )
64 import OccName ( mkDFunOcc, occNameString )
65 import HscTypes ( DFunId,
66 PackageTypeEnv, TypeEnv,
67 extendTypeEnvList, extendTypeEnvWithIds,
68 typeEnvTyCons, typeEnvClasses, typeEnvIds,
71 import Module ( Module )
72 import InstEnv ( InstEnv, emptyInstEnv )
73 import HscTypes ( lookupType, TyThing(..) )
74 import Util ( zipEqual )
75 import SrcLoc ( SrcLoc )
76 import qualified PrelNames
79 import IOExts ( newIORef )
82 %************************************************************************
86 %************************************************************************
89 type TcId = Id -- Type may be a TcType
94 tcSyntaxMap :: PrelNames.SyntaxMap, -- The syntax map (usually the identity)
96 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
98 tcInsts :: InstEnv, -- All instances (both imported and in this module)
100 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
101 {- NameEnv TyThing-} -- compiling this module:
102 -- types and classes (both imported and local)
104 -- (Ids defined in this module start in the local envt,
105 -- though they move to the global envt during zonking)
107 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
108 -- defined in this module
110 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
111 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
112 -- mentioned in the types of Ids bound in tcLEnv
113 -- Why mutable? see notes with tcGetGlobalTyVars
118 The Global-Env/Local-Env story
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
120 During type checking, we keep in the GlobalEnv
121 * All types and classes
122 * All Ids derived from types and classes (constructors, selectors)
125 At the end of type checking, we zonk the local bindings,
126 and as we do so we add to the GlobalEnv
127 * Locally defined top-level Ids
129 Why? Because they are now Ids not TcIds. This final GlobalEnv is
131 a) fed back (via the knot) to typechecking the
132 unfoldings of interface signatures
134 b) used to augment the GlobalSymbolTable
139 = AGlobal TyThing -- Used only in the return type of a lookup
140 | ATcId TcId -- Ids defined in this module
141 | ATyVar TyVar -- Type variables
142 | AThing TcKind -- Used temporarily, during kind checking
143 -- Here's an example of how the AThing guy is used
144 -- Suppose we are checking (forall a. T a Int):
145 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
146 -- 2. Then we kind-check the (T a Int) part.
147 -- 3. Then we zonk the kind variable.
148 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
150 initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
151 initTcEnv syntax_map hst pte
152 = do { gtv_var <- newIORef emptyVarSet ;
153 return (TcEnv { tcSyntaxMap = syntax_map,
155 tcGEnv = emptyNameEnv,
156 tcInsts = emptyInstEnv,
157 tcLEnv = emptyNameEnv,
161 lookup name | isLocalName name = Nothing
162 | otherwise = lookupType hst pte name
165 tcEnvClasses env = typeEnvClasses (tcGEnv env)
166 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
167 tcEnvIds env = typeEnvIds (tcGEnv env)
168 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
169 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
171 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
173 -- This data type is used to help tie the knot
174 -- when type checking type and class declarations
175 data TyThingDetails = SynTyDetails Type
176 | DataTyDetails ThetaType [DataCon] [Id]
177 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
181 %************************************************************************
183 \subsection{Basic lookups}
185 %************************************************************************
188 lookup_global :: TcEnv -> Name -> Maybe TyThing
189 -- Try the global envt and then the global symbol table
190 lookup_global env name
191 = case lookupNameEnv (tcGEnv env) name of
192 Just thing -> Just thing
193 Nothing -> tcGST env name
195 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
196 -- Try the local envt and then try the global
197 lookup_local env name
198 = case lookupNameEnv (tcLEnv env) name of
199 Just thing -> Just thing
200 Nothing -> case lookup_global env name of
201 Just thing -> Just (AGlobal thing)
206 type RecTcEnv = TcEnv
207 -- This environment is used for getting the 'right' IdInfo
208 -- on imported things and for looking up Ids in unfoldings
209 -- The environment doesn't have any local Ids in it
211 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
212 tcAddImportedIdInfo env id
213 = id `lazySetIdInfo` new_info
214 -- The Id must be returned without a data dependency on maybe_id
216 new_info = case tcLookupRecId_maybe env (idName id) of
217 Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
218 Just imported_id -> idInfo imported_id
219 -- ToDo: could check that types are the same
221 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
222 tcLookupRecId_maybe env name = case lookup_global env name of
223 Just (AnId id) -> Just id
226 tcLookupRecId :: RecTcEnv -> Name -> Id
227 tcLookupRecId env name = case lookup_global env name of
229 Nothing -> pprPanic "tcLookupRecId" (ppr name)
232 %************************************************************************
234 \subsection{Making new Ids}
236 %************************************************************************
241 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
242 newLocalId name ty loc
243 = tcGetUnique `thenNF_Tc` \ uniq ->
244 returnNF_Tc (mkUserLocal name uniq ty loc)
246 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
247 newSpecPragmaId name ty
248 = tcGetUnique `thenNF_Tc` \ uniq ->
249 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
252 Make a name for the dict fun for an instance decl.
253 It's a *local* name for the moment. The CoreTidy pass
257 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
258 newDFunName clas (ty:_) loc
259 = tcGetUnique `thenNF_Tc` \ uniq ->
260 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
262 -- Any string that is somewhat unique will do
263 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
265 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
269 isLocalThing :: NamedThing a => Module -> a -> Bool
270 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
273 %************************************************************************
275 \subsection{The global environment}
277 %************************************************************************
280 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
281 tcExtendGlobalEnv things thing_inside
282 = tcGetEnv `thenNF_Tc` \ env ->
284 ge' = extendTypeEnvList (tcGEnv env) things
286 tcSetEnv (env {tcGEnv = ge'}) thing_inside
289 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
290 tcExtendGlobalTypeEnv extra_env thing_inside
291 = tcGetEnv `thenNF_Tc` \ env ->
293 ge' = tcGEnv env `plusNameEnv` extra_env
295 tcSetEnv (env {tcGEnv = ge'}) thing_inside
297 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
298 tcExtendGlobalValEnv ids thing_inside
299 = tcGetEnv `thenNF_Tc` \ env ->
301 ge' = extendTypeEnvWithIds (tcGEnv env) ids
303 tcSetEnv (env {tcGEnv = ge'}) thing_inside
308 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
309 tcLookupGlobal_maybe name
310 = tcGetEnv `thenNF_Tc` \ env ->
311 returnNF_Tc (lookup_global env name)
314 A variety of global lookups, when we know what we are looking for.
317 tcLookupGlobal :: Name -> NF_TcM TyThing
319 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
321 Just thing -> returnNF_Tc thing
322 other -> notFound "tcLookupGlobal" name
324 tcLookupGlobalId :: Name -> NF_TcM Id
325 tcLookupGlobalId name
326 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
328 Just (AnId id) -> returnNF_Tc id
329 other -> notFound "tcLookupGlobalId" name
331 tcLookupDataCon :: Name -> TcM DataCon
332 tcLookupDataCon con_name
333 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
334 case isDataConWrapId_maybe con_id of
335 Just data_con -> returnTc data_con
336 Nothing -> failWithTc (badCon con_id)
339 tcLookupClass :: Name -> NF_TcM Class
341 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
343 Just (AClass clas) -> returnNF_Tc clas
344 other -> notFound "tcLookupClass" name
346 tcLookupTyCon :: Name -> NF_TcM TyCon
348 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
350 Just (ATyCon tc) -> returnNF_Tc tc
351 other -> notFound "tcLookupTyCon" name
353 tcLookupId :: Name -> NF_TcM Id
355 = tcLookup name `thenNF_Tc` \ thing ->
357 ATcId tc_id -> returnNF_Tc tc_id
358 AGlobal (AnId id) -> returnNF_Tc id
359 other -> pprPanic "tcLookupId" (ppr name)
361 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
363 = tcGetEnv `thenNF_Tc` \ env ->
364 returnNF_Tc (map (lookup (tcLEnv env)) ns)
366 lookup lenv name = case lookupNameEnv lenv name of
367 Just (ATcId id) -> id
368 other -> pprPanic "tcLookupLocalIds" (ppr name)
370 tcLookupSyntaxId :: Name -> NF_TcM Id
371 -- Lookup a name like PrelNum.fromInt, and return the corresponding Id,
372 -- after mapping through the SyntaxMap. This may give us the Id for
373 -- (say) MyPrelude.fromInteger
374 tcLookupSyntaxId name
375 = tcGetEnv `thenNF_Tc` \ env ->
376 returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of
378 other -> pprPanic "tcLookupSyntaxId" (ppr name))
380 tcLookupSyntaxName :: Name -> NF_TcM Name
381 tcLookupSyntaxName name
382 = tcGetEnv `thenNF_Tc` \ env ->
383 returnNF_Tc (tcSyntaxMap env name)
387 %************************************************************************
389 \subsection{The local environment}
391 %************************************************************************
394 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
396 = tcGetEnv `thenNF_Tc` \ env ->
397 returnNF_Tc (lookup_local env name)
399 tcLookup :: Name -> NF_TcM TcTyThing
401 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
403 Just thing -> returnNF_Tc thing
404 other -> notFound "tcLookup" name
405 -- Extract the IdInfo from an IfaceSig imported from an interface file
410 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
411 tcExtendKindEnv pairs thing_inside
412 = tcGetEnv `thenNF_Tc` \ env ->
414 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
415 -- No need to extend global tyvars for kind checking
417 tcSetEnv (env {tcLEnv = le'}) thing_inside
419 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
420 tcExtendTyVarEnv tyvars thing_inside
421 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
423 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
424 new_tv_set = mkVarSet tyvars
426 -- It's important to add the in-scope tyvars to the global tyvar set
428 -- f (x::r) = let g y = y::r in ...
429 -- Here, g mustn't be generalised. This is also important during
430 -- class and instance decls, when we mustn't generalise the class tyvars
431 -- when typechecking the methods.
432 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
433 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
435 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
436 -- the signature tyvars contain the original names
437 -- the instance tyvars are what those names should be mapped to
438 -- It's needed when typechecking the method bindings of class and instance decls
439 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
441 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
442 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
443 = tcGetEnv `thenNF_Tc` \ env ->
445 le' = extendNameEnvList (tcLEnv env) stuff
446 stuff = [ (getName sig_tv, ATyVar inst_tv)
447 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
450 tcSetEnv (env {tcLEnv = le'}) thing_inside
455 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
456 tcExtendLocalValEnv names_w_ids thing_inside
457 = tcGetEnv `thenNF_Tc` \ env ->
459 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
460 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
461 le' = extendNameEnvList (tcLEnv env) extra_env
463 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
464 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
468 %************************************************************************
470 \subsection{The global tyvars}
472 %************************************************************************
475 tcExtendGlobalTyVars extra_global_tvs thing_inside
476 = tcGetEnv `thenNF_Tc` \ env ->
477 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
478 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
480 tc_extend_gtvs gtvs extra_global_tvs
481 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
482 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
485 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
486 To improve subsequent calls to the same function it writes the zonked set back into
490 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
492 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
493 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
494 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
495 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
500 %************************************************************************
502 \subsection{The instance environment}
504 %************************************************************************
507 tcGetInstEnv :: NF_TcM InstEnv
508 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
509 returnNF_Tc (tcInsts env)
511 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
512 tcSetInstEnv ie thing_inside
513 = tcGetEnv `thenNF_Tc` \ env ->
514 tcSetEnv (env {tcInsts = ie}) thing_inside
518 %************************************************************************
520 \subsection{The InstInfo type}
522 %************************************************************************
524 The InstInfo type summarises the information in an instance declaration
526 instance c => k (t tvs) where b
531 iDFunId :: DFunId, -- The dfun id
532 iBinds :: RenamedMonoBinds, -- Bindings, b
533 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
536 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
537 nest 4 (ppr (iBinds info))]
539 simpleInstInfoTy :: InstInfo -> Type
540 simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
541 (_, _, _, [ty]) -> ty
543 simpleInstInfoTyCon :: InstInfo -> TyCon
544 -- Gets the type constructor for a simple instance declaration,
545 -- i.e. one of the form instance (...) => C (T a b c) where ...
546 simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst)
550 %************************************************************************
554 %************************************************************************
557 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
559 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
560 ptext SLIT("is not in scope"))