RnEnv.lhs 35.6 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 {-# SOURCE #-} RnHiFiles

13
import HsSyn
14
import RdrHsSyn		( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
15
import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
16
17
			  mkRdrUnqual, mkRdrQual, 
			  lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
18
			  unqualifyRdrName
19
			)
20
import HsTypes		( hsTyVarName, replaceTyVarName )
21
import HscTypes		( Provenance(..), pprNameProvenance, hasBetterProv,
22
23
			  ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
			  AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), 
24
			  ModIface(..),
25
26
			  Deprecations(..), lookupDeprec,
			  extendLocalRdrEnv
27
			)
28
import RnMonad
29
import Name		( Name, 
30
			  getSrcLoc, nameIsLocalOrFrom,
31
			  mkLocalName, mkGlobalName, nameModule,
32
			  mkIPName, nameOccName, nameModule_maybe,
33
			  setNameModuleAndLoc
34
			)
35
import NameEnv
36
import NameSet
37
import OccName		( OccName, occNameUserString, occNameFlavour )
38
import Module		( ModuleName, moduleName, mkVanillaModule, 
39
			  mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
40
import PrelNames	( mkUnboundName, 
41
42
			  derivingOccurrences,
			  mAIN_Name, pREL_MAIN_Name, 
43
			  ioTyConName, intTyConName, 
44
			  boolTyConName, funTyConName,
45
			  unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
46
			  eqStringName, printName, 
47
			  bindIOName, returnIOName, failIOName
48
			)
49
import TysWiredIn	( unitTyCon )	-- A little odd
50
51
import FiniteMap
import UniqSupply
52
import SrcLoc		( SrcLoc, noSrcLoc )
53
import Outputable
54
import ListSetOps	( removeDups, equivClasses )
55
import Util		( sortLt )
56
import BasicTypes	( mapIPName )
57
import List		( nub )
58
import UniqFM		( lookupWithDefaultUFM )
59
import Maybe		( mapMaybe )
60
import CmdLineOpts
61
import FastString	( FastString )
62
63
64
65
66
67
68
69
70
\end{code}

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

\begin{code}
71
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
72
73
74
75
76
77
78
	-- newTopBinder puts into the cache the binder with the
	-- module information set correctly.  When the decl is later renamed,
	-- the binding site will thereby get the correct module.
	-- There maybe occurrences that don't have the correct Module, but
	-- by the typechecker will propagate the binding definition to all 
	-- the occurrences, so that doesn't matter

79
newTopBinder mod rdr_name loc
80
  = 	-- First check the cache
81

82
83
    	-- There should never be a qualified name in a binding position (except in instance decls)
	-- The parser doesn't check this because the same parser parses instance decls
84
    (if isQual rdr_name then
85
	qualNameErr (text "In its declaration") (rdr_name,loc)
86
87
88
89
     else
	returnRn ()
    )				`thenRn_`

90
    getNameSupplyRn		`thenRn` \ name_supply -> 
91
    let 
92
	occ = rdrNameOcc rdr_name
93
	key = (moduleName mod, occ)
94
	cache = nsNames name_supply
95
96
97
    in
    case lookupFM cache key of

98
99
100
101
102
103
	-- A hit in the cache!  We are at the binding site of the name, and
	-- this is the moment when we know all about 
	--	a) the Name's host Module (in particular, which
	-- 	   package it comes from)
	--	b) its defining SrcLoc
	-- So we update this info
104
105

	Just name -> let 
106
			new_name  = setNameModuleAndLoc name mod loc
107
108
			new_cache = addToFM cache key new_name
		     in
109
		     setNameSupplyRn (name_supply {nsNames = new_cache})	`thenRn_`
110
--		     traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
111
112
113
114
		     returnRn new_name
		     
	-- Miss in the cache!
	-- Build a completely new Name, and put it in the cache
115
116
	-- Even for locally-defined names we use implicitImportProvenance; 
	-- updateProvenances will set it to rights
117
	Nothing -> let
118
			(us', us1) = splitUniqSupply (nsUniqs name_supply)
119
			uniq   	   = uniqFromSupply us1
120
			new_name   = mkGlobalName uniq mod occ loc
121
122
			new_cache  = addToFM cache key new_name
		   in
123
		   setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})	`thenRn_`
124
--		   traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
125
126
127
		   returnRn new_name


128
newGlobalName :: ModuleName -> OccName -> RnM d Name
129
130
  -- Used for *occurrences*.  We make a place-holder Name, really just
  -- to agree on its unique, which gets overwritten when we read in
131
132
  -- the binding occurence later (newTopBinder)
  -- The place-holder Name doesn't have the right SrcLoc, and its
