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,
18 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19 tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
22 tcExtendKindEnv, tcLookupLocalIds,
23 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
24 tcExtendLocalValEnv, tcLookup, tcLookup_maybe,
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,
61 isLocalName, nameModule_maybe
63 import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
64 import OccName ( mkDFunOcc, occNameString )
65 import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
66 import Module ( Module )
67 import InstEnv ( InstEnv, emptyInstEnv )
68 import HscTypes ( lookupType, TyThing(..) )
69 import Util ( zipEqual )
70 import SrcLoc ( SrcLoc )
71 import qualified PrelNames
74 import IOExts ( newIORef )
77 %************************************************************************
81 %************************************************************************
84 type TcId = Id -- Type may be a TcType
89 tcSyntaxMap :: PrelNames.SyntaxMap, -- The syntax map (usually the identity)
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 are in the local envt)
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
133 = AGlobal TyThing -- Used only in the return type of a lookup
134 | ATcId TcId -- Ids defined in this module
135 | ATyVar TyVar -- Type variables
136 | AThing TcKind -- Used temporarily, during kind checking
137 -- Here's an example of how the AThing guy is used
138 -- Suppose we are checking (forall a. T a Int):
139 -- 1. We first bind (a -> AThink kv), where kv is a kind variable.
140 -- 2. Then we kind-check the (T a Int) part.
141 -- 3. Then we zonk the kind variable.
142 -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
144 initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
145 initTcEnv syntax_map hst pte
146 = do { gtv_var <- newIORef emptyVarSet ;
147 return (TcEnv { tcSyntaxMap = syntax_map,
149 tcGEnv = emptyNameEnv,
150 tcInsts = emptyInstEnv,
151 tcLEnv = emptyNameEnv,
155 lookup name | isLocalName name = Nothing
156 | otherwise = lookupType hst pte name
159 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
160 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
161 tcEnvIds env = [id | AnId id <- nameEnvElts (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 -- This data type is used to help tie the knot
168 -- when type checking type and class declarations
169 data TyThingDetails = SynTyDetails Type
170 | DataTyDetails ClassContext [DataCon] [Id]
171 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
175 %************************************************************************
177 \subsection{Basic lookups}
179 %************************************************************************
182 lookup_global :: TcEnv -> Name -> Maybe TyThing
183 -- Try the global envt and then the global symbol table
184 lookup_global env name
185 = case lookupNameEnv (tcGEnv env) name of
186 Just thing -> Just thing
187 Nothing -> tcGST env name
189 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
190 -- Try the local envt and then try the global
191 lookup_local env name
192 = case lookupNameEnv (tcLEnv env) name of
193 Just thing -> Just thing
194 Nothing -> case lookup_global env name of
195 Just thing -> Just (AGlobal thing)
200 type RecTcEnv = TcEnv
201 -- This environment is used for getting the 'right' IdInfo
202 -- on imported things and for looking up Ids in unfoldings
203 -- The environment doesn't have any local Ids in it
205 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
206 tcAddImportedIdInfo env id
207 = id `lazySetIdInfo` new_info
208 -- The Id must be returned without a data dependency on maybe_id
210 new_info = case tcLookupRecId_maybe env (idName id) of
211 Nothing -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo
212 Just imported_id -> idInfo imported_id
213 -- ToDo: could check that types are the same
215 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
216 tcLookupRecId_maybe env name = case lookup_global env name of
217 Just (AnId id) -> Just id
220 tcLookupRecId :: RecTcEnv -> Name -> Id
221 tcLookupRecId env name = case lookup_global env name of
223 Nothing -> pprPanic "tcLookupRecId" (ppr name)
226 %************************************************************************
228 \subsection{Making new Ids}
230 %************************************************************************
235 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
236 newLocalId name ty loc
237 = tcGetUnique `thenNF_Tc` \ uniq ->
238 returnNF_Tc (mkUserLocal name uniq ty loc)
240 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
241 newSpecPragmaId name ty
242 = tcGetUnique `thenNF_Tc` \ uniq ->
243 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
246 Make a name for the dict fun for an instance decl.
247 It's a *local* name for the moment. The CoreTidy pass
251 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
252 newDFunName clas (ty:_) loc
253 = tcGetUnique `thenNF_Tc` \ uniq ->
254 returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
256 -- Any string that is somewhat unique will do
257 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
259 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
263 isLocalThing :: NamedThing a => Module -> a -> Bool
264 -- True if the thing has a Local name,
265 -- or a Global name from the specified module
266 isLocalThing mod thing = case nameModule_maybe (getName thing) of
267 Nothing -> True -- A local name
268 Just m -> m == mod -- A global 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' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
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' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- 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 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
344 = tcGetEnv `thenNF_Tc` \ env ->
345 returnNF_Tc (map (lookup (tcLEnv env)) ns)
347 lookup lenv name = case lookupNameEnv lenv name of
348 Just (ATcId id) -> id
349 other -> pprPanic "tcLookupLocalIds" (ppr name)
351 tcLookupSyntaxId :: Name -> NF_TcM Id
352 -- Lookup a name like PrelNum.fromInt, and return the corresponding Id,
353 -- after mapping through the SyntaxMap. This may give us the Id for
354 -- (say) MyPrelude.fromInt
355 tcLookupSyntaxId name
356 = tcGetEnv `thenNF_Tc` \ env ->
357 returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of
359 other -> pprPanic "tcLookupSyntaxId" (ppr name))
361 tcLookupSyntaxName :: Name -> NF_TcM Name
362 tcLookupSyntaxName name
363 = tcGetEnv `thenNF_Tc` \ env ->
364 returnNF_Tc (tcSyntaxMap env name)
368 %************************************************************************
370 \subsection{The local environment}
372 %************************************************************************
375 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
377 = tcGetEnv `thenNF_Tc` \ env ->
378 returnNF_Tc (lookup_local env name)
380 tcLookup :: Name -> NF_TcM TcTyThing
382 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
384 Just thing -> returnNF_Tc thing
385 other -> notFound "tcLookup" name
386 -- Extract the IdInfo from an IfaceSig imported from an interface file
391 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
392 tcExtendKindEnv pairs thing_inside
393 = tcGetEnv `thenNF_Tc` \ env ->
395 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
396 -- No need to extend global tyvars for kind checking
398 tcSetEnv (env {tcLEnv = le'}) thing_inside
400 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
401 tcExtendTyVarEnv tyvars thing_inside
402 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
404 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
405 new_tv_set = mkVarSet tyvars
407 -- It's important to add the in-scope tyvars to the global tyvar set
409 -- f (x::r) = let g y = y::r in ...
410 -- Here, g mustn't be generalised. This is also important during
411 -- class and instance decls, when we mustn't generalise the class tyvars
412 -- when typechecking the methods.
413 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
414 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
416 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
417 -- the signature tyvars contain the original names
418 -- the instance tyvars are what those names should be mapped to
419 -- It's needed when typechecking the method bindings of class and instance decls
420 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
422 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
423 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
424 = tcGetEnv `thenNF_Tc` \ env ->
426 le' = extendNameEnvList (tcLEnv env) stuff
427 stuff = [ (getName sig_tv, ATyVar inst_tv)
428 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
431 tcSetEnv (env {tcLEnv = le'}) thing_inside
436 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
437 tcExtendLocalValEnv names_w_ids thing_inside
438 = tcGetEnv `thenNF_Tc` \ env ->
440 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
441 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
442 le' = extendNameEnvList (tcLEnv env) extra_env
444 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
445 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
449 %************************************************************************
451 \subsection{The global tyvars}
453 %************************************************************************
456 tcExtendGlobalTyVars extra_global_tvs thing_inside
457 = tcGetEnv `thenNF_Tc` \ env ->
458 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
459 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
461 tc_extend_gtvs gtvs extra_global_tvs
462 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
463 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
466 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
467 To improve subsequent calls to the same function it writes the zonked set back into
471 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
473 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
474 tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
475 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
476 tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
481 %************************************************************************
483 \subsection{The instance environment}
485 %************************************************************************
488 tcGetInstEnv :: NF_TcM InstEnv
489 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
490 returnNF_Tc (tcInsts env)
492 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
493 tcSetInstEnv ie thing_inside
494 = tcGetEnv `thenNF_Tc` \ env ->
495 tcSetEnv (env {tcInsts = ie}) thing_inside
499 %************************************************************************
501 \subsection{The InstInfo type}
503 %************************************************************************
505 The InstInfo type summarises the information in an instance declaration
507 instance c => k (t tvs) where b
512 iLocal :: Bool, -- True <=> it's defined in this module
513 iDFunId :: DFunId, -- The dfun id
514 iBinds :: RenamedMonoBinds, -- Bindings, b
515 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
518 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
519 nest 4 (ppr (iBinds info))]
521 simpleInstInfoTy :: InstInfo -> Type
522 simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
523 (_, _, _, [ty]) -> ty
525 simpleInstInfoTyCon :: InstInfo -> TyCon
526 -- Gets the type constructor for a simple instance declaration,
527 -- i.e. one of the form instance (...) => C (T a b c) where ...
528 simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst)
532 %************************************************************************
536 %************************************************************************
539 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
541 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
542 ptext SLIT("is not in scope"))