Rename.lhs 32.6 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[Rename]{Renaming and dependency analysis passes}

\begin{code}
module Rename ( renameModule ) where

#include "HsVersions.h"

import HsSyn
12 13
import HsPragmas	( DataPragmas(..) )
import RdrHsSyn		( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
14 15 16 17
import RnHsSyn		( RenamedHsModule, RenamedHsDecl, 
			  extractHsTyNames, extractHsCtxtTyNames
			)

18
import CmdLineOpts	( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
19 20
			  opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations,
			  opt_WarnUnusedBinds
21 22 23 24
		        )
import RnMonad
import RnNames		( getGlobalNames )
import RnSource		( rnSourceDecls, rnDecl )
25
import RnIfaces		( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports,
26
			  getImportedRules, getSlurped, removeContext,
27
			  loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
28
			)
29 30
import RnEnv		( availName, availsToNameSet, 
			  emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, 
31
			  warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
32
			  lookupOrigNames, unknownNameErr,
33
			  FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
34
			)
35 36 37
import Module           ( Module, ModuleName, WhereFrom(..),
			  moduleNameUserString, mkSearchPath, moduleName, mkThisModule
			)
38
import Name		( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
39
			  nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
40
			  isUserImportedExplicitlyName, isUserImportedName,
41
			  maybeWiredInTyConName, maybeWiredInIdName,
42 43
			  isUserExportedName, toRdrName,
			  nameEnvElts, extendNameEnv
44
			)
45
import OccName		( occNameFlavour, isValOcc )
46
import Id		( idType )
47
import TyCon		( isSynTyCon, getSynTyConDefn )
48 49
import NameSet
import TysWiredIn	( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
50 51
import PrelRules	( builtinRules )
import PrelInfo		( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
52
			  ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
53 54
			  fractionalClassKeys, derivingOccurrences 
			)
55
import Type		( namesOfType, funTyCon )
56
import ErrUtils		( printErrorsAndWarnings, dumpIfSet, ghcExit )
57
import BasicTypes	( Version, initialVersion )
58
import Bag		( isEmptyBag, bagToList )
59 60 61
import FiniteMap	( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, 
			  addToFM_C, elemFM, addToFM
			)
62
import UniqSupply	( UniqSupply )
63
import UniqFM		( lookupUFM )
64
import SrcLoc		( noSrcLoc )
65
import Maybes		( maybeToBool, expectJust )
66
import Outputable
67
import IO		( openFile, IOMode(..) )
68 69 70 71 72
\end{code}



\begin{code}
73 74 75 76 77 78
type RenameResult = ( Module		-- This module
		    , RenamedHsModule	-- Renamed module
		    , Maybe ParsedIface	-- The existing interface file, if any
		    , ParsedIface	-- The new interface
		    , RnNameSupply	-- Final env; for renaming derivings
		    , FixityEnv		-- The fixity environment; for derivings
rrt's avatar
rrt committed
79
		    , [Module])		-- Imported modules
80 81
		   
renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult)
82
renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
83
  = 	-- Initialise the renamer monad
84 85
    do {
	((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) 
86 87 88
	   <- initRn (mkThisModule mod_name) us 
		     (mkSearchPath opt_HiMap) loc
		     (rename this_mod) ;
89 90

	-- Check for warnings
91
	printErrorsAndWarnings rn_errs_bag rn_warns_bag ;
92

93
	-- Dump any debugging output
94
	dump_action ;
95 96

	-- Return results
97 98 99
	if not (isEmptyBag rn_errs_bag) then
	    do { ghcExit 1 ; return Nothing }
        else
100
	    return maybe_rn_stuff
101
    }
102 103 104
\end{code}

\begin{code}
105 106
rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ())
rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
107 108 109 110
  =  	-- FIND THE GLOBAL NAME ENVIRONMENT
    getGlobalNames this_mod			`thenRn` \ maybe_stuff ->

	-- CHECK FOR EARLY EXIT
111 112 113 114 115 116 117 118 119 120 121 122
    case maybe_stuff of {
	Nothing -> 	-- Everything is up to date; no need to recompile further
		rnDump [] []		`thenRn` \ dump_action ->
		returnRn (Nothing, dump_action) ;

  	Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) ->

	-- DEAL WITH DEPRECATIONS
    rnDeprecs local_gbl_env mod_deprec local_decls	`thenRn` \ my_deprecs ->

	-- DEAL WITH LOCAL FIXITIES
    fixitiesFromLocalDecls local_gbl_env local_decls	`thenRn` \ local_fixity_env ->
123 124

	-- RENAME THE SOURCE
125
    initRnMS gbl_env local_fixity_env SourceMode (
126 127 128 129
	rnSourceDecls local_decls
    )					`thenRn` \ (rn_local_decls, source_fvs) ->

	-- SLURP IN ALL THE NEEDED DECLARATIONS
130
    implicitFVs mod_name rn_local_decls 	`thenRn` \ implicit_fvs -> 
131
    let
132 133
		-- The export_fvs make the exported names look just as if they
		-- occurred in the source program.  For the reasoning, see the
134 135 136 137 138
		-- comments with RnIfaces.getImportVersions.
		-- We only need the 'parent name' of the avail;
		-- that's enough to suck in the declaration.
	export_fvs 	= mkNameSet (map availName export_avails)
	real_source_fvs = source_fvs `plusFV` export_fvs
139

140 141 142 143
	slurp_fvs	= implicit_fvs `plusFV` real_source_fvs
		-- It's important to do the "plus" this way round, so that
		-- when compiling the prelude, locally-defined (), Bool, etc
		-- override the implicit ones. 
144
    in
145 146
    loadBuiltinRules builtinRules	`thenRn_`
    slurpImpDecls slurp_fvs		`thenRn` \ rn_imp_decls ->
147 148

	-- EXIT IF ERRORS FOUND
149
    rnDump rn_imp_decls rn_local_decls		`thenRn` \ dump_action ->
150
    checkErrsRn					`thenRn` \ no_errs_so_far ->
151 152
    if not no_errs_so_far then
	-- Found errors already, so exit now
153
	returnRn (Nothing, dump_action)
154 155 156
    else

	-- GENERATE THE VERSION/USAGE INFO
157
    mkImportExportInfo mod_name export_avails exports 	`thenRn` \ (my_exports, my_usages) ->
158 159

	-- RETURN THE RENAMED MODULE
rrt's avatar
rrt committed
160 161
    getNameSupplyRn			`thenRn` \ name_supply ->
    getIfacesRn 			`thenRn` \ ifaces ->
162
    let
rrt's avatar
rrt committed
163
	direct_import_mods :: [Module]
164 165 166 167 168 169 170 171
	direct_import_mods = [m | (_, _, Just (m, _, _, _, imp, _))
				  <- eltsFM (iImpModInfo ifaces), user_import imp]

		-- *don't* just pick the forward edges.  It's entirely possible
		-- that a module is only reachable via back edges.
	user_import ImportByUser = True
	user_import ImportByUserSource = True
	user_import _ = False
rrt's avatar
rrt committed
172

173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
	this_module	   = mkThisModule mod_name

	-- Export only those fixities that are for names that are
	--	(a) defined in this module
	--	(b) exported
	exported_fixities
	  = [ FixitySig (toRdrName name) fixity loc
	    | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
	      isUserExportedName name
	    ]

	new_iface = ParsedIface { pi_mod     = this_module
				, pi_vers    = initialVersion
				, pi_orphan  = any isOrphanDecl rn_local_decls
				, pi_exports = my_exports
				, pi_usages  = my_usages
				, pi_fixity  = (initialVersion, exported_fixities)
				, pi_deprecs = my_deprecs
				  	-- These ones get filled in later
				, pi_insts = [], pi_decls = []
				, pi_rules = (initialVersion, [])
			}
	
196 197
	renamed_module = HsModule mod_name vers 
				  trashed_exports trashed_imports
198
				  (rn_local_decls ++ rn_imp_decls)
199
			          mod_deprec
200
			          loc
201 202 203 204 205

	result = (this_module,   renamed_module, 
		  old_iface,   new_iface,
		  name_supply, local_fixity_env,
		  direct_import_mods)
206
    in
207

208 209 210
	-- REPORT UNUSED NAMES, AND DEBUG DUMP 
    reportUnusedNames mod_name direct_import_mods
		      gbl_env global_avail_env
211 212
		      export_avails source_fvs
		      rn_imp_decls			`thenRn_`
213 214

    returnRn (Just result, dump_action) }