133
134
135
136
  -- Module won't have the right Package either.
  --
  -- (We have to pass a ModuleName, not a Module, because we may be
  -- simply looking at an occurrence M.x in an interface file.)
137
138
139
140
141
142
143
144
145
  --
  -- This means that a renamed program may have incorrect info
  -- on implicitly-imported occurrences, but the correct info on the 
  -- *binding* declaration. It's the type checker that propagates the 
  -- correct information to all the occurrences.
  -- Since implicitly-imported names never occur in error messages,
  -- it doesn't matter that we get the correct info in place till later,
  -- (but since it affects DLL-ery it does matter that we get it right
  --  in the end).
146
newGlobalName mod_name occ
147
  = getNameSupplyRn		`thenRn` \ name_supply ->
148
149
    let
	key = (mod_name, occ)
150
	cache = nsNames name_supply
151
152
    in
    case lookupFM cache key of
153
	Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
154
		     returnRn name
155

156
	Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})  `thenRn_`
157
		     -- traceRn (text "newGlobalName: new" <+> ppr name)		  `thenRn_`
158
159
		     returnRn name
		  where
160
		     (us', us1) = splitUniqSupply (nsUniqs name_supply)
161
		     uniq   	= uniqFromSupply us1
162
		     mod        = mkVanillaModule mod_name
163
		     name       = mkGlobalName uniq mod occ noSrcLoc
164
		     new_cache  = addToFM cache key name
165

166
newIPName rdr_name_ip
167
168
  = getNameSupplyRn		`thenRn` \ name_supply ->
    let
169
	ipcache = nsIPs name_supply
170
    in
171
    case lookupFM ipcache key of
172
173
174
	Just name_ip -> returnRn name_ip
	Nothing      -> setNameSupplyRn new_ns 	`thenRn_`
		        returnRn name_ip
175
		  where
176
		     (us', us1)  = splitUniqSupply (nsUniqs name_supply)
177
		     uniq   	 = uniqFromSupply us1
178
179
180
181
182
183
		     name_ip	 = mapIPName mk_name rdr_name_ip
		     mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name)
		     new_ipcache = addToFM ipcache key name_ip
		     new_ns	 = name_supply {nsUniqs = us', nsIPs = new_ipcache}
    where 
	key = rdr_name_ip	-- Ensures that ?x and %x get distinct Names
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
\end{code}

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

Looking up a name in the RnEnv.

\begin{code}
lookupBndrRn rdr_name
  = getLocalNameEnv		`thenRn` \ local_env ->
    case lookupRdrEnv local_env rdr_name of 
	  Just name -> returnRn name
	  Nothing   -> lookupTopBndrRn rdr_name

lookupTopBndrRn rdr_name
202
203
204
205
206
-- Look up a top-level local binder.   We may be looking up an unqualified 'f',
-- and there may be several imported 'f's too, which must not confuse us.
-- So we have to filter out the non-local ones.
-- A separate function (importsFromLocalDecls) reports duplicate top level
-- decls, so here it's safe just to choose an arbitrary one.
207
208
209
210
211
212
213
214
215

  | isOrig rdr_name
	-- This is here just to catch the PrelBase defn of (say) [] and similar
	-- The parser reads the special syntax and returns an Orig RdrName
	-- But the global_env contains only Qual RdrNames, so we won't
	-- find it there; instead just get the name via the Orig route
  = lookupOrigName rdr_name

  | otherwise
216
  = getModeRn	`thenRn` \ mode ->
217
218
    if isInterfaceMode mode
	then lookupIfaceName rdr_name	
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    else 
    getModuleRn		`thenRn` \ mod ->
    getGlobalNameEnv	`thenRn` \ global_env ->
    case lookup_local mod global_env rdr_name of
	Just name -> returnRn name
	Nothing	  -> failWithRn (mkUnboundName rdr_name)
		  	        (unknownNameErr rdr_name)
  where
    lookup_local mod global_env rdr_name
      = case lookupRdrEnv global_env rdr_name of
	  Nothing   -> Nothing
	  Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of
			 []     -> Nothing
			 (n:ns) -> Just n
233
	      
234
235
236
237
238
239
240
241
242
243
244
245
246
247

-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
--   module A
--	import M( f )
--	f :: Int -> Int
--	f x = x
-- It's clear that the 'f' in the signature must refer to A.f
-- The Haskell98 report does not stipulate this, but it will!
-- So we must treat the 'f' in the signature in the same way
-- as the binding occurrence of 'f', using lookupBndrRn
lookupSigOccRn :: RdrName -> RnMS Name
lookupSigOccRn = lookupBndrRn

248
249
250
251
252
253
254
255
256
257
258
259
260
261
-- lookupInstDeclBndr is used for the binders in an 
-- instance declaration.   Here we use the class name to
-- disambiguate.  

lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
	-- We use the selector name as the binder
lookupInstDeclBndr cls_name rdr_name
  | isOrig rdr_name	-- Occurs in derived instances, where we just
			-- refer diectly to the right method
  = lookupOrigName rdr_name

  | otherwise	
  = getGlobalAvails	`thenRn` \ avail_env ->
    case lookupNameEnv avail_env cls_name of
262
263
264
265
	  -- The class itself isn't in scope, so cls_name is unboundName
	  -- e.g.   import Prelude hiding( Ord )
	  --	    instance Ord T where ...
	  -- The program is wrong, but that should not cause a crash.
sof's avatar
sof committed
266
	Nothing -> returnRn (mkUnboundName rdr_name)
267
268
269
270
271
272
273
274
	Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
				(n:ns)-> ASSERT( null ns ) returnRn n
				[]    -> failWithRn (mkUnboundName rdr_name)
						    (unknownNameErr rdr_name)
	other		    -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
  where
    occ = rdrNameOcc rdr_name

275
276
277
278
279
280
281
282
283
284
285
286
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnMS Name
lookupOccRn rdr_name
  = getLocalNameEnv			`thenRn` \ local_env ->
    case lookupRdrEnv local_env rdr_name of
	  Just name -> returnRn name
	  Nothing   -> lookupGlobalOccRn rdr_name

-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global 
-- environment.  It's used only for
--	record field names
--	class op names in class and instance decls
287

288
lookupGlobalOccRn rdr_name
289
  = getModeRn 		`thenRn` \ mode ->
290
291
292
293
294
    if (isInterfaceMode mode)
	then lookupIfaceName rdr_name
	else 

    getGlobalNameEnv	`thenRn` \ global_env ->
295
    case mode of 
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
	SourceMode -> lookupSrcName global_env rdr_name

	CmdLineMode
	 | not (isQual rdr_name) -> 
		lookupSrcName global_env rdr_name

		-- We allow qualified names on the command line to refer to 
		-- *any* name exported by any module in scope, just as if 
		-- there was an "import qualified M" declaration for every 
		-- module.
		--
		-- First look up the name in the normal environment.  If
		-- it isn't there, we manufacture a new occurrence of an
		-- original name.
	 | otherwise -> 
		case lookupRdrEnv global_env rdr_name of
		       Just _  -> lookupSrcName global_env rdr_name
313
		       Nothing -> lookupQualifiedName rdr_name
314

315
316
317
318
319
320
321
322
-- a qualified name on the command line can refer to any module at all: we
-- try to load the interface if we don't already have it.
lookupQualifiedName :: RdrName -> RnM d Name
lookupQualifiedName rdr_name
 = let 
       mod = rdrNameModule rdr_name
       occ = rdrNameOcc rdr_name
   in
323
   loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface ->
324
325
326
327
328
329
   case  [ name | (_,avails) <- mi_exports iface,
    	   avail	     <- avails,
    	   name 	     <- availNames avail,
    	   nameOccName name == occ ] of
      (n:ns) -> ASSERT (null ns) returnRn n
      _      -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name)
330
331
332
333

lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
lookupSrcName global_env rdr_name
334
  | isOrig rdr_name	-- Can occur in source code too
335
  = lookupOrigName rdr_name
336

337
  | otherwise
338
  = case lookupRdrEnv global_env rdr_name of
339
340
341
342
343
344
345
	Just [GRE name _ Nothing]	-> returnRn name
	Just [GRE name _ (Just deprec)] -> warnDeprec name deprec	`thenRn_`
					   returnRn name
	Just stuff@(GRE name _ _ : _)	-> addNameClashErrRn rdr_name stuff	`thenRn_`
			       		   returnRn name
	Nothing				-> failWithRn (mkUnboundName rdr_name)
				   		      (unknownNameErr rdr_name)
346

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
lookupOrigName :: RdrName -> RnM d Name 
lookupOrigName rdr_name
  = ASSERT( isOrig rdr_name )
    newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)

