[project @ 2001-07-13 13:29:56 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcEnv.lhs
1 \begin{code}
2 module TcEnv(
3         TcId, TcIdSet, 
4         TyThing(..), TyThingDetails(..), TcTyThing(..),
5
6         -- Getting stuff from the environment
7         TcEnv, initTcEnv, 
8         tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
9         getTcGEnv,
10         
11         -- Instance environment, and InstInfo type
12         tcGetInstEnv, tcSetInstEnv, 
13         InstInfo(..), pprInstInfo,
14         simpleInstInfoTy, simpleInstInfoTyCon, 
15
16         -- Global environment
17         tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
18         tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19         tcLookupGlobal_maybe, tcLookupGlobal, 
20
21         -- Local environment
22         tcExtendKindEnv,  tcLookupLocalIds, tcInLocalScope,
23         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, 
24         tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId,
25
26         -- Global type variables
27         tcGetGlobalTyVars, tcExtendGlobalTyVars,
28
29         -- Random useful things
30         RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, 
31
32         -- New Ids
33         newLocalId, newSpecPragmaId,
34         newDFunName,
35
36         -- Misc
37         isLocalThing, tcSetEnv
38   ) where
39
40 #include "HsVersions.h"
41
42 import RnHsSyn          ( RenamedMonoBinds, RenamedSig )
43 import TcMonad
44 import TcMType          ( zonkTcTyVarsAndFV )
45 import TcType           ( Type, ThetaType, 
46                           tyVarsOfTypes, tcSplitDFunTy,
47                           getDFunTyKey, tcTyConAppTyCon
48                         )
49 import Id               ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
50 import IdInfo           ( vanillaIdInfo )
51 import Var              ( TyVar, Id, idType, lazySetIdInfo, idInfo )
52 import VarSet
53 import DataCon          ( DataCon )
54 import TyCon            ( TyCon )
55 import Class            ( Class, ClassOpItem )
56 import Name             ( Name, OccName, NamedThing(..), 
57                           nameOccName, getSrcLoc, mkLocalName, isLocalName,
58                           nameIsLocalOrFrom
59                         )
60 import NameEnv          ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
61                           extendNameEnvList, emptyNameEnv, plusNameEnv )
62 import OccName          ( mkDFunOcc, occNameString )
63 import HscTypes         ( DFunId, 
64                           PackageTypeEnv, TypeEnv, 
65                           extendTypeEnvList, extendTypeEnvWithIds,
66                           typeEnvTyCons, typeEnvClasses, typeEnvIds,
67                           HomeSymbolTable
68                         )
69 import Module           ( Module )
70 import InstEnv          ( InstEnv, emptyInstEnv )
71 import HscTypes         ( lookupType, TyThing(..) )
72 import Util             ( zipEqual )
73 import SrcLoc           ( SrcLoc )
74 import qualified PrelNames 
75 import Outputable
76
77 import IOExts           ( newIORef )
78 \end{code}
79
80 %************************************************************************
81 %*                                                                      *
82 \subsection{TcEnv}
83 %*                                                                      *
84 %************************************************************************
85
86 \begin{code}
87 type TcId    = Id                       -- Type may be a TcType
88 type TcIdSet = IdSet
89
90 data TcEnv
91   = TcEnv {
92         tcGST    :: Name -> Maybe TyThing,      -- The type environment at the moment we began this compilation
93
94         tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
95
96         tcGEnv   :: TypeEnv,            -- The global type environment we've accumulated while
97                  {- NameEnv TyThing-}   -- compiling this module:
98                                         --      types and classes (both imported and local)
99                                         --      imported Ids
100                                         -- (Ids defined in this module start in the local envt, 
101                                         --  though they move to the global envt during zonking)
102
103         tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
104                                         -- defined in this module
105
106         tcTyVars :: TcRef TcTyVarSet    -- The "global tyvars"
107                                         -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
108                                         -- mentioned in the types of Ids bound in tcLEnv
109                                         -- Why mutable? see notes with tcGetGlobalTyVars
110     }
111
112 \end{code}
113
114 The Global-Env/Local-Env story
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 During type checking, we keep in the GlobalEnv
117         * All types and classes
118         * All Ids derived from types and classes (constructors, selectors)
119         * Imported Ids
120
121 At the end of type checking, we zonk the local bindings,
122 and as we do so we add to the GlobalEnv
123         * Locally defined top-level Ids
124
125 Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
126 used thus:
127         a) fed back (via the knot) to typechecking the 
128            unfoldings of interface signatures
129
130         b) used to augment the GlobalSymbolTable
131
132
133 \begin{code}
134 data TcTyThing
135   = AGlobal TyThing     -- Used only in the return type of a lookup
136   | ATcId  TcId         -- Ids defined in this module
137   | ATyVar TyVar        -- Type variables
138   | AThing TcKind       -- Used temporarily, during kind checking
139 -- Here's an example of how the AThing guy is used
140 -- Suppose we are checking (forall a. T a Int):
141 --      1. We first bind (a -> AThink kv), where kv is a kind variable. 
142 --      2. Then we kind-check the (T a Int) part.
143 --      3. Then we zonk the kind variable.
144 --      4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
145
146 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
147 initTcEnv hst pte 
148   = do { gtv_var <- newIORef emptyVarSet ;
149          return (TcEnv { tcGST    = lookup,
150                          tcGEnv   = emptyNameEnv,
151                          tcInsts  = emptyInstEnv,
152                          tcLEnv   = emptyNameEnv,
153                          tcTyVars = gtv_var
154          })}
155   where
156     lookup name | isLocalName name = Nothing
157                 | otherwise        = lookupType hst pte name
158
159
160 tcEnvClasses env = typeEnvClasses (tcGEnv env)
161 tcEnvTyCons  env = typeEnvTyCons  (tcGEnv env) 
162 tcEnvIds     env = typeEnvIds     (tcGEnv env) 
163 tcEnvTyVars  env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
164 tcEnvTcIds   env = [id | ATcId  id <- nameEnvElts (tcLEnv env)]
165
166 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
167
168 tcInLocalScope :: TcEnv -> Name -> Bool
169 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
170
171 -- This data type is used to help tie the knot
172 -- when type checking type and class declarations
173 data TyThingDetails = SynTyDetails Type
174                     | DataTyDetails ThetaType [DataCon] [Id]
175                     | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
176                     | ForeignTyDetails  -- Nothing yet
177 \end{code}
178
179
180 %************************************************************************
181 %*                                                                      *
182 \subsection{Basic lookups}
183 %*                                                                      *
184 %************************************************************************
185
186 \begin{code}
187 lookup_global :: TcEnv -> Name -> Maybe TyThing
188         -- Try the global envt and then the global symbol table
189 lookup_global env name 
190   = case lookupNameEnv (tcGEnv env) name of
191         Just thing -> Just thing
192         Nothing    -> tcGST env name
193
194 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
195         -- Try the local envt and then try the global
196 lookup_local env name
197   = case lookupNameEnv (tcLEnv env) name of
198         Just thing -> Just thing
199         Nothing    -> case lookup_global env name of
200                         Just thing -> Just (AGlobal thing)
201                         Nothing    -> Nothing
202 \end{code}
203
204 \begin{code}
205 type RecTcEnv = TcEnv
206 -- This environment is used for getting the 'right' IdInfo 
207 -- on imported things and for looking up Ids in unfoldings
208 -- The environment doesn't have any local Ids in it
209
210 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
211 tcAddImportedIdInfo env id
212   = id `lazySetIdInfo` new_info
213         -- The Id must be returned without a data dependency on maybe_id
214   where
215     new_info = case tcLookupRecId_maybe env (idName id) of
216                   Nothing          -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
217                   Just imported_id -> idInfo imported_id
218                 -- ToDo: could check that types are the same
219
220 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
221 tcLookupRecId_maybe env name = case lookup_global env name of
222                                    Just (AnId id) -> Just id
223                                    other          -> Nothing
224
225 tcLookupRecId ::  RecTcEnv -> Name -> Id
226 tcLookupRecId env name = case lookup_global env name of
227                                 Just (AnId id) -> id
228                                 Nothing        -> pprPanic "tcLookupRecId" (ppr name)
229 \end{code}
230
231 %************************************************************************
232 %*                                                                      *
233 \subsection{Making new Ids}
234 %*                                                                      *
235 %************************************************************************
236
237 Constructing new Ids
238
239 \begin{code}
240 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
241 newLocalId name ty loc
242   = tcGetUnique         `thenNF_Tc` \ uniq ->
243     returnNF_Tc (mkUserLocal name uniq ty loc)
244
245 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
246 newSpecPragmaId name ty 
247   = tcGetUnique         `thenNF_Tc` \ uniq ->
248     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
249 \end{code}
250
251 Make a name for the dict fun for an instance decl.
252 It's a *local* name for the moment.  The CoreTidy pass
253 will globalise it.
254
255 \begin{code}
256 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
257 newDFunName clas (ty:_) loc
258   = tcGetUnique                 `thenNF_Tc` \ uniq ->
259     returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
260   where
261         -- Any string that is somewhat unique will do
262     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
263
264 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
265 \end{code}
266
267 \begin{code}
268 isLocalThing :: NamedThing a => Module -> a -> Bool
269 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
270 \end{code}
271
272 %************************************************************************
273 %*                                                                      *
274 \subsection{The global environment}
275 %*                                                                      *
276 %************************************************************************
277
278 \begin{code}
279 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
280 tcExtendGlobalEnv things thing_inside
281   = tcGetEnv                            `thenNF_Tc` \ env ->
282     let
283         ge' = extendTypeEnvList (tcGEnv env) things
284     in
285     tcSetEnv (env {tcGEnv = ge'}) thing_inside
286
287
288 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
289 tcExtendGlobalTypeEnv extra_env thing_inside
290   = tcGetEnv                            `thenNF_Tc` \ env ->
291     let
292         ge' = tcGEnv env `plusNameEnv` extra_env
293     in
294     tcSetEnv (env {tcGEnv = ge'}) thing_inside
295
296 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
297 tcExtendGlobalValEnv ids thing_inside
298   = tcGetEnv                            `thenNF_Tc` \ env ->
299     let
300         ge' = extendTypeEnvWithIds (tcGEnv env) ids
301     in
302     tcSetEnv (env {tcGEnv = ge'}) thing_inside
303 \end{code}
304
305
306 \begin{code}
307 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
308 tcLookupGlobal_maybe name
309   = tcGetEnv            `thenNF_Tc` \ env ->
310     returnNF_Tc (lookup_global env name)
311 \end{code}
312
313 A variety of global lookups, when we know what we are looking for.
314
315 \begin{code}
316 tcLookupGlobal :: Name -> NF_TcM TyThing
317 tcLookupGlobal name
318   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
319     case maybe_thing of
320         Just thing -> returnNF_Tc thing
321         other      -> notFound "tcLookupGlobal" name
322
323 tcLookupGlobalId :: Name -> NF_TcM Id
324 tcLookupGlobalId name
325   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
326     case maybe_id of
327         Just (AnId id) -> returnNF_Tc id
328         other          -> notFound "tcLookupGlobalId" name
329         
330 tcLookupDataCon :: Name -> TcM DataCon
331 tcLookupDataCon con_name
332   = tcLookupGlobalId con_name           `thenNF_Tc` \ con_id ->
333     case isDataConWrapId_maybe con_id of
334         Just data_con -> returnTc data_con
335         Nothing       -> failWithTc (badCon con_id)
336
337
338 tcLookupClass :: Name -> NF_TcM Class
339 tcLookupClass name
340   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
341     case maybe_clas of
342         Just (AClass clas) -> returnNF_Tc clas
343         other              -> notFound "tcLookupClass" name
344         
345 tcLookupTyCon :: Name -> NF_TcM TyCon
346 tcLookupTyCon name
347   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
348     case maybe_tc of
349         Just (ATyCon tc) -> returnNF_Tc tc
350         other            -> notFound "tcLookupTyCon" name
351
352 tcLookupId :: Name -> NF_TcM Id
353 tcLookupId name
354   = tcLookup name       `thenNF_Tc` \ thing -> 
355     case thing of
356         ATcId tc_id       -> returnNF_Tc tc_id
357         AGlobal (AnId id) -> returnNF_Tc id
358         other             -> pprPanic "tcLookupId" (ppr name)
359
360 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
361 tcLookupLocalIds ns
362   = tcGetEnv            `thenNF_Tc` \ env ->
363     returnNF_Tc (map (lookup (tcLEnv env)) ns)
364   where
365     lookup lenv name = case lookupNameEnv lenv name of
366                         Just (ATcId id) -> id
367                         other           -> pprPanic "tcLookupLocalIds" (ppr name)
368 \end{code}
369
370
371 %************************************************************************
372 %*                                                                      *
373 \subsection{The local environment}
374 %*                                                                      *
375 %************************************************************************
376
377 \begin{code}
378 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
379 tcLookup_maybe name
380   = tcGetEnv            `thenNF_Tc` \ env ->
381     returnNF_Tc (lookup_local env name)
382
383 tcLookup :: Name -> NF_TcM TcTyThing
384 tcLookup name
385   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
386     case maybe_thing of
387         Just thing -> returnNF_Tc thing
388         other      -> notFound "tcLookup" name
389         -- Extract the IdInfo from an IfaceSig imported from an interface file
390 \end{code}
391
392
393 \begin{code}
394 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
395 tcExtendKindEnv pairs thing_inside
396   = tcGetEnv                            `thenNF_Tc` \ env ->
397     let
398         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
399         -- No need to extend global tyvars for kind checking
400     in
401     tcSetEnv (env {tcLEnv = le'}) thing_inside
402     
403 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
404 tcExtendTyVarEnv tyvars thing_inside
405   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
406     let
407         le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
408         new_tv_set = mkVarSet tyvars
409     in
410         -- It's important to add the in-scope tyvars to the global tyvar set
411         -- as well.  Consider
412         --      f (x::r) = let g y = y::r in ...
413         -- Here, g mustn't be generalised.  This is also important during
414         -- class and instance decls, when we mustn't generalise the class tyvars
415         -- when typechecking the methods.
416     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
417     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
418
419 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
420 --      the signature tyvars contain the original names
421 --      the instance  tyvars are what those names should be mapped to
422 -- It's needed when typechecking the method bindings of class and instance decls
423 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
424
425 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
426 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
427   = tcGetEnv                                    `thenNF_Tc` \ env ->
428     let
429         le'   = extendNameEnvList (tcLEnv env) stuff
430         stuff = [ (getName sig_tv, ATyVar inst_tv)
431                 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
432                 ]
433     in
434     tcSetEnv (env {tcLEnv = le'}) thing_inside
435 \end{code}
436
437
438 \begin{code}
439 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
440 tcExtendLocalValEnv names_w_ids thing_inside
441   = tcGetEnv            `thenNF_Tc` \ env ->
442     let
443         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
444         extra_env           = [(name, ATcId id) | (name,id) <- names_w_ids]
445         le'                 = extendNameEnvList (tcLEnv env) extra_env
446     in
447     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
448     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
449 \end{code}
450
451
452 %************************************************************************
453 %*                                                                      *
454 \subsection{The global tyvars}
455 %*                                                                      *
456 %************************************************************************
457
458 \begin{code}
459 tcExtendGlobalTyVars extra_global_tvs thing_inside
460   = tcGetEnv                                            `thenNF_Tc` \ env ->
461     tc_extend_gtvs (tcTyVars env) extra_global_tvs      `thenNF_Tc` \ gtvs' ->
462     tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
463
464 tc_extend_gtvs gtvs extra_global_tvs
465   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
466     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
467 \end{code}
468
469 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
470 To improve subsequent calls to the same function it writes the zonked set back into
471 the environment.
472
473 \begin{code}
474 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
475 tcGetGlobalTyVars
476   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
477     tcReadMutVar gtv_var                        `thenNF_Tc` \ gbl_tvs ->
478     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenNF_Tc` \ gbl_tvs' ->
479     tcWriteMutVar gtv_var gbl_tvs'              `thenNF_Tc_` 
480     returnNF_Tc gbl_tvs'
481 \end{code}
482
483
484 %************************************************************************
485 %*                                                                      *
486 \subsection{The instance environment}
487 %*                                                                      *
488 %************************************************************************
489
490 \begin{code}
491 tcGetInstEnv :: NF_TcM InstEnv
492 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ env -> 
493                returnNF_Tc (tcInsts env)
494
495 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
496 tcSetInstEnv ie thing_inside
497   = tcGetEnv    `thenNF_Tc` \ env ->
498     tcSetEnv (env {tcInsts = ie}) thing_inside
499 \end{code}    
500
501
502 %************************************************************************
503 %*                                                                      *
504 \subsection{The InstInfo type}
505 %*                                                                      *
506 %************************************************************************
507
508 The InstInfo type summarises the information in an instance declaration
509
510     instance c => k (t tvs) where b
511
512 \begin{code}
513 data InstInfo
514   = InstInfo {
515       iDFunId :: DFunId,                -- The dfun id
516       iBinds  :: RenamedMonoBinds,      -- Bindings, b
517       iPrags  :: [RenamedSig]           -- User pragmas recorded for generating specialised instances
518     }
519
520 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
521                          nest 4 (ppr (iBinds info))]
522
523 simpleInstInfoTy :: InstInfo -> Type
524 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
525                           (_, _, _, [ty]) -> ty
526
527 simpleInstInfoTyCon :: InstInfo -> TyCon
528   -- Gets the type constructor for a simple instance declaration,
529   -- i.e. one of the form       instance (...) => C (T a b c) where ...
530 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
531 \end{code}
532
533
534 %************************************************************************
535 %*                                                                      *
536 \subsection{Errors}
537 %*                                                                      *
538 %************************************************************************
539
540 \begin{code}
541 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
542
543 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> 
544                                   ptext SLIT("is not in scope"))
545 \end{code}