215 216 217 218 219 220 221 222 223
  where
    trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
    trashed_imports  = {-trace "rnSource:trashed_imports"-} []
\end{code}

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

\begin{code}
224
implicitFVs mod_name decls
225
  = lookupOrigNames implicit_occs			`thenRn` \ implicit_names ->
226 227
    returnRn (mkNameSet (map getName default_tycons)	`plusFV`
	      implicit_names)
228
  where
229
 	-- Add occurrences for Int, and (), because they
230 231 232 233 234 235
	-- are the types to which ambigious type variables may be defaulted by
	-- the type checker; so they won't always appear explicitly.
	-- [The () one is a GHC extension for defaulting CCall results.]
	-- ALSO: funTyCon, since it occurs implicitly everywhere!
	--  	 (we don't want to be bothered with making funTyCon a
	--	  free var at every function application!)
236 237
	-- Double is dealt with separately in getGates
    default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
238 239 240

	-- Add occurrences for IO or PrimIO
    implicit_main |  mod_name == mAIN_Name
241 242
		  || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
		  |  otherwise 		        = []
243 244 245 246

	-- Now add extra "occurrences" for things that
	-- the deriving mechanism, or defaulting, will later need in order to
	-- generate code
247 248 249
    implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls

	-- Virtually every program has error messages in it somewhere