lookupIfaceUnqual :: RdrName -> RnM d Name
lookupIfaceUnqual rdr_name
  = ASSERT( isUnqual rdr_name )
  	-- An Unqual is allowed; interface files contain 
	-- unqualified names for locally-defined things, such as
	-- constructors of a data type.
    getModuleRn 			`thenRn ` \ mod ->
    newGlobalName (moduleName mod) (rdrNameOcc rdr_name)

lookupIfaceName :: RdrName -> RnM d Name
lookupIfaceName rdr_name
  | isUnqual rdr_name = lookupIfaceUnqual rdr_name
  | otherwise	      = lookupOrigName rdr_name
365
366
367
368
369
370
371
372
373
374
375
376
377
\end{code}

@lookupOrigName@ 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 @lookupOrigNames@ isn't used much in
interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
calls it at all I think).
378

379
380
381
382
383
384
385
  \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}

\begin{code}
lookupOrigNames :: [RdrName] -> RnM d NameSet
lookupOrigNames rdr_names
  = mapRn lookupOrigName rdr_names	`thenRn` \ names ->
    returnRn (mkNameSet names)
386
\end{code}
387

388
389
390
391
lookupSysBinder is used for the "system binders" of a type, class, or
instance decl.  It ensures that the module is set correctly in the
name cache, and sets the provenance on the returned name too.  The
returned name will end up actually in the type, class, or instance.
392

