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, isLocalInst,
17 tcExtendGlobalEnv, tcExtendGlobalValEnv,
18 tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19 tcLookupGlobal_maybe, tcLookupGlobal,
23 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
24 tcExtendLocalValEnv, tcLookup,
26 -- Global type variables
27 tcGetGlobalTyVars, tcExtendGlobalTyVars,
29 -- Random useful things
30 tcAddImportedIdInfo, tcInstId,
33 newLocalId, newSpecPragmaId,
34 newDefaultMethodName, newDFunName,
37 isLocalThing, tcSetEnv, explicitLookupId
40 #include "HsVersions.h"
42 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
44 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
45 tcInstTyVars, zonkTcTyVars,
47 import Id ( mkUserLocal, isDataConWrapId_maybe )
48 import IdInfo ( vanillaIdInfo )
49 import MkId ( mkSpecPragmaId )
50 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
52 import Type ( Type, ThetaType,
54 splitForAllTys, splitRhoTy,
55 getDFunTyKey, splitTyConApp_maybe
57 import DataCon ( DataCon )
58 import TyCon ( TyCon )
59 import Class ( Class, ClassOpItem, ClassContext )
60 import Subst ( substTy )
61 import Name ( Name, OccName, NamedThing(..),
62 nameOccName, nameModule, getSrcLoc, mkGlobalName,
63 isLocallyDefined, nameModule_maybe,
64 NameEnv, lookupNameEnv, nameEnvElts,
65 extendNameEnvList, emptyNameEnv
67 import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
68 import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
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 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 :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
146 = do { gtv_var <- newIORef emptyVarSet ;
147 return (TcEnv { tcGST = lookup,
148 tcGEnv = emptyNameEnv,
149 tcInsts = emptyInstEnv,
150 tcLEnv = emptyNameEnv,
154 lookup name = lookupType hst pte name
157 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
158 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
159 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
160 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
161 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
163 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
165 -- This data type is used to help tie the knot
166 -- when type checking type and class declarations
167 data TyThingDetails = SynTyDetails Type
168 | DataTyDetails ClassContext [DataCon] [Class]
169 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
173 %************************************************************************
175 \subsection{Basic lookups}
177 %************************************************************************
180 lookup_global :: TcEnv -> Name -> Maybe TyThing
181 -- Try the global envt and then the global symbol table
182 lookup_global env name
183 = case lookupNameEnv (tcGEnv env) name of
184 Just thing -> Just thing
185 Nothing -> tcGST env name
187 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
188 -- Try the local envt and then try the global
189 lookup_local env name
190 = case lookupNameEnv (tcLEnv env) name of
191 Just thing -> Just thing
192 Nothing -> case lookup_global env name of
193 Just thing -> Just (AGlobal thing)
196 explicitLookupId :: TcEnv -> Name -> Maybe Id
197 explicitLookupId env name = case lookup_global env name of
198 Just (AnId id) -> Just id
203 %************************************************************************
205 \subsection{Random useful functions}
207 %************************************************************************
211 -- A useful function that takes an occurrence of a global thing
212 -- and instantiates its type with fresh type variables
214 -> NF_TcM ([TcTyVar], -- It's instantiated type
219 (tyvars, rho) = splitForAllTys (idType id)
221 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
223 rho' = substTy tenv rho
224 (theta', tau') = splitRhoTy rho'
226 returnNF_Tc (tyvars', theta', tau')
228 tcAddImportedIdInfo :: TcEnv -> Id -> Id
229 tcAddImportedIdInfo unf_env id
230 | isLocallyDefined id -- Don't look up locally defined Ids, because they
231 -- have explicit local definitions, so we get a black hole!
234 = id `lazySetIdInfo` new_info
235 -- The Id must be returned without a data dependency on maybe_id
237 new_info = case explicitLookupId unf_env (getName id) of
238 Nothing -> vanillaIdInfo
239 Just imported_id -> idInfo imported_id
240 -- ToDo: could check that types are the same
244 %************************************************************************
246 \subsection{Making new Ids}
248 %************************************************************************
253 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
254 newLocalId name ty loc
255 = tcGetUnique `thenNF_Tc` \ uniq ->
256 returnNF_Tc (mkUserLocal name uniq ty loc)
258 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
259 newSpecPragmaId name ty
260 = tcGetUnique `thenNF_Tc` \ uniq ->
261 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
264 Make a name for the dict fun for an instance decl
267 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
268 newDFunName mod clas (ty:_) loc
269 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
270 tcGetUnique `thenNF_Tc` \ uniq ->
271 returnNF_Tc (mkGlobalName uniq mod
272 (mkDFunOcc dfun_string inst_uniq)
275 -- Any string that is somewhat unique will do
276 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
278 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
279 newDefaultMethodName op_name loc
280 = tcGetUnique `thenNF_Tc` \ uniq ->
281 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
282 (mkDefaultMethodOcc (getOccName op_name))
287 isLocalThing :: NamedThing a => Module -> a -> Bool
288 -- True if the thing has a Local name,
289 -- or a Global name from the specified module
290 isLocalThing mod thing = case nameModule_maybe (getName thing) of
291 Nothing -> True -- A local name
292 Just m -> m == mod -- A global thing
295 %************************************************************************
297 \subsection{The global environment}
299 %************************************************************************
302 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
303 tcExtendGlobalEnv bindings thing_inside
304 = tcGetEnv `thenNF_Tc` \ env ->
306 ge' = extendNameEnvList (tcGEnv env) bindings
308 tcSetEnv (env {tcGEnv = ge'}) thing_inside
310 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
311 tcExtendGlobalValEnv ids thing_inside
312 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
317 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
318 tcLookupGlobal_maybe name
319 = tcGetEnv `thenNF_Tc` \ env ->
320 returnNF_Tc (lookup_global env name)
323 A variety of global lookups, when we know what we are looking for.
326 tcLookupGlobal :: Name -> NF_TcM TyThing
328 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
330 Just thing -> returnNF_Tc thing
331 other -> notFound "tcLookupGlobal" name
333 tcLookupGlobalId :: Name -> NF_TcM Id
334 tcLookupGlobalId name
335 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
337 Just (AnId clas) -> returnNF_Tc clas
338 other -> notFound "tcLookupGlobalId" name
340 tcLookupDataCon :: Name -> TcM DataCon
341 tcLookupDataCon con_name
342 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
343 case isDataConWrapId_maybe con_id of
344 Just data_con -> returnTc data_con
345 Nothing -> failWithTc (badCon con_id)
348 tcLookupClass :: Name -> NF_TcM Class
350 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
352 Just (AClass clas) -> returnNF_Tc clas
353 other -> notFound "tcLookupClass" name
355 tcLookupTyCon :: Name -> NF_TcM TyCon
357 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
359 Just (ATyCon tc) -> returnNF_Tc tc
360 other -> notFound "tcLookupTyCon" name
364 %************************************************************************
366 \subsection{The local environment}
368 %************************************************************************
371 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
373 = tcGetEnv `thenNF_Tc` \ env ->
374 returnNF_Tc (lookup_local env name)
376 tcLookup :: Name -> NF_TcM TcTyThing
378 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
380 Just thing -> returnNF_Tc thing
381 other -> notFound "tcLookup" name
382 -- Extract the IdInfo from an IfaceSig imported from an interface file
387 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
388 tcExtendKindEnv pairs thing_inside
389 = tcGetEnv `thenNF_Tc` \ env ->
391 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
392 -- No need to extend global tyvars for kind checking
394 tcSetEnv (env {tcLEnv = le'}) thing_inside
396 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
397 tcExtendTyVarEnv tyvars thing_inside
398 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
400 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
401 new_tv_set = mkVarSet tyvars
403 -- It's important to add the in-scope tyvars to the global tyvar set
405 -- f (x::r) = let g y = y::r in ...
406 -- Here, g mustn't be generalised. This is also important during
407 -- class and instance decls, when we mustn't generalise the class tyvars
408 -- when typechecking the methods.
409 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
410 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
412 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
413 -- the signature tyvars contain the original names
414 -- the instance tyvars are what those names should be mapped to
415 -- It's needed when typechecking the method bindings of class and instance decls
416 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
418 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
419 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
420 = tcGetEnv `thenNF_Tc` \ env ->
422 le' = extendNameEnvList (tcLEnv env) stuff
423 stuff = [ (getName sig_tv, ATyVar inst_tv)
424 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
427 tcSetEnv (env {tcLEnv = le'}) thing_inside
432 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
433 tcExtendLocalValEnv names_w_ids thing_inside
434 = tcGetEnv `thenNF_Tc` \ env ->
436 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
437 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
438 le' = extendNameEnvList (tcLEnv env) extra_env
440 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
441 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
445 %************************************************************************
447 \subsection{The global tyvars}
449 %************************************************************************
452 tcExtendGlobalTyVars extra_global_tvs thing_inside
453 = tcGetEnv `thenNF_Tc` \ env ->
454 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
455 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
457 tc_extend_gtvs gtvs extra_global_tvs
458 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
459 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
462 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
463 To improve subsequent calls to the same function it writes the zonked set back into
467 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
469 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
470 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
471 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
473 global_tvs' = (tyVarsOfTypes global_tys')
475 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
476 returnNF_Tc global_tvs'
480 %************************************************************************
482 \subsection{The instance environment}
484 %************************************************************************
487 tcGetInstEnv :: NF_TcM InstEnv
488 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
489 returnNF_Tc (tcInsts env)
491 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
492 tcSetInstEnv ie thing_inside
493 = tcGetEnv `thenNF_Tc` \ env ->
494 tcSetEnv (env {tcInsts = ie}) thing_inside
498 %************************************************************************
500 \subsection{The InstInfo type}
502 %************************************************************************
504 The InstInfo type summarises the information in an instance declaration
506 instance c => k (t tvs) where b
511 iClass :: Class, -- Class, k
512 iTyVars :: [TyVar], -- Type variables, tvs
513 iTys :: [Type], -- The types at which the class is being instantiated
514 iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
515 -- instance declaration. It constrains (some of)
517 iLocal :: Bool, -- True <=> it's defined in this module
518 iDFunId :: DFunId, -- The dfun id
519 iBinds :: RenamedMonoBinds, -- Bindings, b
520 iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn
521 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
524 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
525 nest 4 (ppr (iBinds info))]
527 simpleInstInfoTy :: InstInfo -> Type
528 simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
530 simpleInstInfoTyCon :: InstInfo -> TyCon
531 -- Gets the type constructor for a simple instance declaration,
532 -- i.e. one of the form instance (...) => C (T a b c) where ...
533 simpleInstInfoTyCon inst
534 = case splitTyConApp_maybe (simpleInstInfoTy inst) of
535 Just (tycon, _) -> tycon
537 isLocalInst :: Module -> InstInfo -> Bool
538 isLocalInst mod info = isLocalThing mod (iDFunId info)
542 %************************************************************************
546 %************************************************************************
549 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
551 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
552 ptext SLIT("is not in scope"))