250
    string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR]
251

252
    get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _))
253 254 255 256 257 258
       = concat (map get_deriv deriv_classes)
    get other = []

    get_deriv cls = case lookupUFM derivingOccurrences cls of
			Nothing   -> []
			Just occs -> occs
259 260 261 262
\end{code}

\begin{code}
isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
263 264 265 266 267 268
  = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
	-- The 'removeContext' is because of
	--	instance Foo a => Baz T where ...
	-- The decl is an orphan if Baz and T are both not locally defined,
	--	even if Foo *is* locally defined

269
isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
270 271
  = check lhs
  where
272 273 274 275 276 277 278 279 280 281 282 283 284 285
	-- At the moment we just check for common LHS forms
	-- Expand as necessary.  Getting it wrong just means
	-- more orphans than necessary
    check (HsVar v)   	  = not (isLocallyDefined v)
    check (HsApp f a) 	  = check f && check a
    check (HsLit _)   	  = False
    check (OpApp l o _ r) = check l && check o && check r
    check (NegApp e _)    = check e
    check (HsPar e)	  = check e
    check (SectionL e o)  = check e && check o
    check (SectionR o e)  = check e && check o

    check other	      	  = True 	-- Safe fall through

286 287 288 289
isOrphanDecl other = False
\end{code}


290 291 292 293 294 295 296 297 298 299 300
\begin{code}
dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
  = pushSrcLocRn locn1	$
    addErrRn msg
  where
    msg = hang (ptext SLIT("Multiple default declarations"))
	       4  (vcat (map pp dup_things))
    pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
\end{code}


301 302 303 304 305 306 307 308 309 310 311 312 313
%*********************************************************
%*						 	 *
\subsection{Slurping declarations}
%*							 *
%*********************************************************