393
\begin{code}
394
395
lookupSysBinder rdr_name
  = ASSERT( isUnqual rdr_name )
396
397
398
    getModuleRn				`thenRn` \ mod ->
    getSrcLocRn				`thenRn` \ loc ->
    newTopBinder mod rdr_name loc
399
\end{code}
400

401

402
403
404
405
406
407
%*********************************************************
%*							*
\subsection{Implicit free vars and sugar names}
%*							*
%*********************************************************

408
@getXImplicitFVs@ forces the renamer to slurp in some things which aren't
409
410
411
mentioned explicitly, but which might be needed by the type checker.

\begin{code}
412
413
414
getImplicitStmtFVs 	-- Compiling a statement
  = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName]
	      `plusFV` ubiquitousNames)
415
416
		-- These are all needed implicitly when compiling a statement
		-- See TcModule.tc_stmts
417

418
419
420
421
getImplicitModuleFVs mod_name decls	-- Compiling a module
  = lookupOrigNames deriv_occs		`thenRn` \ deriving_names ->
    returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames)
  where
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
	-- Add occurrences for IO or PrimIO
	implicit_main |  mod_name == mAIN_Name
		      || mod_name == pREL_MAIN_Name = unitFV ioTyConName
		      |  otherwise 		    = emptyFVs

	deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
		   	    cls <- deriv_classes,
			    occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]

-- ubiquitous_names are loaded regardless, because 
-- they are needed in virtually every program
ubiquitousNames 
  = mkFVs [unpackCStringName, unpackCStringFoldrName, 
	   unpackCStringUtf8Name, eqStringName]
	-- Virtually every program has error messages in it somewhere

  `plusFV`
439
440
441
    mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName]
	-- Add occurrences for very frequently used types.
	--  	 (e.g. we don't want to be bothered with making funTyCon a
442
	--	  free var at every function application!)
443
444
\end{code}

445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
%************************************************************************
%*									*
\subsection{Re-bindable desugaring names}
%*									*
%************************************************************************

Haskell 98 says that when you say "3" you get the "fromInteger" from the
Standard Prelude, regardless of what is in scope.   However, to experiment
with having a language that is less coupled to the standard prelude, we're
trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"
happens to be in scope.  Then you can
	import Prelude ()
	import MyPrelude as Prelude
to get the desired effect.

At the moment this just happens for
  * fromInteger, fromRational on literals (in expressions and patterns)
  * negate (in expressions)
  * minus  (arising from n+k patterns)

We store the relevant Name in the HsSyn tree, in 
  * HsIntegral/HsFractional	
  * NegApp
  * NPlusKPatIn
respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.
472

473
474
475
476
\begin{code}
lookupSyntaxName :: Name 	-- The standard name
	         -> RnMS Name	-- Possibly a non-standard name
lookupSyntaxName std_name
477
478
  = doptRn Opt_NoImplicitPrelude	`thenRn` \ no_prelude -> 
    if not no_prelude then
479
	returnRn std_name	-- Normal case
480
481
    else
    let
482
483
	rdr_name = mkRdrUnqual (nameOccName std_name)
	-- Get the similarly named thing from the local environment
484
    in
485
    lookupOccRn rdr_name
486
487
488
\end{code}


489
490
491
492
493
494
%*********************************************************
%*							*
\subsection{Binding}
%*							*
%*********************************************************

495
\begin{code}
496
newLocalsRn :: [(RdrName,SrcLoc)]
497
	    -> RnMS [Name]
498
newLocalsRn rdr_names_w_loc
499
 =  getNameSupplyRn		`thenRn` \ name_supply ->
