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,
23 tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
24 tcExtendLocalValEnv, tcLookup,
26 -- Global type variables
27 tcGetGlobalTyVars, tcExtendGlobalTyVars,
29 -- Random useful things
30 RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId,
33 newLocalId, newSpecPragmaId,
34 newDefaultMethodName, newDFunName,
37 isLocalThing, tcSetEnv
40 #include "HsVersions.h"
42 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
44 import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
45 tcInstTyVars, zonkTcTyVars,
47 import Id ( idName, mkUserLocal, isDataConWrapId_maybe )
48 import IdInfo ( vanillaIdInfo )
49 import MkId ( mkSpecPragmaId )
50 import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
53 tyVarsOfTypes, splitDFunTy,
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 isLocalName, 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 | isLocalName name = Nothing
155 | otherwise = lookupType hst pte name
158 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
159 tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
160 tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
161 tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
162 tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
164 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
166 -- This data type is used to help tie the knot
167 -- when type checking type and class declarations
168 data TyThingDetails = SynTyDetails Type
169 | DataTyDetails ClassContext [DataCon] [Class]
170 | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
174 %************************************************************************
176 \subsection{Basic lookups}
178 %************************************************************************
181 lookup_global :: TcEnv -> Name -> Maybe TyThing
182 -- Try the global envt and then the global symbol table
183 lookup_global env name
184 = case lookupNameEnv (tcGEnv env) name of
185 Just thing -> Just thing
186 Nothing -> tcGST env name
188 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
189 -- Try the local envt and then try the global
190 lookup_local env name
191 = case lookupNameEnv (tcLEnv env) name of
192 Just thing -> Just thing
193 Nothing -> case lookup_global env name of
194 Just thing -> Just (AGlobal thing)
199 type RecTcEnv = TcEnv
200 -- This environment is used for getting the 'right' IdInfo
201 -- on imported things and for looking up Ids in unfoldings
202 -- The environment doesn't have any local Ids in it
204 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
205 tcAddImportedIdInfo env id
206 = id `lazySetIdInfo` new_info
207 -- The Id must be returned without a data dependency on maybe_id
209 new_info = case tcLookupRecId env (idName id) of
210 Nothing -> vanillaIdInfo
211 Just imported_id -> idInfo imported_id
212 -- ToDo: could check that types are the same
214 tcLookupRecId :: RecTcEnv -> Name -> Maybe Id
215 tcLookupRecId env name = case lookup_global env name of
216 Just (AnId id) -> Just id
221 %************************************************************************
223 \subsection{Random useful functions}
225 %************************************************************************
229 -- A useful function that takes an occurrence of a global thing
230 -- and instantiates its type with fresh type variables
232 -> NF_TcM ([TcTyVar], -- It's instantiated type
237 (tyvars, rho) = splitForAllTys (idType id)
239 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
241 rho' = substTy tenv rho
242 (theta', tau') = splitRhoTy rho'
244 returnNF_Tc (tyvars', theta', tau')
248 %************************************************************************
250 \subsection{Making new Ids}
252 %************************************************************************
257 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
258 newLocalId name ty loc
259 = tcGetUnique `thenNF_Tc` \ uniq ->
260 returnNF_Tc (mkUserLocal name uniq ty loc)
262 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
263 newSpecPragmaId name ty
264 = tcGetUnique `thenNF_Tc` \ uniq ->
265 returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
268 Make a name for the dict fun for an instance decl
271 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
272 newDFunName mod clas (ty:_) loc
273 = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
274 tcGetUnique `thenNF_Tc` \ uniq ->
275 returnNF_Tc (mkGlobalName uniq mod
276 (mkDFunOcc dfun_string inst_uniq)
279 -- Any string that is somewhat unique will do
280 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
282 newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc)
284 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
285 newDefaultMethodName op_name loc
286 = tcGetUnique `thenNF_Tc` \ uniq ->
287 returnNF_Tc (mkGlobalName uniq (nameModule op_name)
288 (mkDefaultMethodOcc (getOccName op_name))
293 isLocalThing :: NamedThing a => Module -> a -> Bool
294 -- True if the thing has a Local name,
295 -- or a Global name from the specified module
296 isLocalThing mod thing = case nameModule_maybe (getName thing) of
297 Nothing -> True -- A local name
298 Just m -> m == mod -- A global thing
301 %************************************************************************
303 \subsection{The global environment}
305 %************************************************************************
308 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
309 tcExtendGlobalEnv bindings thing_inside
310 = tcGetEnv `thenNF_Tc` \ env ->
312 ge' = extendNameEnvList (tcGEnv env) bindings
314 tcSetEnv (env {tcGEnv = ge'}) thing_inside
316 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
317 tcExtendGlobalValEnv ids thing_inside
318 = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
323 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
324 tcLookupGlobal_maybe name
325 = tcGetEnv `thenNF_Tc` \ env ->
326 returnNF_Tc (lookup_global env name)
329 A variety of global lookups, when we know what we are looking for.
332 tcLookupGlobal :: Name -> NF_TcM TyThing
334 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
336 Just thing -> returnNF_Tc thing
337 other -> notFound "tcLookupGlobal" name
339 tcLookupGlobalId :: Name -> NF_TcM Id
340 tcLookupGlobalId name
341 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
343 Just (AnId clas) -> returnNF_Tc clas
344 other -> notFound "tcLookupGlobalId" name
346 tcLookupDataCon :: Name -> TcM DataCon
347 tcLookupDataCon con_name
348 = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
349 case isDataConWrapId_maybe con_id of
350 Just data_con -> returnTc data_con
351 Nothing -> failWithTc (badCon con_id)
354 tcLookupClass :: Name -> NF_TcM Class
356 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
358 Just (AClass clas) -> returnNF_Tc clas
359 other -> notFound "tcLookupClass" name
361 tcLookupTyCon :: Name -> NF_TcM TyCon
363 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
365 Just (ATyCon tc) -> returnNF_Tc tc
366 other -> notFound "tcLookupTyCon" name
370 %************************************************************************
372 \subsection{The local environment}
374 %************************************************************************
377 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
379 = tcGetEnv `thenNF_Tc` \ env ->
380 returnNF_Tc (lookup_local env name)
382 tcLookup :: Name -> NF_TcM TcTyThing
384 = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
386 Just thing -> returnNF_Tc thing
387 other -> notFound "tcLookup" name
388 -- Extract the IdInfo from an IfaceSig imported from an interface file
393 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
394 tcExtendKindEnv pairs thing_inside
395 = tcGetEnv `thenNF_Tc` \ env ->
397 le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
398 -- No need to extend global tyvars for kind checking
400 tcSetEnv (env {tcLEnv = le'}) thing_inside
402 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
403 tcExtendTyVarEnv tyvars thing_inside
404 = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
406 le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
407 new_tv_set = mkVarSet tyvars
409 -- It's important to add the in-scope tyvars to the global tyvar set
411 -- f (x::r) = let g y = y::r in ...
412 -- Here, g mustn't be generalised. This is also important during
413 -- class and instance decls, when we mustn't generalise the class tyvars
414 -- when typechecking the methods.
415 tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
416 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
418 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
419 -- the signature tyvars contain the original names
420 -- the instance tyvars are what those names should be mapped to
421 -- It's needed when typechecking the method bindings of class and instance decls
422 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
424 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
425 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
426 = tcGetEnv `thenNF_Tc` \ env ->
428 le' = extendNameEnvList (tcLEnv env) stuff
429 stuff = [ (getName sig_tv, ATyVar inst_tv)
430 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
433 tcSetEnv (env {tcLEnv = le'}) thing_inside
438 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
439 tcExtendLocalValEnv names_w_ids thing_inside
440 = tcGetEnv `thenNF_Tc` \ env ->
442 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
443 extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
444 le' = extendNameEnvList (tcLEnv env) extra_env
446 tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
447 tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
451 %************************************************************************
453 \subsection{The global tyvars}
455 %************************************************************************
458 tcExtendGlobalTyVars extra_global_tvs thing_inside
459 = tcGetEnv `thenNF_Tc` \ env ->
460 tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' ->
461 tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
463 tc_extend_gtvs gtvs extra_global_tvs
464 = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
465 tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
468 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
469 To improve subsequent calls to the same function it writes the zonked set back into
473 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
475 = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
476 tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
477 zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
479 global_tvs' = (tyVarsOfTypes global_tys')
481 tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
482 returnNF_Tc global_tvs'
486 %************************************************************************
488 \subsection{The instance environment}
490 %************************************************************************
493 tcGetInstEnv :: NF_TcM InstEnv
494 tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
495 returnNF_Tc (tcInsts env)
497 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
498 tcSetInstEnv ie thing_inside
499 = tcGetEnv `thenNF_Tc` \ env ->
500 tcSetEnv (env {tcInsts = ie}) thing_inside
504 %************************************************************************
506 \subsection{The InstInfo type}
508 %************************************************************************
510 The InstInfo type summarises the information in an instance declaration
512 instance c => k (t tvs) where b
517 iLocal :: Bool, -- True <=> it's defined in this module
518 iDFunId :: DFunId, -- The dfun id
519 iBinds :: RenamedMonoBinds, -- Bindings, b
520 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
523 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
524 nest 4 (ppr (iBinds info))]
526 simpleInstInfoTy :: InstInfo -> Type
527 simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
528 (_, _, _, [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
539 %************************************************************************
543 %************************************************************************
546 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
548 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
549 ptext SLIT("is not in scope"))