\begin{code}
-------------------------------------------------------
slurpImpDecls source_fvs
  = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`

	-- The current slurped-set records all local things
    getSlurped					`thenRn` \ source_binders ->
314
    slurpSourceRefs source_binders source_fvs	`thenRn` \ (decls, needed) ->
315

316 317 318 319 320 321 322
	-- Then get everything else
    closeDecls decls needed			`thenRn` \ decls1 ->

	-- Finally, get any deferred data type decls
    slurpDeferredDecls decls1			`thenRn` \ final_decls -> 

    returnRn final_decls
323 324 325 326 327

-------------------------------------------------------
slurpSourceRefs :: NameSet			-- Variables defined in source
		-> FreeVars			-- Variables referenced in source
		-> RnMG ([RenamedHsDecl],
328
			 FreeVars)		-- Un-satisfied needs
329 330 331 332
-- The declaration (and hence home module) of each gate has
-- already been loaded

slurpSourceRefs source_binders source_fvs
333 334 335 336
  = go_outer [] 			-- Accumulating decls
	     emptyFVs 			-- Unsatisfied needs
	     emptyFVs			-- Accumulating gates
  	     (nameSetToList source_fvs)	-- Things whose defn hasn't been loaded yet
337
  where
338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
	-- The outer loop repeatedly slurps the decls for the current gates
	-- and the instance decls 

	-- The outer loop is needed because consider
	--	instance Foo a => Baz (Maybe a) where ...
	-- It may be that @Baz@ and @Maybe@ are used in the source module,
	-- but not @Foo@; so we need to chase @Foo@ too.
	--
	-- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
	-- include actually getting in Foo's class decl
	--	class Wib a => Foo a where ..
	-- so that its superclasses are discovered.  The point is that Wib is a gate too.
	-- We do this for tycons too, so that we look through type synonyms.

    go_outer decls fvs all_gates []	
	= returnRn (decls, fvs)

    go_outer decls fvs all_gates refs	-- refs are not necessarily slurped yet
	= traceRn (text "go_outer" <+> ppr refs)		`thenRn_`
357
	  foldlRn go_inner (decls, fvs, emptyFVs) refs		`thenRn` \ (decls1, fvs1, gates1) ->
358 359 360 361
	  getImportedInstDecls (all_gates `plusFV` gates1)	`thenRn` \ inst_decls ->
	  rnInstDecls decls1 fvs1 gates1 inst_decls		`thenRn` \ (decls2, fvs2, gates2) ->
	  go_outer decls2 fvs2 (all_gates `plusFV` gates2)
			       (nameSetToList (gates2 `minusNameSet` all_gates))
362
		-- Knock out the all_gates because even if we don't slurp any new
363 364
		-- decls we can get some apparently-new gates from wired-in names

365 366 367 368 369 370 371 372 373 374 375
    go_inner (decls, fvs, gates) wanted_name
	= importDecl wanted_name 		`thenRn` \ import_result ->
	  case import_result of
	    AlreadySlurped -> returnRn (decls, fvs, gates)
	    WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
	    Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)	-- It's a type constructor
			
	    HereItIs decl -> rnIfaceDecl decl		`thenRn` \ (new_decl, fvs1) ->
			     returnRn (new_decl : decls, 
				       fvs1 `plusFV` fvs,
			   	       gates `plusFV` getGates source_fvs new_decl)
376

377 378 379 380 381 382 383 384 385
rnInstDecls decls fvs gates []
  = returnRn (decls, fvs, gates)
rnInstDecls decls fvs gates (d:ds) 
  = rnIfaceDecl d		`thenRn` \ (new_decl, fvs1) ->
    rnInstDecls (new_decl:decls) 
	        (fvs1 `plusFV` fvs)
		(gates `plusFV` getInstDeclGates new_decl)
		ds
\end{code}
386

387

388
\begin{code}
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
closeDecls decls needed
  | not (isEmptyFVs needed)
  = slurpDecls decls needed	`thenRn` \ (decls1, needed1) ->
    closeDecls decls1 needed1

  | otherwise
  = getImportedRules 			`thenRn` \ rule_decls ->
    case rule_decls of
	[]    -> returnRn decls	-- No new rules, so we are done
	other -> rnIfaceDecls decls emptyFVs rule_decls 	`thenRn` \ (decls1, needed1) ->
		 closeDecls decls1 needed1
		 

-------------------------------------------------------
-- Augment decls with any decls needed by needed.
-- Return also free vars of the new decls (only)
slurpDecls decls needed
  = go decls emptyFVs (nameSetToList needed) 
  where
    go decls fvs []         = returnRn (decls, fvs)
    go decls fvs (ref:refs) = slurpDecl decls fvs ref	`thenRn` \ (decls1, fvs1) ->
			      go decls1 fvs1 refs

-------------------------------------------------------
slurpDecl decls fvs wanted_name
416 417
  = importDecl wanted_name 		`thenRn` \ import_result ->
    case import_result of
418
	-- Found a declaration... rename it
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 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 472 473 474 475
	HereItIs decl -> rnIfaceDecl decl		`thenRn` \ (new_decl, fvs1) ->
			 returnRn (new_decl:decls, fvs1 `plusFV` fvs)

	-- No declaration... (wired in thing, or deferred, or already slurped)
	other -> returnRn (decls, fvs)


-------------------------------------------------------
rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
	     -> [(Module, RdrNameHsDecl)]
	     -> RnM d ([RenamedHsDecl], FreeVars)
rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d		`thenRn` \ (new_decl, fvs1) ->
				rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds

rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)	
\end{code}


%*********************************************************
%*						 	 *
\subsection{Deferred declarations}
%*							 *
%*********************************************************

The idea of deferred declarations is this.  Suppose we have a function
	f :: T -> Int
	data T = T1 A | T2 B
	data A = A1 X | A2 Y
	data B = B1 P | B2 Q
Then we don't want to load T and all its constructors, and all
the types those constructors refer to, and all the types *those*
constructors refer to, and so on.  That might mean loading many more
interface files than is really necessary.  So we 'defer' loading T.

But f might be strict, and the calling convention for evaluating
values of type T depends on how many constructors T has, so 
we do need to load T, but not the full details of the type T.
So we load the full decl for T, but only skeleton decls for A and B:
	f :: T -> Int
	data T = {- 2 constructors -}

Whether all this is worth it is moot.

\begin{code}
slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
slurpDeferredDecls decls
  = getDeferredDecls						`thenRn` \ def_decls ->
    rnIfaceDecls decls emptyFVs (map stripDecl def_decls)	`thenRn` \ (decls1, fvs) ->
    ASSERT( isEmptyFVs fvs )
    returnRn decls1

stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc))
  = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc))
	-- Nuke the context and constructors
	-- But retain the *number* of constructors!
	-- Also the tvs will have kinds on them.
476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502
\end{code}


%*********************************************************
%*						 	 *
\subsection{Extracting the `gates'}
%*							 *
%*********************************************************