500
    let
501
	(us', us1) = splitUniqSupply (nsUniqs name_supply)
502
	uniqs	   = uniqsFromSupply us1
503
	names	   = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
504
505
506
		     | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
		     ]
    in
507
    setNameSupplyRn (name_supply {nsUniqs = us'})	`thenRn_`
508
509
510
    returnRn names


511
bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
512
	   	    -> [(RdrName,SrcLoc)]
513
514
	    	    -> ([Name] -> RnMS a)
	    	    -> RnMS a
515
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
516
  = getModeRn 				`thenRn` \ mode ->
517
518
    getLocalNameEnv			`thenRn` \ local_env ->
    getGlobalNameEnv			`thenRn` \ global_env ->
519

520
521
522
523
	-- Check for duplicate names
    checkDupOrQualNames doc_str rdr_names_w_loc	`thenRn_`

    	-- Warn about shadowing, but only in source modules
524
525
    let
      check_shadow (rdr_name,loc)
526
527
	|  rdr_name `elemRdrEnv` local_env 
 	|| rdr_name `elemRdrEnv` global_env 
528
529
530
531
532
	= pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name)
        | otherwise 
	= returnRn ()
    in

533
    (case mode of
534
	SourceMode -> ifOptRn Opt_WarnNameShadowing	$
535
		      mapRn_ check_shadow rdr_names_w_loc
536
	other	   -> returnRn ()
537
    )					`thenRn_`
538

539
    newLocalsRn rdr_names_w_loc		`thenRn` \ names ->
540
    let
541
	new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names)
542
    in
543
    setLocalNameEnv new_local_env (enclosed_scope names)
544

545
bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
546
547
548
549
550
551
  -- 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
552
bindCoreLocalRn rdr_name enclosed_scope
553
554
  = getSrcLocRn 		`thenRn` \ loc ->
    getLocalNameEnv		`thenRn` \ name_env ->
555
    getNameSupplyRn		`thenRn` \ name_supply ->
556
    let
