TcEnv.lhs 16.5 KB
Newer Older
1
2
\begin{code}
module TcEnv(
3
	TcId, TcIdSet, 
4
	TyThing(..), TyThingDetails(..), TcTyThing(..),
5
6

	-- Getting stuff from the environment
7
	TcEnv, initTcEnv, 
8
	tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts,
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
27
	-- Global type variables
	tcGetGlobalTyVars, tcExtendGlobalTyVars,
28

29
	-- Random useful things
30
	RecTcEnv, tcLookupRecId, tcLookupRecId_maybe, 
31

32
	-- New Ids
33
	newLocalName, newDFunName,
34

35
	-- Misc
36
	isLocalThing, tcSetEnv
37
38
  ) where

39
#include "HsVersions.h"
40

41
import RnHsSyn		( RenamedMonoBinds, RenamedSig )
42
import TcMonad
43
import TcMType		( zonkTcTyVarsAndFV )
44
import TcType		( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, 
45
46
			  tyVarsOfTypes, tcSplitDFunTy,
			  getDFunTyKey, tcTyConAppTyCon
47
			)
48
import Id		( idName, isDataConWrapId_maybe )
49
import IdInfo		( vanillaIdInfo )
50
import Var		( TyVar, Id, idType, lazySetIdInfo, idInfo )
51
import VarSet
52
import DataCon		( DataCon )
53
import TyCon		( TyCon )
54
import Class		( Class, ClassOpItem )
55
56
import Name		( Name, NamedThing(..), 
			  getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom
57
			)
58
import NameEnv		( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
59
			  extendNameEnvList, emptyNameEnv, plusNameEnv )
60
import OccName		( mkDFunOcc, occNameString )
61
62
63
64
65
import HscTypes		( DFunId, 
			  PackageTypeEnv, TypeEnv, 
			  extendTypeEnvList, extendTypeEnvWithIds,
			  typeEnvTyCons, typeEnvClasses, typeEnvIds,
			  HomeSymbolTable
66
			)
67
import Module		( Module )
68
import InstEnv		( InstEnv, emptyInstEnv )
69
import HscTypes		( lookupType, TyThing(..) )
70
import Util		( zipEqual )
71
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
72
import Outputable
73
74

import IOExts		( newIORef )
75
76
\end{code}

77
78
79
80
81
82
%************************************************************************
%*									*
\subsection{TcEnv}
%*									*
%************************************************************************

83
\begin{code}
84
85
86
type TcId    = Id 			-- Type may be a TcType
type TcIdSet = IdSet

87
88
data TcEnv
  = TcEnv {
89
	tcGST  	 :: Name -> Maybe TyThing,	-- The type environment at the moment we began this compilation
90

91
	tcInsts	 :: InstEnv,		-- All instances (both imported and in this module)
92

93
	tcGEnv	 :: TypeEnv,		-- The global type environment we've accumulated while
94
		 {- NameEnv TyThing-}	-- compiling this module:
95
96
					--	types and classes (both imported and local)
					-- 	imported Ids
97
98
					-- (Ids defined in this module start in the local envt, 
					--  though they move to the global envt during zonking)
99
100
101

	tcLEnv 	 :: NameEnv TcTyThing,	-- The local type environment: Ids and TyVars
					-- defined in this module
102

103
104
105
106
	tcTyVars :: TcRef TcTyVarSet	-- The "global tyvars"
					-- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
					-- mentioned in the types of Ids bound in tcLEnv
					-- Why mutable? see notes with tcGetGlobalTyVars
107
108
    }

109
110
111
112
113
114
115
116
117
118
119
120
\end{code}

The Global-Env/Local-Env story
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
During type checking, we keep in the GlobalEnv
	* All types and classes
	* All Ids derived from types and classes (constructors, selectors)
	* Imported Ids

At the end of type checking, we zonk the local bindings,
and as we do so we add to the GlobalEnv
	* Locally defined top-level Ids
121

122
123
124
125
Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
used thus:
	a) fed back (via the knot) to typechecking the 
	   unfoldings of interface signatures
126

127
	b) used to augment the GlobalSymbolTable
128

129
130

\begin{code}
131
132
initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
initTcEnv hst pte 
133
  = do { gtv_var <- newIORef emptyVarSet ;
134
	 return (TcEnv { tcGST    = lookup,
135
		      	 tcGEnv   = emptyNameEnv,
136
		      	 tcInsts  = emptyInstEnv,
137
		      	 tcLEnv   = emptyNameEnv,
138
139
		      	 tcTyVars = gtv_var
	 })}