When we import a declaration like
\begin{verbatim}
	data T = T1 Wibble | T2 Wobble
\end{verbatim}
we don't want to treat @Wibble@ and @Wobble@ as gates
{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
If only @T@ is mentioned
we want only @T@ to be a gate;
that way we don't suck in useless instance
decls for (say) @Eq Wibble@, when they can't possibly be useful.

@getGates@ takes a newly imported (and renamed) decl, and the free
vars of the source program, and extracts from the decl the gate names.

\begin{code}
getGates source_fvs (SigD (IfaceSig _ ty _ _))
  = extractHsTyNames ty

503
getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
504
  = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
505
		        (hsTyVarNames tvs)
506 507
     `addOneToNameSet` cls)
    `plusFV` maybe_double
508
  where
509
    get (ClassOpSig n _ ty _) 
510 511 512
	| n `elemNameSet` source_fvs = extractHsTyNames ty
	| otherwise		     = emptyFVs

513 514 515 516 517 518 519 520 521 522
	-- If we load any numeric class that doesn't have
	-- Int as an instance, add Double to the gates. 
	-- This takes account of the fact that Double might be needed for
	-- defaulting, but we don't want to load Double (and all its baggage)
	-- if the more exotic classes aren't used at all.
    maybe_double | nameUnique cls `elem` fractionalClassKeys 
		 = unitFV (getName doubleTyCon)
		 | otherwise
		 = emptyFVs

523 524
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
  = delListFromNameSet (extractHsTyNames ty)
525
		       (hsTyVarNames tvs)
526 527
	-- A type synonym type constructor isn't a "gate" for instance decls

528
getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
529
  = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
530
		       (hsTyVarNames tvs)
531 532
    `addOneToNameSet` tycon
  where
533
    get (ConDecl n _ tvs ctxt details _)
534 535 536 537
	| n `elemNameSet` source_fvs
		-- If the constructor is method, get fvs from all its fields
	= delListFromNameSet (get_details details `plusFV` 
		  	      extractHsCtxtTyNames ctxt)
538
			     (hsTyVarNames tvs)
539
    get (ConDecl n _ tvs ctxt (RecCon fields) _)
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
		-- Even if the constructor isn't mentioned, the fields
		-- might be, as selectors.  They can't mention existentially
		-- bound tyvars (typechecker checks for that) so no need for 
		-- the deleteListFromNameSet part
	= foldr (plusFV . get_field) emptyFVs fields
	
    get other_con = emptyFVs

    get_details (VanillaCon tys) = plusFVs (map get_bang tys)
    get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
    get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
    get_details (NewCon t _)	 = extractHsTyNames t

    get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
		     | otherwise			 = emptyFVs

556
    get_bang bty = extractHsTyNames (getBangType bty)
557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587

getGates source_fvs other_decl = emptyFVs
\end{code}

@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
rather than a declaration.