557
	(us', us1) = splitUniqSupply (nsUniqs name_supply)
558
	uniq	   = uniqFromSupply us1
559
	name	   = mkLocalName uniq (rdrNameOcc rdr_name) loc
560
    in
561
    setNameSupplyRn (name_supply {nsUniqs = us'})	`thenRn_`
562
563
564
    let
	new_name_env = extendRdrEnv name_env rdr_name name
    in
565
    setLocalNameEnv new_name_env (enclosed_scope name)
566

567
568
569
570
bindCoreLocalsRn []     thing_inside = thing_inside []
bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b	$ \ name' ->
				       bindCoreLocalsRn bs	$ \ names' ->
				       thing_inside (name':names')
571

572
bindLocalNames names enclosed_scope
573
  = getLocalNameEnv 		`thenRn` \ name_env ->
574
    setLocalNameEnv (extendLocalRdrEnv name_env names)
575
576
		    enclosed_scope

577
578
579
580
581
582
bindLocalNamesFV names enclosed_scope
  = bindLocalNames names $
    enclosed_scope `thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)


583
-------------------------------------
584
585
586
587
588
589
590
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
591
  = getSrcLocRn		`thenRn` \ loc ->
592
    bindLocatedLocalsRn doc
sof's avatar
sof committed
593
594
			(rdr_names `zip` repeat loc)
		 	enclosed_scope
595

596
597
	-- binLocalsFVRn is the same as bindLocalsRn
	-- except that it deals with free vars
598
599
bindLocalsFVRn doc rdr_names enclosed_scope
  = bindLocalsRn doc rdr_names		$ \ names ->
600
601
602
603
    enclosed_scope names		`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)

-------------------------------------
604
extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
605
	-- This tiresome function is used only in rnSourceDecl on InstDecl
606
extendTyVarEnvFVRn tyvars enclosed_scope
607
608
  = bindLocalNames tyvars enclosed_scope 	`thenRn` \ (thing, fvs) -> 
    returnRn (thing, delListFromNameSet fvs tyvars)
609

610
611
bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
	      -> ([HsTyVarBndr Name] -> RnMS a)
612
	      -> RnMS a
613
614
615
bindTyVarsRn doc_str tyvar_names enclosed_scope
  = getSrcLocRn					`thenRn` \ loc ->
    let
616
	located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] 
617
618
    in
    bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
619
    enclosed_scope (zipWith replaceTyVarName tyvar_names names)
620

621
bindPatSigTyVars :: [RdrNameHsType]
622
		 -> RnMS (a, FreeVars)
623
624
625
626
627
628
629
	  	 -> RnMS (a, FreeVars)
  -- Find the type variables in the pattern type 
  -- signatures that must be brought into scope

bindPatSigTyVars tys enclosed_scope
  = getLocalNameEnv			`thenRn` \ name_env ->
    getSrcLocRn				`thenRn` \ loc ->
630
    let
631
632
633
634
635
636
637
638
639
640
	forall_tyvars  = nub [ tv | ty <- tys,
				    tv <- extractHsTyRdrTyVars ty, 
				    not (tv `elemFM` name_env)
			 ]
		-- The 'nub' is important.  For example:
		--	f (x :: t) (y :: t) = ....
		-- We don't want to complain about binding t twice!

	located_tyvars = [(tv, loc) | tv <- forall_tyvars] 
	doc_sig        = text "In a pattern type-signature"
641
    in
642
    bindLocatedLocalsRn doc_sig located_tyvars	$ \ names ->
643
    enclosed_scope 				`thenRn` \ (thing, fvs) ->
644
645
    returnRn (thing, delListFromNameSet fvs names)

646
647

-------------------------------------
648
checkDupOrQualNames, checkDupNames :: SDoc
sof's avatar
sof committed
649
				   -> [(RdrName, SrcLoc)]
650
				   -> RnM d ()
651
	-- Works in any variant of the renamer monad
sof's avatar
sof committed
652
653
654

checkDupOrQualNames doc_str rdr_names_w_loc
  =	-- Check for use of qualified names
sof's avatar
sof committed
655
    mapRn_ (qualNameErr doc_str) quals 	`thenRn_`
sof's avatar
sof committed
656
657
    checkDupNames doc_str rdr_names_w_loc
  where
658
    quals = filter (isQual . fst) rdr_names_w_loc
sof's avatar
sof committed
659
660
    
checkDupNames doc_str rdr_names_w_loc
sof's avatar
sof committed
661
662
  = 	-- Check for duplicated names in a binding group
    mapRn_ (dupNamesErr doc_str) dups
sof's avatar
sof committed
663
  where
664
    (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
665
666
667
668
669
\end{code}


%************************************************************************
%*									*
670
\subsection{GlobalRdrEnv}
671
672
673
%*									*
%************************************************************************

674
675
676
677
\begin{code}
mkGlobalRdrEnv :: ModuleName		-- Imported module (after doing the "as M" name change)
	       -> Bool			-- True <=> want unqualified import
	       -> (Name -> Provenance)
678
	       -> Avails		-- Whats imported
679
	       -> Deprecations
680
681
	       -> GlobalRdrEnv

682
683
mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs
  = gbl_env2
684
685
686
687
688
689
  where
 	-- Make the name environment.  We're talking about a 
	-- single module here, so there must be no name clashes.
	-- In practice there only ever will be if it's the module
	-- being compiled.

690
691
	-- Add qualified names for the things that are available
	-- (Qualified names are always imported)
692
693
    gbl_env1 = foldl add_avail emptyRdrEnv avails

694
	-- Add unqualified names
695
696
    gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1)
	     | otherwise  = gbl_env1
697
698
699
700
701
702
703
704
705
706
707

    add_unqual env (qual_name, elts)
	= foldl add_one env elts
	where
	  add_one env elt = addOneToGlobalRdrEnv env unqual_name elt
	  unqual_name     = unqualifyRdrName qual_name
	-- The qualified import should only have added one 
	-- binding for each qualified name!  But if there's an error in
	-- the module (multiple bindings for the same name) we may get
	-- duplicates.  So the simple thing is to do the fold.

708
709
710
    add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
    add_avail env avail = foldl add_name env (availNames avail)

711
712
    add_name env name 	-- Add qualified name only
	= addOneToGlobalRdrEnv env  (mkRdrQual this_mod occ) elt
713
714
	where
	  occ  = nameOccName name
715
	  elt  = GRE name (mk_provenance name) (lookupDeprec deprecs name)
716
717
718
719
720
721
722
723
724

mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
-- Used to construct a GlobalRdrEnv for an interface that we've
-- read from a .hi file.  We can't construct the original top-level
-- environment because we don't have enough info, but we compromise
-- by making an environment from its exports
mkIfaceGlobalRdrEnv m_avails
  = foldl add emptyRdrEnv m_avails
  where
725
    add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True 
726
								(\n -> LocalDef) avails NoDeprecs)
727
		-- The NoDeprecs is a bit of a hack I suppose
728
729
\end{code}

730
\begin{code}
731
732
733
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2

734
addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv
735
736
737
738
739
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

