RnEnv.lhs 26.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

import HsSyn
12
import RdrHsSyn		( RdrNameIE )
13
import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
14
			  mkRdrUnqual, qualifyRdrName, lookupRdrEnv
15
			)
16
import HsTypes		( hsTyVarName, replaceTyVarName )
17
import HscTypes		( Provenance(..), pprNameProvenance, hasBetterProv,
18
			  ImportReason(..), GlobalRdrEnv, AvailEnv,
19
			  AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo )
20
import RnMonad
21 22
import Name		( Name, NamedThing(..),
			  getSrcLoc, 
23
			  mkLocalName, mkImportedLocalName, mkGlobalName,
24
			  mkIPName, nameOccName, nameModule,
25 26
			  extendNameEnv_C, plusNameEnv_C, nameEnvElts,
			  setNameModuleAndLoc
27
			)
28
import NameSet
29
import OccName		( OccName, occNameUserString, occNameFlavour )
30
import Module		( ModuleName, moduleName, mkVanillaModule )
31
import FiniteMap
32
import Unique		( Unique )
33
import UniqSupply
34
import SrcLoc		( SrcLoc, noSrcLoc )
35
import Outputable
36
import ListSetOps	( removeDups, equivClasses )
37
import Util		( sortLt )
38
import List		( nub )
39
import PrelNames	( mkUnboundName )
40
import CmdLineOpts
41 42 43 44 45 46 47 48 49
\end{code}

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

\begin{code}
50 51
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
newTopBinder mod rdr_name loc
52
  = 	-- First check the cache
53
    traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
54

55
    getNameSupplyRn		`thenRn` \ (us, cache, ipcache) ->
56
    let 
57
	occ = rdrNameOcc rdr_name
58
	key = (moduleName mod, occ)
59 60 61
    in
    case lookupFM cache key of

62 63 64 65 66 67
	-- 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
68 69

	Just name -> let 
70
			new_name  = setNameModuleAndLoc name mod loc
71 72
			new_cache = addToFM cache key new_name
		     in
73
		     setNameSupplyRn (us, new_cache, ipcache)	`thenRn_`
74
		     traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
75 76 77 78
		     returnRn new_name
		     
	-- Miss in the cache!
	-- Build a completely new Name, and put it in the cache
79 80
	-- Even for locally-defined names we use implicitImportProvenance; 
	-- updateProvenances will set it to rights
81 82 83
	Nothing -> let
			(us', us1) = splitUniqSupply us
			uniq   	   = uniqFromSupply us1
84
			new_name   = mkGlobalName uniq mod occ loc
85 86
			new_cache  = addToFM cache key new_name
		   in
87
		   setNameSupplyRn (us', new_cache, ipcache)	`thenRn_`
88
		   traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
89 90 91
		   returnRn new_name


92
newGlobalName :: ModuleName -> OccName -> RnM d Name
93 94
  -- Used for *occurrences*.  We make a place-holder Name, really just
  -- to agree on its unique, which gets overwritten when we read in
95 96
  -- the binding occurence later (newTopBinder)
  -- The place-holder Name doesn't have the right SrcLoc, and its
97 98 99 100
  -- 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.)
101 102 103 104 105 106 107 108 109
  --
  -- 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).
110 111
newGlobalName mod_name occ
  = getNameSupplyRn		`thenRn` \ (us, cache, ipcache) ->
112 113 114 115
    let
	key = (mod_name, occ)
    in
    case lookupFM cache key of
116
	Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
117
		     returnRn name
