[project @ 2001-02-20 09:40:43 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, 
18         tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
19         tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
20
21         -- Local environment
22         tcExtendKindEnv,  tcLookupLocalIds,
23         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, 
24         tcExtendLocalValEnv, tcLookup, tcLookup_maybe, 
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 TcType           ( TcKind,  TcType, TcTyVar, TcTyVarSet, 
45                           zonkTcTyVarsAndFV
46                         )
47 import Id               ( idName, mkUserLocal, isDataConWrapId_maybe )
48 import IdInfo           ( constantIdInfo )
49 import MkId             ( mkSpecPragmaId )
50 import Var              ( TyVar, Id, idType, lazySetIdInfo, idInfo )
51 import VarSet
52 import Type             ( Type,
53                           tyVarsOfTypes, splitDFunTy,
54                           getDFunTyKey, tyConAppTyCon
55                         )
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
62                         )
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 
72 import Outputable
73
74 import IOExts           ( newIORef )
75 \end{code}
76
77 %************************************************************************
78 %*                                                                      *
79 \subsection{TcEnv}
80 %*                                                                      *
81 %************************************************************************
82
83 \begin{code}
84 type TcId    = Id                       -- Type may be a TcType
85 type TcIdSet = IdSet
86
87 data TcEnv
88   = TcEnv {
89         tcSyntaxMap :: PrelNames.SyntaxMap,     -- The syntax map (usually the identity)
90
91         tcGST    :: Name -> Maybe TyThing,      -- The type environment at the moment we began this compilation
92
93         tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
94
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)
98                                         --      imported Ids
99                                         -- (Ids defined in this module are in the local envt)
100
101         tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
102                                         -- defined in this module
103
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
108     }
109
110 \end{code}
111
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)
117         * Imported Ids
118
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
122
123 Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
124 used thus:
125         a) fed back (via the knot) to typechecking the 
126            unfoldings of interface signatures
127
128         b) used to augment the GlobalSymbolTable
129
130
131 \begin{code}
132 data TcTyThing
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
143
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,
148                          tcGST    = lookup,
149                          tcGEnv   = emptyNameEnv,
150                          tcInsts  = emptyInstEnv,
151                          tcLEnv   = emptyNameEnv,
152                          tcTyVars = gtv_var
153          })}
154   where
155     lookup name | isLocalName name = Nothing
156                 | otherwise        = lookupType hst pte name
157
158
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)]
164
165 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
166
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
172 \end{code}
173
174
175 %************************************************************************
176 %*                                                                      *
177 \subsection{Basic lookups}
178 %*                                                                      *
179 %************************************************************************
180
181 \begin{code}
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
188
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)
196                         Nothing    -> Nothing
197 \end{code}
198
199 \begin{code}
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
204
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
209   where
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
214
215 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
216 tcLookupRecId_maybe env name = case lookup_global env name of
217                                    Just (AnId id) -> Just id
218                                    other          -> Nothing
219
220 tcLookupRecId ::  RecTcEnv -> Name -> Id
221 tcLookupRecId env name = case lookup_global env name of
222                                 Just (AnId id) -> id
223                                 Nothing        -> pprPanic "tcLookupRecId" (ppr name)
224 \end{code}
225
226 %************************************************************************
227 %*                                                                      *
228 \subsection{Making new Ids}
229 %*                                                                      *
230 %************************************************************************
231
232 Constructing new Ids
233
234 \begin{code}
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)
239
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))
244 \end{code}
245
246 Make a name for the dict fun for an instance decl.
247 It's a *local* name for the moment.  The CoreTidy pass
248 will globalise it.
249
250 \begin{code}
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)
255   where
256         -- Any string that is somewhat unique will do
257     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
258
259 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
260 \end{code}
261
262 \begin{code}
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
269 \end{code}
270
271 %************************************************************************
272 %*                                                                      *
273 \subsection{The global environment}
274 %*                                                                      *
275 %************************************************************************
276
277 \begin{code}
278 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
279 tcExtendGlobalEnv things thing_inside
280   = tcGetEnv                            `thenNF_Tc` \ env ->
281     let
282         ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
283     in
284     tcSetEnv (env {tcGEnv = ge'}) thing_inside
285
286 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
287 tcExtendGlobalValEnv ids thing_inside
288   = tcGetEnv                            `thenNF_Tc` \ env ->
289     let
290         ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids]
291     in
292     tcSetEnv (env {tcGEnv = ge'}) thing_inside
293 \end{code}
294
295
296 \begin{code}
297 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
298 tcLookupGlobal_maybe name
299   = tcGetEnv            `thenNF_Tc` \ env ->
300     returnNF_Tc (lookup_global env name)
301 \end{code}
302
303 A variety of global lookups, when we know what we are looking for.
304
305 \begin{code}
306 tcLookupGlobal :: Name -> NF_TcM TyThing
307 tcLookupGlobal name
308   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
309     case maybe_thing of
310         Just thing -> returnNF_Tc thing
311         other      -> notFound "tcLookupGlobal" name
312
313 tcLookupGlobalId :: Name -> NF_TcM Id
314 tcLookupGlobalId name
315   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
316     case maybe_id of
317         Just (AnId id) -> returnNF_Tc id
318         other          -> notFound "tcLookupGlobalId" name
319         
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)
326
327
328 tcLookupClass :: Name -> NF_TcM Class
329 tcLookupClass name
330   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
331     case maybe_clas of
332         Just (AClass clas) -> returnNF_Tc clas
333         other              -> notFound "tcLookupClass" name
334         
335 tcLookupTyCon :: Name -> NF_TcM TyCon
336 tcLookupTyCon name
337   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
338     case maybe_tc of
339         Just (ATyCon tc) -> returnNF_Tc tc
340         other            -> notFound "tcLookupTyCon" name
341
342 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
343 tcLookupLocalIds ns
344   = tcGetEnv            `thenNF_Tc` \ env ->
345     returnNF_Tc (map (lookup (tcLEnv env)) ns)
346   where
347     lookup lenv name = case lookupNameEnv lenv name of
348                         Just (ATcId id) -> id
349                         other           -> pprPanic "tcLookupLocalIds" (ppr name)
350
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
358                         Just (AnId id) -> id
359                         other          -> pprPanic "tcLookupSyntaxId" (ppr name))
360
361 tcLookupSyntaxName :: Name -> NF_TcM Name
362 tcLookupSyntaxName name
363   = tcGetEnv            `thenNF_Tc` \ env ->
364     returnNF_Tc (tcSyntaxMap env name)
365 \end{code}
366
367
368 %************************************************************************
369 %*                                                                      *
370 \subsection{The local environment}
371 %*                                                                      *
372 %************************************************************************
373
374 \begin{code}
375 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
376 tcLookup_maybe name
377   = tcGetEnv            `thenNF_Tc` \ env ->
378     returnNF_Tc (lookup_local env name)
379
380 tcLookup :: Name -> NF_TcM TcTyThing
381 tcLookup name
382   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
383     case maybe_thing of
384         Just thing -> returnNF_Tc thing
385         other      -> notFound "tcLookup" name
386         -- Extract the IdInfo from an IfaceSig imported from an interface file
387 \end{code}
388
389
390 \begin{code}
391 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
392 tcExtendKindEnv pairs thing_inside
393   = tcGetEnv                            `thenNF_Tc` \ env ->
394     let
395         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
396         -- No need to extend global tyvars for kind checking
397     in
398     tcSetEnv (env {tcLEnv = le'}) thing_inside
399     
400 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
401 tcExtendTyVarEnv tyvars thing_inside
402   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
403     let
404         le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
405         new_tv_set = mkVarSet tyvars
406     in
407         -- It's important to add the in-scope tyvars to the global tyvar set
408         -- as well.  Consider
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
415
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
421
422 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
423 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
424   = tcGetEnv                                    `thenNF_Tc` \ env ->
425     let
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
429                 ]
430     in
431     tcSetEnv (env {tcLEnv = le'}) thing_inside
432 \end{code}
433
434
435 \begin{code}
436 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
437 tcExtendLocalValEnv names_w_ids thing_inside
438   = tcGetEnv            `thenNF_Tc` \ env ->
439     let
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
443     in
444     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
445     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
446 \end{code}
447
448
449 %************************************************************************
450 %*                                                                      *
451 \subsection{The global tyvars}
452 %*                                                                      *
453 %************************************************************************
454
455 \begin{code}
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
460
461 tc_extend_gtvs gtvs extra_global_tvs
462   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
463     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
464 \end{code}
465
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
468 the environment.
469
470 \begin{code}
471 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
472 tcGetGlobalTyVars
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_` 
477     returnNF_Tc gbl_tvs'
478 \end{code}
479
480
481 %************************************************************************
482 %*                                                                      *
483 \subsection{The instance environment}
484 %*                                                                      *
485 %************************************************************************
486
487 \begin{code}
488 tcGetInstEnv :: NF_TcM InstEnv
489 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ env -> 
490                returnNF_Tc (tcInsts env)
491
492 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
493 tcSetInstEnv ie thing_inside
494   = tcGetEnv    `thenNF_Tc` \ env ->
495     tcSetEnv (env {tcInsts = ie}) thing_inside
496 \end{code}    
497
498
499 %************************************************************************
500 %*                                                                      *
501 \subsection{The InstInfo type}
502 %*                                                                      *
503 %************************************************************************
504
505 The InstInfo type summarises the information in an instance declaration
506
507     instance c => k (t tvs) where b
508
509 \begin{code}
510 data InstInfo
511   = InstInfo {
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
516     }
517
518 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
519                          nest 4 (ppr (iBinds info))]
520
521 simpleInstInfoTy :: InstInfo -> Type
522 simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
523                           (_, _, _, [ty]) -> ty
524
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)
529 \end{code}
530
531
532 %************************************************************************
533 %*                                                                      *
534 \subsection{Errors}
535 %*                                                                      *
536 %************************************************************************
537
538 \begin{code}
539 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
540
541 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> 
542                                   ptext SLIT("is not in scope"))
543 \end{code}