740
741
742
combine_globals :: [GlobalRdrElt] 	-- Old
		-> [GlobalRdrElt]	-- New
		-> [GlobalRdrElt]
743
744
745
combine_globals ns_old ns_new	-- ns_new is often short
  = foldr add ns_old ns_new
  where
746
    add n ns | any (is_duplicate n) ns_old = map (choose n) ns	-- Eliminate duplicates
747
	     | otherwise	           = n:ns
748

749
750
751
    choose n m | n `beats` m = n
	       | otherwise   = m

752
    (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm
753

754
755
756
    is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool
    is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False
    is_duplicate (GRE n1 _        _) (GRE n2 _	      _) = n1 == n2
757
\end{code}
758

759
760
761
762
763
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
764
import statements, we {\em do} want to eliminate the duplicate, not report
765
766
767
768
769
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.
770
771


772
773
774
775
776
777
778
@unQualInScope@ returns a function that takes a @Name@ and tells whether
its unqualified name is in scope.  This is put as a boolean flag in
the @Name@'s provenance to guide whether or not to print the name qualified
in error messages.

\begin{code}
unQualInScope :: GlobalRdrEnv -> Name -> Bool
779
780
-- True if 'f' is in scope, and has only one binding,
-- and the thing it is bound to is the name we are looking for
781
-- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
782
783
784
--
-- This fn is only efficient if the shared 
-- partial application is used a lot.
785
unQualInScope env
786
  = (`elemNameSet` unqual_names)
787
  where
788
789
    unqual_names :: NameSet
    unqual_names = foldRdrEnv add emptyNameSet env
790
791
    add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name
    add _        _              unquals		 	    = unquals
792
793
\end{code}

794

795
796
797
798
799
%************************************************************************
%*									*
\subsection{Avails}
%*									*
%************************************************************************
800

801
\begin{code}
802
plusAvail (Avail n1)	   (Avail n2)	    = Avail n1
803
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
sof's avatar
sof committed
804
805
-- Added SOF 4/97
#ifdef DEBUG
806
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
sof's avatar
sof committed
807
#endif
808

809
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
810
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
811
812
813
814
815
816
817
818
819

unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a

plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
plusAvailEnv = plusNameEnv_C plusAvail

availEnvElts = nameEnvElts

820
addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
821
addAvailToNameSet names avail = addListToNameSet names (availNames avail)
822
823
824
825

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

826
availName :: GenAvailInfo name -> name
827
828
829
availName (Avail n)     = n
availName (AvailTC n _) = n

830
availNames :: GenAvailInfo name -> [name]
831
832
833
availNames (Avail n)      = [n]
availNames (AvailTC n ns) = ns

834
-------------------------------------
835
836
filterAvail :: RdrNameIE	-- Wanted
	    -> AvailInfo	-- Available
837
838
	    -> Maybe AvailInfo	-- Resulting available; 
				-- Nothing if (any of the) wanted stuff isn't there
839
840

filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
841
842
  | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
  | otherwise    = Nothing
843
844
845
846
  where
    is_wanted name = nameOccName name `elem` wanted_occs
    sub_names_ok   = all (`elem` avail_occs) wanted_occs
    avail_occs	   = map nameOccName ns
847
848
    wanted_occs    = map rdrNameOcc (want:wants)

849
filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns ) 
850
851
852
						  Just (AvailTC n [n])

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

854
855
filterAvail (IEVar _)      avail@(Avail n)      = Just avail
filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
856
857
858
859
860
861
862
						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

863
864
865
866
filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
	-- We don't complain even if the IE says T(..), but
	-- no constrs/class ops of T are available
	-- Instead that's caught with a warning by the caller
867

868
filterAvail ie avail = Nothing
869

870
-------------------------------------
871
groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
872
873
  -- Group by module and sort by occurrence
  -- This keeps the list in canonical order
874
groupAvails this_mod avails 
875
876
877
  = [ (mkSysModuleNameFS fs, sortLt lt avails)
    | (fs,avails) <- fmToList groupFM
    ]
878
  where
879
    groupFM :: FiniteMap FastString Avails
880
	-- Deliberately use the FastString so we
881
882
883
	-- get a canonical ordering
    groupFM = foldl add emptyFM avails