140
  where
141
142
    lookup name | isLocalName name = Nothing
		| otherwise	   = lookupType hst pte name
143

144

145
146
147
tcEnvClasses env = typeEnvClasses (tcGEnv env)
tcEnvTyCons  env = typeEnvTyCons  (tcGEnv env) 
tcEnvIds     env = typeEnvIds     (tcGEnv env) 
148
tcLEnvElts   env = nameEnvElts (tcLEnv env)
149

150
getTcGEnv (TcEnv { tcGEnv = genv }) = genv
151

152
153
tcInLocalScope :: TcEnv -> Name -> Bool
tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
154
\end{code}
155

156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
\begin{code}
data TcTyThing
  = AGlobal TyThing		-- Used only in the return type of a lookup
  | ATcId   TcId		-- Ids defined in this module
  | ATyVar  TyVar 		-- Type variables
  | AThing  TcKind		-- Used temporarily, during kind checking
-- Here's an example of how the AThing guy is used
-- Suppose we are checking (forall a. T a Int):
--	1. We first bind (a -> AThink kv), where kv is a kind variable. 
--	2. Then we kind-check the (T a Int) part.
--	3. Then we zonk the kind variable.
--	4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment

\end{code}

This data type is used to help tie the knot
 when type checking type and class declarations

\begin{code}
175
data TyThingDetails = SynTyDetails Type
176
177
		    | DataTyDetails ThetaType [DataCon] [Id]
		    | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
178
		    | ForeignTyDetails	-- Nothing yet
179
\end{code}
180

181
182
183
184
185
186
187
188
%************************************************************************
%*									*
\subsection{Basic lookups}
%*									*
%************************************************************************

\begin{code}
lookup_global :: TcEnv -> Name -> Maybe TyThing
189
	-- Try the global envt and then the global symbol table
190
lookup_global env name 
191
192
  = case lookupNameEnv (tcGEnv env) name of
	Just thing -> Just thing
193
	Nothing    -> tcGST env name
194
195

lookup_local :: TcEnv -> Name -> Maybe TcTyThing
196
	-- Try the local envt and then try the global
197
lookup_local env name
198
199
  = case lookupNameEnv (tcLEnv env) name of
	Just thing -> Just thing
200
	Nothing    -> case lookup_global env name of
201
			Just thing -> Just (AGlobal thing)
202
			Nothing	   -> Nothing
203
204
\end{code}

205
206
207
208
209
210
\begin{code}
type RecTcEnv = TcEnv
-- This environment is used for getting the 'right' IdInfo 
-- on imported things and for looking up Ids in unfoldings
-- The environment doesn't have any local Ids in it

211
212
213
214
tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
tcLookupRecId_maybe env name = case lookup_global env name of
				   Just (AnId id) -> Just id
				   other	  -> Nothing
215

216
217
218
219
tcLookupRecId ::  RecTcEnv -> Name -> Id
tcLookupRecId env name = case lookup_global env name of
				Just (AnId id) -> id
				Nothing	       -> pprPanic "tcLookupRecId" (ppr name)
220
\end{code}
221

222
223
224
225
226
227
228
229
230
%************************************************************************
%*									*
\subsection{Making new Ids}
%*									*
%************************************************************************

Constructing new Ids

\begin{code}
231
232
newLocalName :: Name -> NF_TcM Name
newLocalName name	-- Make a clone
233
  = tcGetUnique		`thenNF_Tc` \ uniq ->
234
    returnNF_Tc (mkLocalName uniq (getOccName name) (getSrcLoc name))
235
236
\end{code}

237
238
239
Make a name for the dict fun for an instance decl.
It's a *local* name for the moment.  The CoreTidy pass
will globalise it.
240
241

\begin{code}
242
243
244
245
newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
newDFunName clas (ty:_) loc
  = tcGetUnique			`thenNF_Tc` \ uniq ->
    returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
246
247
248
249
  where
	-- Any string that is somewhat unique will do
    dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)

250
newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
251
252
\end{code}

253
254
\begin{code}
isLocalThing :: NamedThing a => Module -> a -> Bool
255
isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
256
\end{code}
257
258
259
260
261
262
263
264

%************************************************************************
%*									*
\subsection{The global environment}
%*									*
%************************************************************************

\begin{code}
265
266
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv things thing_inside
267
268
  = tcGetEnv				`thenNF_Tc` \ env ->
    let
