RnEnv.lhs 26.5 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
7
8
%
\section[RnEnv]{Environment manipulation for the renamer monad}

\begin{code}
module RnEnv where		-- Export everything

9
#include "HsVersions.h"
10

11
12
import CmdLineOpts	( opt_WarnNameShadowing, opt_WarnUnusedMatches,
			  opt_WarnUnusedBinds, opt_WarnUnusedImports )
13
import HsSyn
14
import RdrHsSyn		( RdrNameIE )
15
16
17
18
import RnHsSyn		( RenamedHsType )
import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
			  mkRdrUnqual, qualifyRdrName
			)
19
import HsTypes		( getTyVarName, replaceTyVarName )
20

21
import RnMonad
22
23
import Name		( Name, Provenance(..), ExportFlag(..), NamedThing(..),
			  ImportReason(..), getSrcLoc, 
24
			  mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
25
			  nameOccName, setNameModule, nameModule,
26
			  pprOccName, isLocallyDefined, nameUnique, nameOccName,
27
                          occNameUserString,
28
			  setNameProvenance, getNameProvenance, pprNameProvenance
29
			)
30
import NameSet
31
32
import OccName		( OccName,
			  mkDFunOcc, 
sof's avatar
sof committed
33
			  occNameFlavour
34
			)
35
36
37
import TysWiredIn	( tupleTyCon, unboxedTupleTyCon, listTyCon )
import Type		( funTyCon )
import Module		( ModuleName, mkThisModule, mkVanillaModule, moduleName )
38
39
import TyCon		( TyCon )
import FiniteMap
40
import Unique		( Unique, Uniquable(..) )
41
import UniqFM           ( emptyUFM, listToUFM, plusUFM_C )
42
43
import UniqSupply
import SrcLoc		( SrcLoc, noSrcLoc )
44
import Outputable
45
import Util		( removeDups, equivClasses, thenCmp )
46
import List		( nub )
47
import Maybes		( mapMaybe )
48
49
50
51
52
53
54
55
56
57
58
\end{code}



%*********************************************************
%*							*
\subsection{Making new names}
%*							*
%*********************************************************