884
    add env avail = addToFM_C combine env mod_fs [avail']
885
		  where
886
887
888
889
		    mod_fs = moduleNameFS (moduleName avail_mod)
		    avail_mod = case nameModule_maybe (availName avail) of
					  Just m  -> m
					  Nothing -> this_mod
890
891
		    combine old _ = avail':old
		    avail'	  = sortAvail avail
892
893

    a1 `lt` a2 = occ1 < occ2
894
	       where
895
896
		 occ1  = nameOccName (availName a1)
		 occ2  = nameOccName (availName a2)
sof's avatar
sof committed
897

898
899
900
901
902
903
904
905
906
sortAvail :: AvailInfo -> AvailInfo
-- Sort the sub-names into canonical order.
-- The canonical order has the "main name" at the beginning 
-- (if it's there at all)
sortAvail (Avail n) = Avail n
sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
			 | otherwise   = AvailTC n (    sortLt lt ns)
			 where
			   n1 `lt` n2 = nameOccName n1 < nameOccName n2
907
908
\end{code}

909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
\begin{code}
pruneAvails :: (Name -> Bool)	-- Keep if this is True
	    -> [AvailInfo]
	    -> [AvailInfo]
pruneAvails keep avails
  = mapMaybe del avails
  where
    del :: AvailInfo -> Maybe AvailInfo	-- Nothing => nothing left!
    del (Avail n) | keep n    = Just (Avail n)
    	          | otherwise = Nothing
    del (AvailTC n ns) | null ns'  = Nothing
		       | otherwise = Just (AvailTC n ns')
		       where
		         ns' = filter keep ns
\end{code}
924
925
926

%************************************************************************
%*									*
927
\subsection{Free variable manipulation}
928
929
930
931
%*									*
%************************************************************************

\begin{code}
932
933
934
935
936
937
-- A useful utility
mapFvRn f xs = mapRn f xs	`thenRn` \ stuff ->
	       let
		  (ys, fvs_s) = unzip stuff
	       in
	       returnRn (ys, plusFVs fvs_s)
938
939
940
941
942
943
944
945
946
947
\end{code}


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

\begin{code}
948
warnUnusedModules :: [ModuleName] -> RnM d ()
949
warnUnusedModules mods
950
  = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods)
951
  where
952
    unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> 
953
954
			   text "is imported, but nothing from it is used",
			 parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
955
				   quotes (ppr m))]
956

957
warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
958
warnUnusedImports names
959
  = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names)
960

961
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
962
warnUnusedLocalBinds names
963
  = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names])
964
965

warnUnusedMatches names
966
  = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names])
967

968
-------------------------
969

970
971
972
warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
warnUnusedBinds names
  = mapRn_ warnUnusedGroup  groups
973
  where
974
975
	-- Group by provenance
   groups = equivClasses cmp names
976
   (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
977
978
979
980
 

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

981
982
983
984
warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
warnUnusedGroup names
  | null filtered_names  = returnRn ()
  | not is_local	 = returnRn ()
985
  | otherwise
986
987
  = pushSrcLocRn def_loc	$
    addWarnRn			$
988
    sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
989
  where
990
    filtered_names = filter reportable names
991
    (name1, prov1) = head filtered_names
992
    (is_local, def_loc, msg)
993
	= case prov1 of
994
		LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
995

996
		NonLocalDef (UserImport mod loc _)
997
998
999
1000
1001
			-> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")

    reportable (name,_) = case occNameUserString (nameOccName name) of
				('_' : _) -> False
				zz_other  -> True
1002
1003
	-- Haskell 98 encourages compilers to suppress warnings about
	-- unused names in a pattern if they start with "_".
1004
\end{code}
1005

1006
\begin{code}
1007
addNameClashErrRn rdr_name (np1:nps)
1008
  = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
1009
		    ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
1010
  where
1011
1012
    msg1 = ptext  SLIT("either") <+> mk_ref np1
    msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
1013
    mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
1014

1015
shadowedNameWarn shadow
sof's avatar
sof committed
1016
  = hsep [ptext SLIT("This binding for"), 
1017
	       quotes (ppr shadow),
sof's avatar
sof committed
1018
	       ptext SLIT("shadows an existing binding")]
1019

1020
1021
unknownNameErr name
  = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
1022
1023
1024
1025
1026
  where
    flavour = occNameFlavour (rdrNameOcc name)

qualNameErr descriptor (name,loc)
  = pushSrcLocRn loc $
1027
    addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),
1028
		     descriptor])
1029
1030
1031

dupNamesErr descriptor ((name,loc) : dup_things)
  = pushSrcLocRn loc $
1032
1033
    addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
	      $$ 
1034
	      descriptor)
1035
1036
1037

warnDeprec :: Name -> DeprecTxt -> RnM d ()
warnDeprec name txt
1038
  = ifOptRn Opt_WarnDeprecations	$
1039
1040
1041
    addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> 
		     quotes (ppr name) <+> text "is deprecated:", 
		     nest 4 (ppr txt) ])
1042
\end{code}
1043