\begin{code}
getWiredInGates :: Name -> FreeVars
getWiredInGates name 	-- No classes are wired in
  | is_id	         = getWiredInGates_s (namesOfType (idType the_id))
  | isSynTyCon the_tycon = getWiredInGates_s
	 (delListFromNameSet (namesOfType ty) (map getName tyvars))
  | otherwise 	         = unitFV name
  where
    maybe_wired_in_id    = maybeWiredInIdName name
    is_id		 = maybeToBool maybe_wired_in_id
    maybe_wired_in_tycon = maybeWiredInTyConName name
    Just the_id 	 = maybe_wired_in_id
    Just the_tycon	 = maybe_wired_in_tycon
    (tyvars,ty) 	 = getSynTyConDefn the_tycon

getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
\end{code}

\begin{code}
getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
getInstDeclGates other				    = emptyFVs
\end{code}


588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
%*********************************************************
%*						 	 *
\subsection{Fixities}
%*							 *
%*********************************************************

\begin{code}
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
fixitiesFromLocalDecls gbl_env decls
  = foldlRn getFixities emptyNameEnv decls				`thenRn` \ env -> 
    traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))	`thenRn_`
    returnRn env
  where
    getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
    getFixities acc (FixD fix)
      = fix_decl acc fix

    getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
      = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
		-- Get fixities from class decl sigs too.
    getFixities acc other_decl
      = returnRn acc

    fix_decl acc sig@(FixitySig rdr_name fixity loc)
	= 	-- Check for fixity decl for something not declared
	  case lookupRdrEnv gbl_env rdr_name of {
	    Nothing | opt_WarnUnusedBinds 
		    -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
		       `thenRn_` returnRn acc 
		    | otherwise -> returnRn acc ;
	
	    Just (name:_) ->

		-- Check for duplicate fixity decl
	  case lookupNameEnv acc name of {
	    Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
					 `thenRn_` returnRn acc ;

626
	    Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
	  }}
\end{code}


%*********************************************************
%*						 	 *
\subsection{Deprecations}
%*							 *
%*********************************************************

For deprecations, all we do is check that the names are in scope.
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.

\begin{code}
rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
	   -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
rnDeprecs gbl_env mod_deprec decls
 = mapRn rn_deprec deprecs 	`thenRn_` 
   returnRn (extra_deprec ++ deprecs)
 where
   deprecs = [d | DeprecD d <- decls]
   extra_deprec = case mod_deprec of
		   Nothing  -> []
		   Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]

   rn_deprec (Deprecation ie txt loc)
     = pushSrcLocRn loc		$
       mapRn check (ieNames ie)

   check n = case lookupRdrEnv gbl_env n of
		Nothing -> addErrRn (unknownNameErr n)
		Just _  -> returnRn ()
\end{code}


663 664 665 666 667 668 669
%*********************************************************
%*						 	 *
\subsection{Unused names}
%*							 *
%*********************************************************

\begin{code}
rrt's avatar
rrt committed
670
reportUnusedNames :: ModuleName -> [Module] 
671
		  -> GlobalRdrEnv -> AvailEnv
672 673
		  -> Avails -> NameSet -> [RenamedHsDecl] 
		  -> RnMG ()
674 675
reportUnusedNames mod_name direct_import_mods 
		  gbl_env avail_env 
676
		  export_avails mentioned_names
677
		  imported_decls
678 679 680 681 682 683
  = let
	used_names = mentioned_names `unionNameSets` availsToNameSet export_avails

	-- Now, a use of C implies a use of T,
	-- if C was brought into scope by T(..) or T(C)
	really_used_names = used_names `unionNameSets`
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
	  mkNameSet [ availName parent_avail
		    | sub_name <- nameSetToList used_names
		    , isValOcc (getOccName sub_name)

			-- Usually, every used name will appear in avail_env, but there 
			-- is one time when it doesn't: tuples and other built in syntax.  When you
			-- write (a,b) that gives rise to a *use* of "(,)", so that the
			-- instances will get pulled in, but the tycon "(,)" isn't actually
			-- in scope.  Hence the isValOcc filter.
			--
			-- Also, (-x) gives rise to an implicit use of 'negate'; similarly, 
			--   3.5 gives rise to an implcit use of :%
			-- hence the isUserImportedName filter on the warning
		      
		    , let parent_avail 
			    = case lookupNameEnv avail_env sub_name of
				Just avail -> avail
				Nothing -> WARN( isUserImportedName sub_name,
702 703
						 text "reportUnusedName: not in avail_env" <+> 
							ppr sub_name )
704 705 706
					   Avail sub_name
		      
		    , case parent_avail of { AvailTC _ _ -> True; other -> False }
707 708 709 710 711 712 713
		    ]

	defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
	defined_but_not_used =
	   nameSetToList (defined_names `minusNameSet` really_used_names)

	-- Filter out the ones only defined implicitly
