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, mkUserLocal, isDataConWrapId_maybe )
48 import IdInfo ( constantIdInfo )
49 import MkId ( mkSpecPragmaId )
50 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
53 tyVarsOfTypes, splitDFunTy,
54 getDFunTyKey, tyConAppTyCon
56 import DataCon ( DataCon )
57 import TyCon ( TyCon )
58 import Class ( Class, ClassOpItem, ClassContext )
59 import Name ( Name, OccName, NamedThing(..),
60 nameOccName, getSrcLoc, mkLocalName, isLocalName,
61 nameIsLocalOrFrom, nameModule_maybe
63 import Name ( NameEnv, lookupNameEnv, nameEnvElts,
64 extendNameEnvList, emptyNameEnv, plusNameEnv )
65 import OccName ( mkDFunOcc, occNameString )
66 import HscTypes ( DFunId,
67 PackageTypeEnv, TypeEnv,
68 extendTypeEnvList, extendTypeEnvWithIds,
69 typeEnvTyCons, typeEnvClasses, typeEnvIds,
72 import Module ( Module )
73 import InstEnv ( InstEnv, emptyInstEnv )
74 import HscTypes ( lookupType, TyThing(..) )
75 import Util ( zipEqual )
76 import SrcLoc ( SrcLoc )
77 import qualified PrelNames
80 import IOExts ( newIORef )
83 %************************************************************************
87 %************************************************************************
90 type TcId = Id -- Type may be a TcType
95 tcSyntaxMap :: PrelNames.SyntaxMap, -- The syntax map (usually the identity)
97 tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
99 tcInsts :: InstEnv, -- All instances (both imported and in this module)
101 tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
102 {- NameEnv TyThing-} -- compiling this module:
103 -- types and classes (both imported and local)
105 -- (Ids defined in this module start in the local envt,
106 -- though they move to the global envt during zonking)
108 tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
109 -- defined in this module
111 tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
112 -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
113 -- mentioned in the types of Ids bound in tcLEnv
114 -- Why mutable? see notes with tcGetGlobalTyVars
119 The Global-Env/Local-Env story
120 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
121 During type checking, we keep in the GlobalEnv
122 * All types and classes
123 * All Ids derived from types and classes (constructors, selectors)
126 At the end of type checking, we zonk the local bindings,
127 and as we do so we add to the GlobalEnv
128 * Locally defined top-level Ids
130 Why? Because they are now Ids not TcIds. This final GlobalEnv is
132 a) fed back (via the knot) to typechecking the
133 unfoldings of interface signatures
135 b) used to augment the GlobalSymbolTable
140 = AGlobal TyThing -- Used only in the return type of a lookup
141 | ATcId TcId -- Ids defined in this module
142 | ATyVar TyVar -- Type variables
143 | AThing TcKind -- Used temporarily, during kind checking
144 -- Here's an example of how the AThing guy is used
145 -- Suppose we are checking (forall a. T a Int):
146 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
147 -- 2. Then we kind-check the (T a Int) part.
148 -- 3. Then we zonk the kind variable.
149 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
151 initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
152 initTcEnv syntax_map hst pte
153 = do { gtv_var <- newIORef emptyVarSet ;
154 return (TcEnv { tcSyntaxMap = syntax_map,
156 tcGEnv = emptyNameEnv,
157 tcInsts = emptyInstEnv,
158 tcLEnv = emptyNameEnv,
162 lookup name | isLocalName name = Nothing
163 | otherwise = lookupType hst pte name
166 tcEnvClasses env = typeEnvClasses (tcGEnv env)
167 tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
168 tcEnvIds env = typeEnvIds (tcGEnv env)
169 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
170 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
172 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
174 -- This data type is used to help tie the knot
175 -- when type checking type and class declarations
176 data TyThingDetails = SynTyDetails Type
177 | DataTyDetails ClassContext [DataCon] [Id]
178 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
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 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
213 tcAddImportedIdInfo env id
214 = id `lazySetIdInfo` new_info
215 -- The Id must be returned without a data dependency on maybe_id
217 new_info = case tcLookupRecId_maybe env (idName id) of
218 Nothing -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo
219 Just imported_id -> idInfo imported_id
220 -- ToDo: could check that types are the same
222 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
223 tcLookupRecId_maybe env name = case lookup_global env name of
224 Just (AnId id) -> Just id
227 tcLookupRecId :: RecTcEnv -> Name -> Id
228 tcLookupRecId env name = case lookup_global env name of
230 Nothing -> pprPanic "tcLookupRecId" (ppr name)
233 %************************************************************************
235 \subsection{Making new Ids}
237 %************************************************************************
242 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
243 newLocalId name ty loc
244 = tcGetUnique `thenNF_Tc` \ uniq ->
245 returnNF_Tc (mkUserLocal name uniq ty loc)
247 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
248 newSpecPragmaId name ty
249 = tcGetUnique `thenNF_Tc` \ uniq ->
250 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
253 Make a name for the dict fun for an instance decl.
254 It's a *local* name for the moment. The CoreTidy pass
258 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
259 newDFunName clas (ty:_) loc
260 = tcGetUnique `thenNF_Tc` \ uniq ->
261 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
263 -- Any string that is somewhat unique will do
264 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
266 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
270 isLocalThing :: NamedThing a => Module -> a -> Bool
271 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
274 %************************************************************************
276 \subsection{The global environment}
278 %************************************************************************
281 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
282 tcExtendGlobalEnv things thing_inside
283 = tcGetEnv `thenNF_Tc` \ env ->
285 ge' = extendTypeEnvList (tcGEnv env) things
287 tcSetEnv (env {tcGEnv = ge'}) thing_inside
290 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
291 tcExtendGlobalTypeEnv extra_env thing_inside
292 = tcGetEnv `thenNF_Tc` \ env ->
294 ge' = tcGEnv env `plusNameEnv` extra_env
296 tcSetEnv (env {tcGEnv = ge'}) thing_inside
298 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
299 tcExtendGlobalValEnv ids thing_inside
300 = tcGetEnv `thenNF_Tc` \ env ->
302 ge' = extendTypeEnvWithIds (tcGEnv env) ids
304 tcSetEnv (env {tcGEnv = ge'}) thing_inside
309 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
310 tcLookupGlobal_maybe name
311 = tcGetEnv `thenNF_Tc` \ env ->
312 returnNF_Tc (lookup_global env name)
315 A variety of global lookups, when we know what we are looking for.
318 tcLookupGlobal :: Name -> NF_TcM TyThing
320 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
322 Just thing -> returnNF_Tc thing
323 other -> notFound "tcLookupGlobal" name
325 tcLookupGlobalId :: Name -> NF_TcM Id
326 tcLookupGlobalId name
327 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
329 Just (AnId id) -> returnNF_Tc id
330 other -> notFound "tcLookupGlobalId" name
332 tcLookupDataCon :: Name -> TcM DataCon
333 tcLookupDataCon con_name
334 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
335 case isDataConWrapId_maybe con_id of
336 Just data_con -> returnTc data_con
337 Nothing -> failWithTc (badCon con_id)
340 tcLookupClass :: Name -> NF_TcM Class
342 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
344 Just (AClass clas) -> returnNF_Tc clas
345 other -> notFound "tcLookupClass" name
347 tcLookupTyCon :: Name -> NF_TcM TyCon
349 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
351 Just (ATyCon tc) -> returnNF_Tc tc
352 other -> notFound "tcLookupTyCon" name
354 tcLookupId :: Name -> NF_TcM Id
356 = tcLookup name `thenNF_Tc` \ thing ->
358 ATcId tc_id -> returnNF_Tc tc_id
359 AGlobal (AnId id) -> returnNF_Tc id
360 other -> pprPanic "tcLookupId" (ppr name)
362 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
364 = tcGetEnv `thenNF_Tc` \ env ->
365 returnNF_Tc (map (lookup (tcLEnv env)) ns)
367 lookup lenv name = case lookupNameEnv lenv name of
368 Just (ATcId id) -> id
369 other -> pprPanic "tcLookupLocalIds" (ppr name)
371 tcLookupSyntaxId :: Name -> NF_TcM Id
372 -- Lookup a name like PrelNum.fromInt, and return the corresponding Id,
373 -- after mapping through the SyntaxMap. This may give us the Id for
374 -- (say) MyPrelude.fromInteger
375 tcLookupSyntaxId name
376 = tcGetEnv `thenNF_Tc` \ env ->
377 returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of
379 other -> pprPanic "tcLookupSyntaxId" (ppr name))
381 tcLookupSyntaxName :: Name -> NF_TcM Name
382 tcLookupSyntaxName name
383 = tcGetEnv `thenNF_Tc` \ env ->
384 returnNF_Tc (tcSyntaxMap env name)
388 %************************************************************************
390 \subsection{The local environment}
392 %************************************************************************
395 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
397 = tcGetEnv `thenNF_Tc` \ env ->
398 returnNF_Tc (lookup_local env name)
400 tcLookup :: Name -> NF_TcM TcTyThing
402 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
404 Just thing -> returnNF_Tc thing
405 other -> notFound "tcLookup" name
406 -- Extract the IdInfo from an IfaceSig imported from an interface file
411 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
412 tcExtendKindEnv pairs thing_inside
413 = tcGetEnv `thenNF_Tc` \ env ->
415 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
416 -- No need to extend global tyvars for kind checking
418 tcSetEnv (env {tcLEnv = le'}) thing_inside
420 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
421 tcExtendTyVarEnv tyvars thing_inside
422 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
424 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
425 new_tv_set = mkVarSet tyvars
427 -- It's important to add the in-scope tyvars to the global tyvar set
429 -- f (x::r) = let g y = y::r in ...
430 -- Here, g mustn't be generalised. This is also important during
431 -- class and instance decls, when we mustn't generalise the class tyvars
432 -- when typechecking the methods.
433 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
434 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
436 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
437 -- the signature tyvars contain the original names
438 -- the instance tyvars are what those names should be mapped to
439 -- It's needed when typechecking the method bindings of class and instance decls
440 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
442 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
443 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
444 = tcGetEnv `thenNF_Tc` \ env ->
446 le' = extendNameEnvList (tcLEnv env) stuff
447 stuff = [ (getName sig_tv, ATyVar inst_tv)
448 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
451 tcSetEnv (env {tcLEnv = le'}) thing_inside
456 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
457 tcExtendLocalValEnv names_w_ids thing_inside
458 = tcGetEnv `thenNF_Tc` \ env ->
460 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
461 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
462 le' = extendNameEnvList (tcLEnv env) extra_env
464 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
465 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
469 %************************************************************************
471 \subsection{The global tyvars}
473 %************************************************************************
476 tcExtendGlobalTyVars extra_global_tvs thing_inside
477 = tcGetEnv `thenNF_Tc` \ env ->
478 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
479 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
481 tc_extend_gtvs gtvs extra_global_tvs
482 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
483 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
486 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
487 To improve subsequent calls to the same function it writes the zonked set back into
491 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
493 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
494 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
495 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
496 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
501 %************************************************************************
503 \subsection{The instance environment}
505 %************************************************************************
508 tcGetInstEnv :: NF_TcM InstEnv
509 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
510 returnNF_Tc (tcInsts env)
512 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
513 tcSetInstEnv ie thing_inside
514 = tcGetEnv `thenNF_Tc` \ env ->
515 tcSetEnv (env {tcInsts = ie}) thing_inside
519 %************************************************************************
521 \subsection{The InstInfo type}
523 %************************************************************************
525 The InstInfo type summarises the information in an instance declaration
527 instance c => k (t tvs) where b
532 iDFunId :: DFunId, -- The dfun id
533 iBinds :: RenamedMonoBinds, -- Bindings, b
534 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
537 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
538 nest 4 (ppr (iBinds info))]
540 simpleInstInfoTy :: InstInfo -> Type
541 simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
542 (_, _, _, [ty]) -> ty
544 simpleInstInfoTyCon :: InstInfo -> TyCon
545 -- Gets the type constructor for a simple instance declaration,
546 -- i.e. one of the form instance (...) => C (T a b c) where ...
547 simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst)
551 %************************************************************************
555 %************************************************************************
558 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
560 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
561 ptext SLIT("is not in scope"))