269
270
271
272
273
274
275
276
277
278
	ge' = extendTypeEnvList (tcGEnv env) things
    in
    tcSetEnv (env {tcGEnv = ge'}) thing_inside


tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
tcExtendGlobalTypeEnv extra_env thing_inside
  = tcGetEnv				`thenNF_Tc` \ env ->
    let
	ge' = tcGEnv env `plusNameEnv` extra_env
279
280
281
282
283
    in
    tcSetEnv (env {tcGEnv = ge'}) thing_inside

tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids thing_inside
284
285
  = tcGetEnv				`thenNF_Tc` \ env ->
    let
286
	ge' = extendTypeEnvWithIds (tcGEnv env) ids
287
288
    in
    tcSetEnv (env {tcGEnv = ge'}) thing_inside
289
290
291
292
293
294
295
296
\end{code}


\begin{code}
tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
tcLookupGlobal_maybe name
  = tcGetEnv		`thenNF_Tc` \ env ->
    returnNF_Tc (lookup_global env name)
297
298
\end{code}

299
A variety of global lookups, when we know what we are looking for.
300
301

\begin{code}
302
tcLookupGlobal :: Name -> NF_TcM TyThing
303
tcLookupGlobal name
304
305
306
  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_thing ->
    case maybe_thing of
	Just thing -> returnNF_Tc thing
307
	other	   -> notFound "tcLookupGlobal" name
308
309
310
311
312

tcLookupGlobalId :: Name -> NF_TcM Id
tcLookupGlobalId name
  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_id ->
    case maybe_id of
313
314
	Just (AnId id) -> returnNF_Tc id
	other	       -> notFound "tcLookupGlobalId" name
315
316
317
318
	
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
  = tcLookupGlobalId con_name		`thenNF_Tc` \ con_id ->
319
    case isDataConWrapId_maybe con_id of
320
 	Just data_con -> returnTc data_con
321
	Nothing	      -> failWithTc (badCon con_id)
322
323
324
325
326
327
328


tcLookupClass :: Name -> NF_TcM Class
tcLookupClass name
  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_clas ->
    case maybe_clas of
	Just (AClass clas) -> returnNF_Tc clas
329
	other		   -> notFound "tcLookupClass" name
330
331
332
333
334
335
	
tcLookupTyCon :: Name -> NF_TcM TyCon
tcLookupTyCon name
  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_tc ->
    case maybe_tc of
	Just (ATyCon tc) -> returnNF_Tc tc
336
	other		 -> notFound "tcLookupTyCon" name
337

338
339
340
341
342
343
344
345
tcLookupId :: Name -> NF_TcM Id
tcLookupId name
  = tcLookup name	`thenNF_Tc` \ thing -> 
    case thing of
	ATcId tc_id	  -> returnNF_Tc tc_id
	AGlobal (AnId id) -> returnNF_Tc id
	other		  -> pprPanic "tcLookupId" (ppr name)

346
347
348
349
350
351
352
353
tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
tcLookupLocalIds ns
  = tcGetEnv 		`thenNF_Tc` \ env ->
    returnNF_Tc (map (lookup (tcLEnv env)) ns)
  where
    lookup lenv name = case lookupNameEnv lenv name of
			Just (ATcId id) -> id
			other		-> pprPanic "tcLookupLocalIds" (ppr name)
354
\end{code}
355
356


357
358
%************************************************************************
%*									*
359
\subsection{The local environment}
360
361
%*									*
%************************************************************************
362

363
364
365
366
367
368
369
370
371
372
373
\begin{code}
tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
tcLookup_maybe name
  = tcGetEnv 		`thenNF_Tc` \ env ->
    returnNF_Tc (lookup_local env name)

tcLookup :: Name -> NF_TcM TcTyThing
tcLookup name
  = tcLookup_maybe name		`thenNF_Tc` \ maybe_thing ->
    case maybe_thing of
	Just thing -> returnNF_Tc thing
374
	other	   -> notFound "tcLookup" name
375
376
377
378
	-- Extract the IdInfo from an IfaceSig imported from an interface file
\end{code}


379
\begin{code}
380
381
382
tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
tcExtendKindEnv pairs thing_inside
  = tcGetEnv				`thenNF_Tc` \ env ->
383
    let
384
 	le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
385
386
	-- No need to extend global tyvars for kind checking
    in
387
    tcSetEnv (env {tcLEnv = le'}) thing_inside
388
    
389
390
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tyvars thing_inside
391
  = tcGetEnv			`thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
392
    let
393
394
 	le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
	new_tv_set = mkVarSet tyvars
395
    in
396
397
398
399
400
401
402
	-- It's important to add the in-scope tyvars to the global tyvar set
	-- as well.  Consider
	--	f (x::r) = let g y = y::r in ...
	-- Here, g mustn't be generalised.  This is also important during
	-- class and instance decls, when we mustn't generalise the class tyvars
	-- when typechecking the methods.
    tc_extend_gtvs gtvs new_tv_set		`thenNF_Tc` \ gtvs' ->
403
    tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
404
405
406
407
408
409
410

-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
--	the signature tyvars contain the original names
--	the instance  tyvars are what those names should be mapped to
-- It's needed when typechecking the method bindings of class and instance decls
-- It does *not* extend the global tyvars; tcMethodBind does that for itself

411
tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
412
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
413
  = tcGetEnv					`thenNF_Tc` \ env ->
414
    let
415
416
417
418
	le'   = extendNameEnvList (tcLEnv env) stuff
	stuff = [ (getName sig_tv, ATyVar inst_tv)
		| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
		]
419
    in
420
421
    tcSetEnv (env {tcLEnv = le'}) thing_inside
\end{code}
422
423


424
425
426
427
\begin{code}
tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendLocalValEnv names_w_ids thing_inside
  = tcGetEnv		`thenNF_Tc` \ env ->
428
    let
429
430
431
	extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
	extra_env	    = [(name, ATcId id) | (name,id) <- names_w_ids]
	le'		    = extendNameEnvList (tcLEnv env) extra_env
432
    in
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
    tc_extend_gtvs (tcTyVars env) extra_global_tyvars	`thenNF_Tc` \ gtvs' ->
    tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
\end{code}


%************************************************************************
%*									*
\subsection{The global tyvars}
%*									*
%************************************************************************

\begin{code}
tcExtendGlobalTyVars extra_global_tvs thing_inside
  = tcGetEnv						`thenNF_Tc` \ env ->
    tc_extend_gtvs (tcTyVars env) extra_global_tvs	`thenNF_Tc` \ gtvs' ->
448
    tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
449
450
451
452

tc_extend_gtvs gtvs extra_global_tvs
  = tcReadMutVar gtvs			`thenNF_Tc` \ global_tvs ->
    tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
453
454
455
456
457
458
459
\end{code}

@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
To improve subsequent calls to the same function it writes the zonked set back into
the environment.

\begin{code}
460
tcGetGlobalTyVars :: NF_TcM TcTyVarSet
461
tcGetGlobalTyVars
462
  = tcGetEnv 					`thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
463
464
465
466
    tcReadMutVar gtv_var			`thenNF_Tc` \ gbl_tvs ->
    zonkTcTyVarsAndFV (varSetElems gbl_tvs)	`thenNF_Tc` \ gbl_tvs' ->
    tcWriteMutVar gtv_var gbl_tvs'		`thenNF_Tc_` 
    returnNF_Tc gbl_tvs'
467
468
\end{code}

469

470
471
472
473
474
475
476
%************************************************************************
%*									*
\subsection{The instance environment}
%*									*
%************************************************************************

\begin{code}
477
tcGetInstEnv :: NF_TcM InstEnv
478
tcGetInstEnv = tcGetEnv 	`thenNF_Tc` \ env -> 
479
	       returnNF_Tc (tcInsts env)
480

481
482
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
tcSetInstEnv ie thing_inside
483
  = tcGetEnv 	`thenNF_Tc` \ env ->
484
    tcSetEnv (env {tcInsts = ie}) thing_inside
485
486
487
\end{code}    


488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
%************************************************************************
%*									*
\subsection{The InstInfo type}
%*									*
%************************************************************************

The InstInfo type summarises the information in an instance declaration

    instance c => k (t tvs) where b

\begin{code}
data InstInfo
  = InstInfo {
      iDFunId :: DFunId,		-- The dfun id
      iBinds  :: RenamedMonoBinds,	-- Bindings, b
      iPrags  :: [RenamedSig]		-- User pragmas recorded for generating specialised instances
    }

pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
			 nest 4 (ppr (iBinds info))]

simpleInstInfoTy :: InstInfo -> Type
510
simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
511
			  (_, _, _, [ty]) -> ty
512
513
514
515

simpleInstInfoTyCon :: InstInfo -> TyCon
  -- Gets the type constructor for a simple instance declaration,
  -- i.e. one of the form 	instance (...) => C (T a b c) where ...
516
simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
517
518
519
\end{code}


520
521
522
523
524
%************************************************************************
%*									*
\subsection{Errors}
%*									*
%************************************************************************
525

526
\begin{code}
527
badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
528

529
notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> 
530
				  ptext SLIT("is not in scope"))
531
\end{code}