118 119 120

	Nothing   -> setNameSupplyRn (us', new_cache, ipcache)		`thenRn_`
		     traceRn (text "newGlobalName: new" <+> ppr name)	`thenRn_`
121 122 123 124
		     returnRn name
		  where
		     (us', us1) = splitUniqSupply us
		     uniq   	= uniqFromSupply us1
125
		     mod        = mkVanillaModule mod_name
126
		     name       = mkGlobalName uniq mod occ noSrcLoc
127
		     new_cache  = addToFM cache key name
128

129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
newIPName rdr_name
  = getNameSupplyRn		`thenRn` \ (us, cache, ipcache) ->
    case lookupFM ipcache key of
	Just name -> returnRn name
	Nothing   -> setNameSupplyRn (us', cache, new_ipcache)	`thenRn_`
		     returnRn name
		  where
		     (us', us1)  = splitUniqSupply us
		     uniq   	 = uniqFromSupply us1
		     name        = mkIPName uniq key
		     new_ipcache = addToFM ipcache key name
    where key = (rdrNameOcc rdr_name)
\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
  = getModeRn	`thenRn` \ mode ->
    case mode of 
	InterfaceMode -> 	-- Look in the global name cache
			    lookupOrigName rdr_name	

	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 ->
		getGlobalNameEnv	`thenRn` \ global_env ->
		case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
171 172
		  Just ((name,_):rest) -> ASSERT( null rest )
				      	  returnRn name 
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
		  Nothing	   -> 	-- Almost always this case is a compiler bug.
					-- But consider a type signature that doesn't have 
					-- a corresponding binder: 
					--	module M where { f :: Int->Int }
					-- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
					-- and we don't want to panic.  So we report an out-of-scope error
					failWithRn (mkUnboundName rdr_name)
						   (unknownNameErr rdr_name)

-- 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

-- 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
lookupGlobalOccRn rdr_name
  = getModeRn	`thenRn` \ mode ->
    case mode of {
		-- When processing interface files, the global env 
		-- is always empty, so go straight to the name cache
	InterfaceMode -> lookupOrigName rdr_name ;

	SourceMode ->

    getGlobalNameEnv	`thenRn` \ global_env ->
    case lookupRdrEnv global_env rdr_name of
218
	Just [(name,_)]	 -> returnRn name
219 220 221
	Just stuff@((name,_):_) 
		-> addNameClashErrRn rdr_name stuff	`thenRn_`
       		   returnRn name
222 223 224 225
	Nothing -> 	-- Not found when processing source code; so fail
			failWithRn (mkUnboundName rdr_name)
				   (unknownNameErr rdr_name)
    }
226 227 228 229 230 231 232 233 234

lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
  -- Checks that there is exactly one
lookupGlobalRn global_env rdr_name
  = case lookupRdrEnv global_env rdr_name of
	Just [(name,_)]		-> returnRn (Just name)
	Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff	`thenRn_`
		       		   returnRn (Just name)
	Nothing			-> returnRn Nothing
235 236 237 238 239 240 241 242 243 244 245 246 247 248
\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).
249

250 251 252 253 254 255 256 257 258 259
  \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}

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.

\begin{code}
lookupOrigName :: RdrName -> RnM d Name 
lookupOrigName rdr_name
260
  | isQual rdr_name
261
  = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
262

263
  | otherwise
264 265 266
  =	-- An Unqual is allowed; interface files contain 
	-- unqualified names for locally-defined things, such as
	-- constructors of a data type.
267 268
    getModuleRn 			`thenRn ` \ mod ->
    newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
269

270 271 272 273
lookupOrigNames :: [RdrName] -> RnM d NameSet
lookupOrigNames rdr_names
  = mapRn lookupOrigName rdr_names	`thenRn` \ names ->
    returnRn (mkNameSet names)
274
\end{code}
275

276 277 278 279
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.
280

281
\begin{code}
282 283
lookupSysBinder rdr_name
  = ASSERT( isUnqual rdr_name )
284 285 286
    getModuleRn				`thenRn` \ mod ->
    getSrcLocRn				`thenRn` \ loc ->
    newTopBinder mod rdr_name loc
287
\end{code}
288

289

290 291 292 293 294 295 296

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

297
\begin{code}
298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314
newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
	    -> [(RdrName,SrcLoc)]
	    -> RnMS [Name]
newLocalsRn mk_name rdr_names_w_loc
 =  getNameSupplyRn		`thenRn` \ (us, cache, ipcache) ->
    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
		     ]
    in
    setNameSupplyRn (us', cache, ipcache)	`thenRn_`
    returnRn names


315
bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
316
	   	    -> [(RdrName,SrcLoc)]
317 318
	    	    -> ([Name] -> RnMS a)
	    	    -> RnMS a
319
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
320
  = getModeRn 				`thenRn` \ mode ->
321
    getLocalNameEnv			`thenRn` \ name_env ->
322

323 324 325
	-- Check for duplicate names
    checkDupOrQualNames doc_str rdr_names_w_loc	`thenRn_`

326 327
    doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->

328
    	-- Warn about shadowing, but only in source modules
329
    (case mode of
330
	SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
331
	other				   -> returnRn ()
332 333
    )					`thenRn_`
	
334 335 336 337 338 339 340
    let
	mk_name    = case mode of
			SourceMode    -> mkLocalName 
			InterfaceMode -> mkImportedLocalName 
		     -- Keep track of whether the name originally came from 
		     -- an interface file.
    in
341
    newLocalsRn mk_name rdr_names_w_loc		`thenRn` \ names ->
342
    let
343
	new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
344
    in
345
    setLocalNameEnv new_local_env (enclosed_scope names)
346

347 348
  where
    check_shadow name_env (rdr_name,loc)
349
	= case lookupRdrEnv name_env rdr_name of
350 351 352 353
		Nothing   -> returnRn ()
		Just name -> pushSrcLocRn loc $
			     addWarnRn (shadowedNameWarn rdr_name)

354 355 356 357 358 359 360 361 362 363 364
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 ->
365
    getNameSupplyRn		`thenRn` \ (us, cache, ipcache) ->
366 367 368 369 370
    let
	(us', us1) = splitUniqSupply us
	uniq	   = uniqFromSupply us1
	name	   = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
    in
371
    setNameSupplyRn (us', cache, ipcache)	`thenRn_`
372 373 374
    let
	new_name_env = extendRdrEnv name_env rdr_name name
    in
375
    setLocalNameEnv new_name_env (enclosed_scope name)	`thenRn` \ (result, fvs) ->
376 377 378 379 380 381
    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')
382

383 384 385 386 387 388 389
bindLocalNames names enclosed_scope
  = getLocalNameEnv 		`thenRn` \ name_env ->
    setLocalNameEnv (addListToRdrEnv name_env pairs)
		    enclosed_scope
  where
    pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]

390
-------------------------------------
391 392 393 394 395 396 397
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
398
  = getSrcLocRn		`thenRn` \ loc ->
399
    bindLocatedLocalsRn doc
sof's avatar
sof committed
400 401
			(rdr_names `zip` repeat loc)
		 	enclosed_scope
402

403 404
	-- binLocalsFVRn is the same as bindLocalsRn
	-- except that it deals with free vars
405 406
bindLocalsFVRn doc rdr_names enclosed_scope
  = bindLocalsRn doc rdr_names		$ \ names ->
407 408 409
    enclosed_scope names		`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)

410 411 412 413
-------------------------------------
bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
bindUVarRn = bindLocalRn

414
-------------------------------------
415
extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
416
	-- This tiresome function is used only in rnDecl on InstDecl
417
extendTyVarEnvFVRn tyvars enclosed_scope
418 419
  = bindLocalNames tyvars enclosed_scope 	`thenRn` \ (thing, fvs) -> 
    returnRn (thing, delListFromNameSet fvs tyvars)
420

421 422
bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
	      -> ([HsTyVarBndr Name] -> RnMS a)
423
	      -> RnMS a
424
bindTyVarsRn doc_str tyvar_names enclosed_scope
425 426 427 428
  = bindTyVars2Rn doc_str tyvar_names 	$ \ names tyvars ->
    enclosed_scope tyvars

-- Gruesome name: return Names as well as HsTyVars
429 430
bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
	      -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
431
	      -> RnMS a
432
bindTyVars2Rn doc_str tyvar_names enclosed_scope
433 434
  = getSrcLocRn					`thenRn` \ loc ->
    let
435
	located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] 
436 437
    in
    bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
438 439
    enclosed_scope names (zipWith replaceTyVarName tyvar_names names)

440 441
bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
	      -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
442
	      -> RnMS (a, FreeVars)
443 444 445 446 447
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)

448 449
bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
	      -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
450
	      -> RnMS (a, FreeVars)
451 452 453 454 455
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)

456 457 458 459 460 461 462 463 464 465 466 467
bindNakedTyVarsFVRn :: SDoc -> [RdrName]
	            -> ([Name] -> RnMS (a, FreeVars))
		    -> RnMS (a, FreeVars)
bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
  = getSrcLocRn					`thenRn` \ loc ->
    let
	located_tyvars = [(tv, loc) | tv <- tyvar_names] 
    in
    bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
    enclosed_scope names			`thenRn` \ (thing, fvs) ->
    returnRn (thing, delListFromNameSet fvs names)

468 469

-------------------------------------
470
checkDupOrQualNames, checkDupNames :: SDoc
sof's avatar
sof committed
471
				   -> [(RdrName, SrcLoc)]
472
				   -> RnM d ()
473
	-- Works in any variant of the renamer monad
sof's avatar
sof committed
474 475 476

checkDupOrQualNames doc_str rdr_names_w_loc
  =	-- Check for use of qualified names
sof's avatar
sof committed
477
    mapRn_ (qualNameErr doc_str) quals 	`thenRn_`
sof's avatar
sof committed
478 479 480 481 482
    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
483 484
  = 	-- Check for duplicated names in a binding group
    mapRn_ (dupNamesErr doc_str) dups
sof's avatar
sof committed
485
  where
486
    (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
487 488 489 490 491
\end{code}


%************************************************************************
%*									*
492
\subsection{GlobalRdrEnv}
493 494 495 496
%*									*
%************************************************************************

\begin{code}
497 498 499
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2

500
addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
501 502 503 504 505
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

506 507 508
combine_globals :: [(Name,Provenance)] 	-- Old
		-> [(Name,Provenance)]	-- New
		-> [(Name,Provenance)]
509 510 511
combine_globals ns_old ns_new	-- ns_new is often short
  = foldr add ns_old ns_new
  where
512
    add n ns | any (is_duplicate n) ns_old = map (choose n) ns	-- Eliminate duplicates
513
	     | otherwise	           = n:ns
514

515 516 517 518
    choose n m | n `beats` m = n
	       | otherwise   = m

    (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
519

520 521 522
    is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
    is_duplicate (n1,LocalDef) (n2,LocalDef) = False
    is_duplicate (n1,_)        (n2,_)	     = n1 == n2
523
\end{code}
524

525 526 527 528 529
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
530
import statements, we {\em do} want to eliminate the duplicate, not report
531 532 533 534 535
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.
536 537


538 539 540 541 542 543 544 545 546 547 548 549 550 551 552
@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
unQualInScope env
  = lookup
  where
    lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
			   Just [(name',_)] -> name == name'
			   other            -> False
\end{code}

553

554 555 556 557 558
%************************************************************************
%*									*
\subsection{Avails}
%*									*
%************************************************************************
559

560
\begin{code}
561
plusAvail (Avail n1)	   (Avail n2)	    = Avail n1
562
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
sof's avatar
sof committed
563 564
-- Added SOF 4/97
#ifdef DEBUG
565
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
sof's avatar
sof committed
566
#endif
567

568
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
569
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
570 571 572 573 574 575 576 577 578 579

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

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

availEnvElts = nameEnvElts

580
addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
581
addAvailToNameSet names avail = addListToNameSet names (availNames avail)
582 583 584 585

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

586
availName :: GenAvailInfo name -> name
587 588 589
availName (Avail n)     = n
availName (AvailTC n _) = n

590
availNames :: GenAvailInfo name -> [name]
591 592 593
availNames (Avail n)      = [n]
availNames (AvailTC n ns) = ns

594
-------------------------------------
595 596 597 598
addSysAvails :: AvailInfo -> [Name] -> AvailInfo
addSysAvails avail          []  = avail
addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)

599
-------------------------------------
600 601 602 603 604 605
rdrAvailInfo :: AvailInfo -> RdrAvailInfo
-- Used when building the avails we are going to put in an interface file
-- We sort the components to reduce needless wobbling of interfaces
rdrAvailInfo (Avail n)	    = Avail   (nameOccName n)
rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))

606
-------------------------------------
607 608
filterAvail :: RdrNameIE	-- Wanted
	    -> AvailInfo	-- Available
609 610
	    -> Maybe AvailInfo	-- Resulting available; 
				-- Nothing if (any of the) wanted stuff isn't there
611 612

filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
613 614
  | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
  | otherwise    = Nothing
615 616 617 618
  where
    is_wanted name = nameOccName name `elem` wanted_occs
    sub_names_ok   = all (`elem` avail_occs) wanted_occs
    avail_occs	   = map nameOccName ns
619 620
    wanted_occs    = map rdrNameOcc (want:wants)

621
filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns ) 
622 623 624
						  Just (AvailTC n [n])

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

626 627
filterAvail (IEVar _)      avail@(Avail n)      = Just avail
filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
628 629 630 631 632 633 634
						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

635 636 637 638
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
639

640
filterAvail ie avail = Nothing
641

642 643 644 645 646 647 648 649 650 651 652 653 654 655 656
-------------------------------------
sortAvails :: Avails -> Avails
sortAvails avails = sortLt lt avails
  where
    a1 `lt` a2 = mod1 < mod2 ||
	         (mod1 == mod2 && occ1 < occ2)
	       where
		 name1 = availName a1
		 name2 = availName a2
		 mod1  = nameModule name1
		 mod2  = nameModule name2
		 occ1  = nameOccName name1
		 occ2  = nameOccName name2
				
-------------------------------------
657 658 659 660
pprAvail :: AvailInfo -> SDoc
pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
					[]  -> empty
					ns' -> parens (hsep (punctuate comma (map ppr ns')))
sof's avatar
sof committed
661

662
pprAvail (Avail n) = ppr n
663 664 665 666 667
\end{code}


%************************************************************************
%*									*
668
\subsection{Free variable manipulation}
669 670 671 672
%*									*
%************************************************************************

\begin{code}
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
\end{code}


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

\begin{code}
689
warnUnusedModules :: [ModuleName] -> RnM d ()
690
warnUnusedModules mods
691
  = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
692
    if warn then mapRn_ (addWarnRn . unused_mod) mods
693
	    else returnRn ()
694
  where
695
    unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> 
696 697
			   text "is imported, but nothing from it is used",
			 parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
698
				   quotes (ppr m))]
699

700
warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
701
warnUnusedImports names
702
  = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
703
    if warn then warnUnusedBinds names else returnRn ()
704

705
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
706
warnUnusedLocalBinds names
707 708 709
  = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
    if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
	    else returnRn ()
710 711

warnUnusedMatches names
712 713 714
  = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
    if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
	    else returnRn ()
715

716
-------------------------
717

718 719 720
warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
warnUnusedBinds names
  = mapRn_ warnUnusedGroup  groups
721
  where
722 723
	-- Group by provenance
   groups = equivClasses cmp names
724
   (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
725 726 727 728
 

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

729 730 731 732
warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
warnUnusedGroup names
  | null filtered_names  = returnRn ()
  | not is_local	 = returnRn ()
733
  | otherwise
734 735
  = pushSrcLocRn def_loc	$
    addWarnRn			$
736
    sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
737
  where
738
    filtered_names = filter reportable names
739
    (name1, prov1) = head filtered_names
740
    (is_local, def_loc, msg)
741
	= case prov1 of
742
		LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
743 744 745 746 747 748 749

		NonLocalDef (UserImport mod loc _) _ 
			-> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")

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

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

763 764 765 766
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])
767

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

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

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

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