\begin{code}
59
newImportedGlobalName mod_name occ mod
60
61
62
63
64
65
66
67
68
69
70
  = getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
    let
	key = (mod_name, occ)
    in
    case lookupFM cache key of
	Just name -> returnRn name
	Nothing   -> setNameSupplyRn (us', inst_ns, new_cache)		`thenRn_`
		     returnRn name
		  where
		     (us', us1) = splitUniqSupply us
		     uniq   	= uniqFromSupply us1
71
		     name       = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False)
72
		     new_cache  = addToFM cache key name
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

updateProvenances :: [Name] -> RnM d ()
updateProvenances names
  = getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
    setNameSupplyRn (us, inst_ns, update cache names)
  where
    update cache [] 	      = cache
    update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
				update (addToFM cache key name) names
 			      where
				key = (moduleName (nameModule name), nameOccName name)

newImportedBinder :: Module -> RdrName -> RnM d Name
newImportedBinder mod rdr_name
  = ASSERT2( isUnqual rdr_name, ppr rdr_name )
    newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod

-- Make an imported global name, checking first to see if it's in the cache
mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
mkImportedGlobalName mod_name occ
  = newImportedGlobalName mod_name occ (mkVanillaModule mod_name)
94
95
	
mkImportedGlobalFromRdrName rdr_name
96
  | isQual rdr_name
97
  = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
98

99
  | otherwise
100
101
102
  =	-- An Unqual is allowed; interface files contain 
	-- unqualified names for locally-defined things, such as
	-- constructors of a data type.
103
104
    getModuleRn 			`thenRn ` \ mod_name ->
    mkImportedGlobalName mod_name (rdrNameOcc rdr_name)
105

106

107
108
109
110
newLocalTopBinder :: Module -> OccName 
	       -> (Name -> ExportFlag) -> SrcLoc
	       -> RnM d Name
newLocalTopBinder mod occ rec_exp_fn loc
111
112
  = 	-- First check the cache
    getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
113
    let 
114
	key          = (moduleName mod,occ)
115
116
117
118
119
120
121
	mk_prov name = LocalDef loc (rec_exp_fn name)
	-- We must set the provenance of the thing in the cache
	-- correctly, particularly whether or not it is locally defined.
	--
	-- Since newLocallyDefinedGlobalName is used only
	-- at binding occurrences, we may as well get the provenance
	-- dead right first time; hence the rec_exp_fn passed in
122
    in
123
124
125
126
127
128
    case lookupFM cache key of

	-- A hit in the cache!
	-- Overwrite whatever provenance is in the cache already; 
	-- this updates WiredIn things and known-key things, 
	-- which are there from the start, to LocalDef.
129
130
131
	--
	-- It also means that if there are two defns for the same thing
	-- in a module, then each gets a separate SrcLoc
132
	Just name -> let 
133
			new_name = setNameProvenance name (mk_prov new_name)
134
135
136
137
138
139
140
141
142
			new_cache = addToFM cache key new_name
		     in
		     setNameSupplyRn (us, inst_ns, new_cache)		`thenRn_`
		     returnRn new_name
		     
	-- Miss in the cache!
	-- Build a new original name, and put it in the cache
	Nothing -> let
			(us', us1) = splitUniqSupply us
143
			uniq   	   = uniqFromSupply us1
144
			new_name   = mkGlobalName uniq mod occ (mk_prov new_name)
145
146
147
148
			new_cache  = addToFM cache key new_name
		   in
		   setNameSupplyRn (us', inst_ns, new_cache)		`thenRn_`
		   returnRn new_name
149
\end{code}
150

151
152
%*********************************************************
%*							*
153
\subsection{Dfuns and default methods}
154
155
%*							*
%*********************************************************
156

157
158
@newImplicitBinder@ is used for (a) dfuns
(b) default methods, defined in this module.
159

160
161
\begin{code}
newImplicitBinder occ src_loc
162
  = getModuleRn				`thenRn` \ mod_name ->
163
164
    newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc
\end{code}
165

166
Make a name for the dict fun for an instance decl
167

168
169
170
171
172
173
\begin{code}
newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
newDFunName key@(cl_occ, tycon_occ) loc
  = newInstUniq key	`thenRn` \ inst_uniq ->
    newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc
\end{code}
174

175
176
177
178
179
180
181
182
183
184
185
186
\begin{code}
getDFunKey :: RenamedHsType -> (OccName, OccName)	-- Used to manufacture DFun names
getDFunKey (HsForAllTy _ _ ty)     = getDFunKey ty
getDFunKey (MonoFunTy _ ty)        = getDFunKey ty
getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)

get_tycon_key (MonoTyVar tv)   = nameOccName (getName tv)
get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
get_tycon_key (MonoTupleTy tys True)  = getOccName (tupleTyCon        (length tys))
get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
get_tycon_key (MonoListTy _)   = getOccName listTyCon
get_tycon_key (MonoFunTy _ _)  = getOccName funTyCon
187
188
\end{code}

189
190
191
192
193
194
195

%*********************************************************
%*							*
\subsection{Binding}
%*							*
%*********************************************************

196
\begin{code}
197
-------------------------------------
198
bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
199
	   	    -> [(RdrName,SrcLoc)]
200
201
	    	    -> ([Name] -> RnMS a)
	    	    -> RnMS a
202
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
sof's avatar
sof committed
203
  = checkDupOrQualNames doc_str rdr_names_w_loc	`thenRn_`
204

205
    getLocalNameEnv			`thenRn` \ name_env ->
206
207
    (if opt_WarnNameShadowing
     then
sof's avatar
sof committed
208
	mapRn_ (check_shadow name_env) rdr_names_w_loc
209
     else
sof's avatar
sof committed
210
	returnRn ()
211
212
    )					`thenRn_`
	
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
    getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
    getModeRn 			`thenRn` \ mode ->
    let
	n	   = length rdr_names_w_loc
	(us', us1) = splitUniqSupply us
	uniqs	   = uniqsFromSupply n us1
	names	   = [ mk_name uniq (rdrNameOcc rdr_name) loc
		     | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
		     ]
	mk_name    = case mode of
			SourceMode    -> mkLocalName 
			InterfaceMode -> mkImportedLocalName 
		     -- Keep track of whether the name originally came from 
		     -- an interface file.
    in
    setNameSupplyRn (us', inst_ns, cache)	`thenRn_`

230
    let
231
	new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
232
    in
233
    setLocalNameEnv new_name_env (enclosed_scope names)
234

235
236
  where
    check_shadow name_env (rdr_name,loc)
237
	= case lookupRdrEnv name_env rdr_name of
238
239
240
241
		Nothing   -> returnRn ()
		Just name -> pushSrcLocRn loc $
			     addWarnRn (shadowedNameWarn rdr_name)

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
	  	  -> RnMS (a, FreeVars)
  -- A specialised variant when renaming stuff from interface
  -- files (of which there is a lot)
  --	* one at a time
  --	* no checks for shadowing
  -- 	* always imported
  -- 	* deal with free vars
bindCoreLocalFVRn rdr_name enclosed_scope
  = getSrcLocRn 		`thenRn` \ loc ->
    getLocalNameEnv		`thenRn` \ name_env ->
    getNameSupplyRn		`thenRn` \ (us, inst_ns, cache) ->
    let
	(us', us1) = splitUniqSupply us
	uniq	   = uniqFromSupply us1
	name	   = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
    in
    setNameSupplyRn (us', inst_ns, cache)	`thenRn_`
    let
	new_name_env = extendRdrEnv name_env rdr_name name
    in
263
    setLocalNameEnv new_name_env (enclosed_scope name)	`thenRn` \ (result, fvs) ->
264
265
266
267
268
269
    returnRn (result, delFromNameSet fvs name)

bindCoreLocalsFVRn []     thing_inside = thing_inside []
bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b	$ \ name' ->
					 bindCoreLocalsFVRn bs	$ \ names' ->
					 thing_inside (name':names')
270
271

-------------------------------------
272
273
274
275
276
277
278
bindLocalRn doc rdr_name enclosed_scope
  = getSrcLocRn 				`thenRn` \ loc ->
    bindLocatedLocalsRn doc [(rdr_name,loc)]	$ \ (n:ns) ->
    ASSERT( null ns )
    enclosed_scope n

bindLocalsRn doc rdr_names enclosed_scope
279
  = getSrcLocRn		`thenRn` \ loc ->
280
    bindLocatedLocalsRn doc
sof's avatar
sof committed
281
282
			(rdr_names `zip` repeat loc)
		 	enclosed_scope
283

284
285
	-- binLocalsFVRn is the same as bindLocalsRn
	-- except that it deals with free vars
286
287
bindLocalsFVRn doc rdr_names enclosed_scope
  = bindLocalsRn doc rdr_names		$ \ names ->
288
289
290
291
    enclosed_scope names		`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)

-------------------------------------
292
extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
293
	-- This tiresome function is used only in rnDecl on InstDecl
294
extendTyVarEnvFVRn tyvars enclosed_scope
295
296
  = getLocalNameEnv		`thenRn` \ env ->
    let
297
298
299
	tyvar_names = map getTyVarName tyvars
	new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name) 
				      | name <- tyvar_names
300
301
				      ]
    in
302
303
    setLocalNameEnv new_env enclosed_scope	`thenRn` \ (thing, fvs) -> 
    returnRn (thing, delListFromNameSet fvs tyvar_names)
304
305

bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
306
307
	      -> ([HsTyVar Name] -> RnMS a)
	      -> RnMS a
308
bindTyVarsRn doc_str tyvar_names enclosed_scope
309
310
311
312
313
  = bindTyVars2Rn doc_str tyvar_names 	$ \ names tyvars ->
    enclosed_scope tyvars

-- Gruesome name: return Names as well as HsTyVars
bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
314
315
	      -> ([Name] -> [HsTyVar Name] -> RnMS a)
	      -> RnMS a
316
bindTyVars2Rn doc_str tyvar_names enclosed_scope
317
318
319
320
321
  = getSrcLocRn					`thenRn` \ loc ->
    let
	located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] 
    in
    bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
322
323
324
    enclosed_scope names (zipWith replaceTyVarName tyvar_names names)

bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
325
326
	      -> ([HsTyVar Name] -> RnMS (a, FreeVars))
	      -> RnMS (a, FreeVars)
327
328
329
330
331
332
bindTyVarsFVRn doc_str rdr_names enclosed_scope
  = bindTyVars2Rn doc_str rdr_names	$ \ names tyvars ->
    enclosed_scope tyvars		`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)

bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
333
334
	      -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars))
	      -> RnMS (a, FreeVars)
335
336
337
338
339
340
341
bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
  = bindTyVars2Rn doc_str rdr_names	$ \ names tyvars ->
    enclosed_scope names tyvars		`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)


-------------------------------------
342
checkDupOrQualNames, checkDupNames :: SDoc
sof's avatar
sof committed
343
				   -> [(RdrName, SrcLoc)]
344
				   -> RnM d ()
345
	-- Works in any variant of the renamer monad
sof's avatar
sof committed
346
347
348

checkDupOrQualNames doc_str rdr_names_w_loc
  =	-- Check for use of qualified names
sof's avatar
sof committed
349
    mapRn_ (qualNameErr doc_str) quals 	`thenRn_`
sof's avatar
sof committed
350
351
352
353
354
    checkDupNames doc_str rdr_names_w_loc
  where
    quals = filter (isQual.fst) rdr_names_w_loc
    
checkDupNames doc_str rdr_names_w_loc
sof's avatar
sof committed
355
356
  = 	-- Check for duplicated names in a binding group
    mapRn_ (dupNamesErr doc_str) dups
sof's avatar
sof committed
357
  where
358
    (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
359
360
361
362
363
364
365
366
367
368
369
370
\end{code}


%*********************************************************
%*							*
\subsection{Looking up names}
%*							*
%*********************************************************

Looking up a name in the RnEnv.

\begin{code}
371
372
373
374
375
376
377
lookupBndrRn rdr_name
  = getNameEnvs		`thenRn` \ (global_env, local_env) ->

	-- Try local env
    case lookupRdrEnv local_env rdr_name of {
	  Just name -> returnRn name ;
	  Nothing   ->
378
379
380

    getModeRn	`thenRn` \ mode ->
    case mode of 
381
382
	InterfaceMode -> 	-- Look in the global name cache
			    mkImportedGlobalFromRdrName rdr_name
383

384
385
386
387
388
389
390
391
392
	SourceMode    -> -- Source mode, so look up a *qualified* version
			 -- of the name, so that we get the right one even
			 -- if there are many with the same occ name
			 -- There must *be* a binding
		getModuleRn		`thenRn` \ mod ->
		case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
		  Just (name:rest) -> ASSERT( null rest )
				      returnRn name 
		  Nothing	   -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
393
    }
394

395
396
397
398
-- Just like lookupRn except that we record the occurrence too
-- Perhaps surprisingly, even wired-in names are recorded.
-- Why?  So that we know which wired-in names are referred to when
-- deciding which instance declarations to import.
399
lookupOccRn :: RdrName -> RnMS Name
400
lookupOccRn rdr_name
401
  = getNameEnvs				`thenRn` \ (global_env, local_env) ->
402
    lookup_occ global_env local_env rdr_name
403
404

-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global 
405
406
407
-- environment.  It's used only for
--	record field names
--	class op names in class and instance decls
408
lookupGlobalOccRn :: RdrName -> RnMS Name
409
lookupGlobalOccRn rdr_name
410
  = getNameEnvs				`thenRn` \ (global_env, local_env) ->
411
    lookup_global_occ global_env rdr_name
412

413
414
415
416
417
-- Look in both local and global env
lookup_occ global_env local_env rdr_name
  = case lookupRdrEnv local_env rdr_name of
	  Just name -> returnRn name
	  Nothing   -> lookup_global_occ global_env rdr_name
418

419
420
421
422
423
424
425
426
427
-- Look in global env only
lookup_global_occ global_env rdr_name
  = case lookupRdrEnv global_env rdr_name of
	Just [name]	    -> returnRn name
	Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff	`thenRn_`
			       returnRn name
	Nothing -> getModeRn	`thenRn` \ mode ->
		   case mode of 
			-- Not found when processing source code; so fail
428
429
			SourceMode    -> failWithRn (mkUnboundName rdr_name)
						    (unknownNameErr rdr_name)
430
431
432
		
			-- Not found when processing an imported declaration,
			-- so we create a new name for the purpose
433
			InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
\end{code}
%
@lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
and adds it to the occurrence pool so that it'll be loaded later.
This is used when language constructs
(such as monad comprehensions, overloaded literals, or deriving clauses)
require some stuff to be loaded that isn't explicitly mentioned in the code.

This doesn't apply in interface mode, where everything is explicit,
but we don't check for this case:
it does no harm to record an ``extra'' occurrence
and @lookupImplicitOccRn@ isn't used much in interface mode
(it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).

  \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
449

450
451
452
453
For List and Tuple types it's important to get the correct
@isLocallyDefined@ flag, which is used in turn when deciding
whether there are any instance decls in this module are ``special''.
The name cache should have the correct provenance, though.
454

455
\begin{code}
456
457
lookupImplicitOccRn :: RdrName -> RnMS Name 
lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
458
459
\end{code}

460
@unQualInScope@ returns a function that takes a @Name@ and tells whether
461
its unqualified name is in scope.  This is put as a boolean flag in
462
the @Name@'s provenance to guide whether or not to print the name qualified
463
in error messages.
464

465
\begin{code}
466
467
unQualInScope :: GlobalRdrEnv -> Name -> Bool
unQualInScope env
468
469
  = lookup
  where
470
    lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
471
			   Just [name'] -> name == name'
472
			   other        -> False
473
\end{code}
474
475
476
477
478
479
480

%************************************************************************
%*									*
\subsection{Envt utility functions}
%*									*
%************************************************************************

481
482
\subsubsection{NameEnv}%  ================

483
\begin{code}
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2

addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]

delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv 
delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name

combine_globals :: [Name] 	-- Old
		-> [Name]	-- New
		-> [Name]
combine_globals ns_old ns_new	-- ns_new is often short
  = foldr add ns_old ns_new
  where
499
500
    add n ns | any (is_duplicate n) ns_old = map choose ns	-- Eliminate duplicates
	     | otherwise	           = n:ns
501
502
503
504
	     where
	       choose n' | n==n' && better_provenance n n' = n
			 | otherwise			   = n'

505
506
507
508
-- Choose 
--	a local thing		      over an	imported thing
--	a user-imported thing	      over a	non-user-imported thing
-- 	an explicitly-imported thing  over an	implicitly imported thing
509
510
better_provenance n1 n2
  = case (getNameProvenance n1, getNameProvenance n2) of
511
512
513
514
	(LocalDef _ _,			      _				  ) -> True
	(NonLocalDef (UserImport _ _ True) _, _				  ) -> True
	(NonLocalDef (UserImport _ _ _   ) _, NonLocalDef ImplicitImport _) -> True
	other								    -> False
515

516
517
518
is_duplicate :: Name -> Name -> Bool
is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
		   | otherwise 		                        = n1 == n2
519
\end{code}
520
521
522
523
524
525
526
527
528
529
530
We treat two bindings of a locally-defined name as a duplicate,
because they might be two separate, local defns and we want to report
and error for that, {\em not} eliminate a duplicate.

On the other hand, if you import the same name from two different
import statements, we {\em d}* want to eliminate the duplicate, not report
an error.

If a module imports itself then there might be a local defn and an imported
defn of the same name; in this case the names will compare as equal, but
will still have different provenances.
531
532
533



534
535
\subsubsection{ExportAvails}%  ================

536
\begin{code}
537
mkEmptyExportAvails :: ModuleName -> ExportAvails
538
539
mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)

540
mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
541
mkExportAvails mod_name unqual_imp name_env avails
542
543
  = (mod_avail_env, entity_avail_env)
  where
544
545
546
547
548
549
550
551
552
    mod_avail_env = unitFM mod_name unqual_avails 

	-- unqual_avails is the Avails that are visible in *unqualfied* form
	-- (1.4 Report, Section 5.1.1)
	-- For example, in 
	--	import T hiding( f )
	-- we delete f from avails

    unqual_avails | not unqual_imp = []	-- Short cut when no unqualified imports
553
		  | otherwise      = mapMaybe prune avails
554

555
556
557
558
559
560
    prune (Avail n) | unqual_in_scope n = Just (Avail n)
    prune (Avail n) | otherwise		= Nothing
    prune (AvailTC n ns) | null uqs     = Nothing
			 | otherwise    = Just (AvailTC n uqs)
			 where
			   uqs = filter unqual_in_scope ns
561

562
    unqual_in_scope n = unQualInScope name_env n
563

564
    entity_avail_env = listToUFM [ (name,avail) | avail <- avails, 
565
			  	   		  name  <- availNames avail]
566

567
568
569
plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
plusExportAvails (m1, e1) (m2, e2)
  = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
570
	-- ToDo: wasteful: we do this once for each constructor!
571
572
573
\end{code}


574
575
\subsubsection{AvailInfo}%  ================

576
\begin{code}
577
578
plusAvail (Avail n1)	   (Avail n2)	    = Avail n1
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
sof's avatar
sof committed
579
580
-- Added SOF 4/97
#ifdef DEBUG
581
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
sof's avatar
sof committed
582
#endif
583
584

addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
585
addAvailToNameSet names avail = addListToNameSet names (availNames avail)
586
587
588
589

availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails

590
591
592
593
availName :: AvailInfo -> Name
availName (Avail n)     = n
availName (AvailTC n _) = n

594
availNames :: AvailInfo -> [Name]
595
596
597
598
599
availNames (Avail n)      = [n]
availNames (AvailTC n ns) = ns

filterAvail :: RdrNameIE	-- Wanted
	    -> AvailInfo	-- Available
600
601
	    -> Maybe AvailInfo	-- Resulting available; 
				-- Nothing if (any of the) wanted stuff isn't there
602
603

filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
604
605
  | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
  | otherwise    = Nothing
606
607
608
609
  where
    is_wanted name = nameOccName name `elem` wanted_occs
    sub_names_ok   = all (`elem` avail_occs) wanted_occs
    avail_occs	   = map nameOccName ns
610
611
    wanted_occs    = map rdrNameOcc (want:wants)

612
filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns ) 
613
614
615
						  Just (AvailTC n [n])

filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail		-- Type synonyms
616

617
618
filterAvail (IEVar _)      avail@(Avail n)      = Just avail
filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
619
620
621
622
623
624
625
						where
						  wanted n = nameOccName n == occ
						  occ      = rdrNameOcc v
	-- The second equation happens if we import a class op, thus
	-- 	import A( op ) 
	-- where op is a class operation

626
filterAvail (IEThingAll _) avail@(AvailTC _ _)  = Just avail
627

628
filterAvail ie avail = Nothing
629

sof's avatar
sof committed
630
631

-- In interfaces, pprAvail gets given the OccName of the "host" thing
632
633
634
635
636
pprAvail avail = getPprStyle $ \ sty ->
	         if ifaceStyle sty then
		    ppr_avail (pprOccName . nameOccName) avail
		 else
		    ppr_avail ppr avail
sof's avatar
sof committed
637
638
639
640
641
642
643

ppr_avail pp_name (AvailTC n ns) = hsep [
				     pp_name n,
				     parens  $ hsep $ punctuate comma $
				     map pp_name ns
				   ]
ppr_avail pp_name (Avail n) = pp_name n
644
645
646
647
648
649
650
\end{code}




%************************************************************************
%*									*
651
\subsection{Free variable manipulation}
652
653
654
655
%*									*
%************************************************************************

\begin{code}
656
657
658
659
660
661
662
663
type FreeVars	= NameSet

plusFV   :: FreeVars -> FreeVars -> FreeVars
addOneFV :: FreeVars -> Name -> FreeVars
unitFV   :: Name -> FreeVars
emptyFVs :: FreeVars
plusFVs  :: [FreeVars] -> FreeVars

664
665
666
667
isEmptyFVs = isEmptyNameSet
emptyFVs   = emptyNameSet
plusFVs    = unionManyNameSets
plusFV     = unionNameSets
668
669
670
671

-- No point in adding implicitly imported names to the free-var set
addOneFV s n = addOneToNameSet s n
unitFV     n = unitNameSet n
672
673
674
675
676
677
678

-- A useful utility
mapFvRn f xs = mapRn f xs	`thenRn` \ stuff ->
	       let
		  (ys, fvs_s) = unzip stuff
	       in
	       returnRn (ys, plusFVs fvs_s)
679
680
681
682
683
684
685
686
687
688
689
\end{code}


%************************************************************************
%*									*
\subsection{Envt utility functions}
%*									*
%************************************************************************


\begin{code}
690
warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d ()
691

692
warnUnusedTopNames names
693
694
695
696
  | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
  = returnRn () 	-- Don't force ns unless necessary
  | otherwise
  = warnUnusedBinds (\ is_local -> not is_local) names
697

698
warnUnusedLocalBinds ns
699
  | not opt_WarnUnusedBinds = returnRn ()
sof's avatar
sof committed
700
  | otherwise		    = warnUnusedBinds (\ is_local -> is_local) ns
701
702

warnUnusedMatches names
sof's avatar
sof committed
703
  | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
704
  | otherwise 		  = returnRn ()
705

706
-------------------------
707

708
warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d ()
sof's avatar
sof committed
709
warnUnusedBinds warn_when_local names
sof's avatar
sof committed
710
  = mapRn_ (warnUnusedGroup warn_when_local) groups
711
  where
712
713
714
715
716
717
718
	-- Group by provenance
   groups = equivClasses cmp names
   name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
 
   cmp_prov (LocalDef _ _) (NonLocalDef _ _)       = LT
   cmp_prov (LocalDef loc1 _) (LocalDef loc2 _)    = loc1 `compare` loc2
   cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
719
720
            (NonLocalDef (UserImport m2 loc2 _) _) =
	 (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
721
722
723
724
725
   cmp_prov (NonLocalDef _ _) (LocalDef _ _)       = GT
			-- In-scope NonLocalDefs must have UserImport info on them

-------------------------

726
warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
sof's avatar
sof committed
727
728
warnUnusedGroup emit_warning names
  | not (emit_warning is_local) = returnRn ()
729
  | otherwise
730
731
732
  = case filter isReportable names of
      []       -> returnRn ()
      repnames -> warn repnames
733
  where
734
735
736
737
738
739
740
741
  warn repnames = pushSrcLocRn def_loc	$
                  addWarnRn		$
                  sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr repnames)))]

  name1 = head names

  (is_local, def_loc, msg)
	   = case getNameProvenance name1 of
742
		LocalDef loc _ 			     -> (True, loc, text "Defined but not used")
743
744
745
		NonLocalDef (UserImport mod loc _) _ ->
		 (True, loc, text "Imported from" <+> quotes (ppr mod) <+> 
			 			      text "but not used")
746
		other -> (False, getSrcLoc name1, text "Strangely defined but not used")
747
748
749
750
751
752
753

  isReportable = not . startsWithUnderscore . occNameUserString  . nameOccName
    -- Haskell 98 encourages compilers to suppress warnings about
    -- unused names in a pattern if they start with "_".
  startsWithUnderscore ('_' : _) = True
    -- Suppress warnings for names starting with an underscore
  startsWithUnderscore other     = False
754
\end{code}
755

756
757
\begin{code}
addNameClashErrRn rdr_name (name1:names)
758
  = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
759
		    ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
760
  where
761
762
763
    msg1 = ptext  SLIT("either") <+> mk_ref name1
    msgs = [ptext SLIT("    or") <+> mk_ref name | name <- names]
    mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
764

765
766
767
768
fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
  = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
	4 (vcat [ppr how_in_scope1,
		 ppr how_in_scope2])
769

770
shadowedNameWarn shadow
sof's avatar
sof committed
771
  = hsep [ptext SLIT("This binding for"), 
772
	       quotes (ppr shadow),
sof's avatar
sof committed
773
	       ptext SLIT("shadows an existing binding")]
774

775
776
unknownNameErr name
  = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
777
778
779
780
781
  where
    flavour = occNameFlavour (rdrNameOcc name)

qualNameErr descriptor (name,loc)
  = pushSrcLocRn loc $
782
783
784
785
    addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), 
		     quotes (ppr name),
		     ptext SLIT("in"),
		     descriptor])
786
787
788

dupNamesErr descriptor ((name,loc) : dup_things)
  = pushSrcLocRn loc $
789
790
791
    addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
	      $$ 
	      (ptext SLIT("in") <+> descriptor))
792
793
\end{code}