714 715 716
	bad_locals     = [n | n <- defined_but_not_used, isLocallyDefined	      n]
	bad_imp_names  = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n,
						         not (module_unused n)]
717

718 719 720 721
	deprec_used deprec_env = [ (n,txt)
                                 | n <- nameSetToList mentioned_names,
                                   not (isLocallyDefined n),
                                   Just txt <- [lookupNameEnv deprec_env n] ]
722

723 724 725
	-- inst_mods are directly-imported modules that 
	--	contain instance decl(s) that the renamer decided to suck in
	-- It's not necessarily redundant to import such modules.
726 727 728 729 730 731
	--
	-- NOTE: Consider 
	--	      module This
	--		import M ()
	--
	--	 The import M() is not *necessarily* redundant, even if
732
	-- 	 we suck in no instance decls from M (e.g. it contains 
733 734 735 736 737 738
	--	 no instance decls, or This contains no code).  It may be 
	--	 that we import M solely to ensure that M's orphan instance 
	--	 decls (or those in its imports) are visible to people who 
	--	 import This.  Sigh. 
	--	 There's really no good way to detect this, so the error message 
	--	 in RnEnv.warnUnusedModules is weakened instead
739
	inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
rrt's avatar
rrt committed
740
			 let m = nameModule dfun,
741 742 743
			 m `elem` direct_import_mods
		    ]

rrt's avatar
rrt committed
744
	minimal_imports :: FiniteMap Module AvailEnv
745 746 747 748 749 750
	minimal_imports0 = emptyFM
	minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
	minimal_imports  = foldr   add_inst_mod minimal_imports1 inst_mods
	
	add_name n acc = case maybeUserImportedFrom n of
			   Nothing -> acc
rrt's avatar
rrt committed
751
			   Just m  -> addToFM_C plusAvailEnv acc m
752 753 754 755 756 757 758
					        (unitAvailEnv (mk_avail n))
	add_inst_mod m acc 
	  | m `elemFM` acc = acc	-- We import something already
	  | otherwise	   = addToFM acc m emptyAvailEnv
		-- Add an empty collection of imports for a module
		-- from which we have sucked only instance decls

759 760 761 762 763
	mk_avail n = case lookupNameEnv avail_env n of
			Just (AvailTC m _) | n==m      -> AvailTC n [n]
					   | otherwise -> AvailTC m [n,m]
			Just avail	   -> Avail n
			Nothing		   -> pprPanic "mk_avail" (ppr n)
764 765 766

	-- unused_imp_mods are the directly-imported modules 
	-- that are not mentioned in minimal_imports
767 768 769
	unused_imp_mods = [m | m <- direct_import_mods,
			       not (maybeToBool (lookupFM minimal_imports m)),
			       moduleName m /= pRELUDE_Name]
770 771 772 773

	module_unused :: Name -> Bool
	-- Name is imported from a module that's completely unused,
	-- so don't report stuff about the name (the module covers it)
rrt's avatar
rrt committed
774
	module_unused n = expectJust "module_unused" (maybeUserImportedFrom n)
775 776
			  `elem` unused_imp_mods
				-- module_unused is only called if it's user-imported
777
    in
778
    warnUnusedModules unused_imp_mods				`thenRn_`
779
    warnUnusedLocalBinds bad_locals				`thenRn_`
780
    warnUnusedImports bad_imp_names				`thenRn_`
781
    printMinimalImports mod_name minimal_imports		`thenRn_`
782
    getIfacesRn							`thenRn` \ ifaces ->
783
    (if opt_WarnDeprecations
784
	then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
785
	else returnRn ())
786

787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
printMinimalImports mod_name imps
  | not opt_D_dump_minimal_imports
  = returnRn ()
  | otherwise
  = mapRn to_ies (fmToList imps)		`thenRn` \ mod_ies ->
    ioToRnM (do { h <- openFile filename WriteMode ;
		  printForUser h (vcat (map ppr_mod_ie mod_ies))
	})					`thenRn_`
    returnRn ()
  where
    filename = moduleNameUserString mod_name ++ ".imports"
    ppr_mod_ie (mod_name, ies) 
	| mod_name == pRELUDE_Name 
	= empty
	| otherwise
	= ptext SLIT("import") <+> ppr mod_name <> 
			    parens (fsep (punctuate comma (map ppr ies)))

    to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)	`thenRn` \ ies ->
rrt's avatar
rrt committed
807
			      returnRn (moduleName mod, ies)
808 809 810 811 812 813 814 815 816 817 818 819 820

    to_ie :: AvailInfo -> RnMG (IE Name)
    to_ie (Avail n)       = returnRn (IEVar n)
    to_ie (AvailTC n [m]) = ASSERT( n==m ) 
			    returnRn (IEThingAbs n)
    to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n)) 
						ImportBySystem	 	`thenRn` \ (_, avails) ->
			    case [ms | AvailTC m ms <- avails, m == n] of
			      [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
				   | otherwise	        -> returnRn (IEThingWith n (filter (/= n) ns))
			      other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
				       returnRn (IEVar n)

821 822 823
rnDump  :: [RenamedHsDecl] 	-- Renamed imported decls
	-> [RenamedHsDecl] 	-- Renamed local decls
	-> RnMG (IO ())
824
rnDump imp_decls local_decls
825 826 827
        | opt_D_dump_rn_trace || 
	  opt_D_dump_rn_stats ||
	  opt_D_dump_rn 
828
 	= getRnStats imp_decls		`thenRn` \ stats_msg ->
829

830
	  returnRn (printErrs stats_msg >> 
831 832
		    dumpIfSet opt_D_dump_rn "Renamer:" 
			      (vcat (map ppr (local_decls ++ imp_decls))))
833

834 835
	| otherwise = returnRn (return ())
\end{code}
836 837 838 839 840 841 842 843 844 845 846 847 848


%*********************************************************
%*							*
\subsection{Statistics}
%*							*
%*********************************************************

\begin{code}
getRnStats :: [RenamedHsDecl] -> RnMG SDoc
getRnStats imported_decls
  = getIfacesRn 		`thenRn` \ ifaces ->
    let
849
	n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901

	decls_read     = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
				-- Data, newtype, and class decls are in the decls_fm
				-- under multiple names; the tycon/class, and each
				-- constructor/class op too.
				-- The 'True' selects just the 'main' decl
				 not (isLocallyDefined (availName avail))
			     ]

	(cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
	(cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls

	unslurped_insts       = iInsts ifaces
	inst_decls_unslurped  = length (bagToList unslurped_insts)
	inst_decls_read	      = id_sp + inst_decls_unslurped

	stats = vcat 
		[int n_mods <+> text "interfaces read",
		 hsep [ int cd_sp, text "class decls imported, out of", 
		        int cd_rd, text "read"],
		 hsep [ int dd_sp, text "data decls imported, out of",  
			int dd_rd, text "read"],
		 hsep [ int nd_sp, text "newtype decls imported, out of",  
		        int nd_rd, text "read"],
		 hsep [int sd_sp, text "type synonym decls imported, out of",  
		        int sd_rd, text "read"],
		 hsep [int vd_sp, text "value signatures imported, out of",  
		        int vd_rd, text "read"],
		 hsep [int id_sp, text "instance decls imported, out of",  
		        int inst_decls_read, text "read"],
		 text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) 
					   [d | TyClD d <- imported_decls, isClassDecl d]),
		 text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName) 
					   [d | TyClD d <- decls_read, isClassDecl d])]
    in
    returnRn (hcat [text "Renamer stats: ", stats])

count_decls decls
  = (class_decls, 
     data_decls, 
     newtype_decls,
     syn_decls, 
     val_decls, 
     inst_decls)
  where
    tycl_decls = [d | TyClD d <- decls]
    (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls

    val_decls     = length [() | SigD _	  <- decls]
    inst_decls    = length [() | InstD _  <- decls]
\end{code}    

902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925

%************************************************************************
%*									*
\subsection{Errors and warnings}
%*									*
%************************************************************************

\begin{code}
warnDeprec :: (Name, DeprecTxt) -> RnM d ()
warnDeprec (name, txt)
  = pushSrcLocRn (getSrcLoc name)	$
    addWarnRn				$
    sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
          text "is deprecated:", nest 4 (ppr txt) ]


unusedFixityDecl rdr_name fixity
  = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]

dupFixityDecl rdr_name loc1 loc2
  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
	  ptext SLIT("at ") <+> ppr loc1,
	  ptext SLIT("and") <+> ppr loc2]
\end{code}