RnIfaces.lhs 34.7 KB
Newer Older
1
2
3
4
5
6
7
8
9
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[RnIfaces]{Cacheing and Renaming of Interfaces}

\begin{code}
#include "HsVersions.h"

module RnIfaces (
10
11
	getInterfaceExports,
	getImportedInstDecls,
sof's avatar
sof committed
12
	getSpecialInstModules, getDeferredDataDecls,
13
	importDecl, recordSlurp,
sof's avatar
sof committed
14
	getImportVersions, getSlurpedNames, getRnStats,
15
16
17
18
19

	checkUpToDate,

	getDeclBinders,
	mkSearchPath
20
21
    ) where

22
IMP_Ubiq()
sof's avatar
sof committed
23
24
25
#if __GLASGOW_HASKELL__ >= 202
import IO
#endif
26
27


sof's avatar
sof committed
28
import CmdLineOpts	( opt_PruneTyDecls, opt_PruneInstDecls, opt_PprUserLength )
sof's avatar
sof committed
29
30
import HsSyn		( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..),
			  HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..),
sof's avatar
sof committed
31
32
			  FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), HsIdInfo,
			  IE(..), hsDeclName
33
34
			)
import HsPragmas	( noGenPragmas )
sof's avatar
sof committed
35
import BasicTypes	( SYN_IE(Version), NewOrData(..) )
sof's avatar
sof committed
36
import RdrHsSyn		( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
37
38
			  RdrName, rdrNameOcc
			)
39
40
41
import RnEnv		( newGlobalName, lookupRn, addImplicitOccsRn, 
			  availName, availNames, addAvailToNameSet, pprAvail
			)
sof's avatar
sof committed
42
import RnSource		( rnHsSigType )
43
import RnMonad
sof's avatar
sof committed
44
import RnHsSyn          ( SYN_IE(RenamedHsDecl) )
45
import ParseIface	( parseIface )
46

47
import ErrUtils		( SYN_IE(Error), SYN_IE(Warning) )
sof's avatar
sof committed
48
49
50
51
import FiniteMap	( FiniteMap, sizeFM, emptyFM, unitFM,  delFromFM,
			  lookupFM, addToFM, addToFM_C, addListToFM, 
			  fmToList, eltsFM 
			)
52
import Name		( Name {-instance NamedThing-}, Provenance, OccName(..),
sof's avatar
sof committed
53
			  nameModule, occNameString, moduleString, pprModule, isLocallyDefined,
54
			  NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
sof's avatar
sof committed
55
			  minusNameSet, mkNameSet, elemNameSet, nameUnique, addOneToNameSet,
sof's avatar
sof committed
56
57
			  isWiredInName, maybeWiredInTyConName, maybeWiredInIdName,
			  NamedThing(..)
58
			 )
sof's avatar
sof committed
59
import Id		( GenId, Id(..), idType, dataConTyCon, isAlgCon )
60
61
62
import TyCon		( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type		( namesOfType )
import TyVar		( GenTyVar )
sof's avatar
sof committed
63
64
65
import SrcLoc		( mkIfaceSrcLoc, SrcLoc )
import PrelMods		( gHC__ )
import PrelInfo		( cCallishTyKeys )
66
67
68
import Bag
import Maybes		( MaybeErr(..), expectJust, maybeToBool )
import ListSetOps	( unionLists )
69
import Pretty
sof's avatar
sof committed
70
import Outputable	( PprStyle(..) )
sof's avatar
sof committed
71
72
import Unique		( Unique )
import Util		( pprPanic, pprTrace, Ord3(..) )
73
import StringBuffer     ( StringBuffer, hGetStringBuffer, freeStringBuffer )
sof's avatar
sof committed
74
import Outputable
sof's avatar
sof committed
75
76
77
#if __GLASGOW_HASKELL__ >= 202
import List (nub)
#endif
78
79
\end{code}

80
81


sof's avatar
sof committed
82
83
84
85
86
87
88
89
90
91
92
%*********************************************************
%*							*
\subsection{Statistics}
%*							*
%*********************************************************

\begin{code}
getRnStats :: [RenamedHsDecl] -> RnMG Doc
getRnStats all_decls
  = getIfacesRn 		`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
93
	Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
sof's avatar
sof committed
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
	n_mods	    = sizeFM mod_vers_map

	decls_imported = filter is_imported_decl all_decls
	decls_read     = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
				 name == availName avail,
					-- Data, newtype, and class decls are in the decls_fm
					-- under multiple names; the tycon/class, and each
					-- constructor/class op too.
				 not (isLocallyDefined name)
			     ]

	(cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd,     _) = count_decls decls_read
	(cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported

	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 (of which", int add_sp, text "abstractly), out of",  
			int dd_rd, text "read"],
		 hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), 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"]
		]
    in
    returnRn (hcat [text "Renamer stats: ", stats])

is_imported_decl (DefD _) = False
is_imported_decl (ValD _) = False
is_imported_decl decl     = not (isLocallyDefined (hsDeclName decl))

count_decls decls
  = -- pprTrace "count_decls" (ppr PprDebug  decls
    --
    --			    $$
    --			    text "========="
    --			    $$
    --			    ppr PprDebug imported_decls
    --	) $
    (class_decls, 
     data_decls,    abstract_data_decls,
     newtype_decls, abstract_newtype_decls,
     syn_decls, 
     val_decls, 
     inst_decls)
  where
    class_decls   = length [() | ClD _		     	    <- decls]
    data_decls    = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls]
    newtype_decls = length [() | TyD (TyData NewType  _ _ _ _ _ _ _) <- decls]
    abstract_data_decls    = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls]
    abstract_newtype_decls = length [() | TyD (TyData NewType  _ _ _ [] _ _ _) <- decls]
    syn_decls     = length [() | TyD (TySynonym _ _ _ _)    <- decls]
    val_decls     = length [() | SigD _		    	    <- decls]
    inst_decls    = length [() | InstD _		    <- decls]

\end{code}    

159
160
161
162
163
%*********************************************************
%*							*
\subsection{Loading a new interface file}
%*							*
%*********************************************************
164

165
\begin{code}
sof's avatar
sof committed
166
loadInterface :: Doc -> Module -> RnMG Ifaces
167
168
loadInterface doc_str load_mod 
  = getIfacesRn 		`thenRn` \ ifaces ->
169
    let
sof's avatar
sof committed
170
	Ifaces this_mod mod_vers_map export_envs decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
171
    in
172
	-- CHECK WHETHER WE HAVE IT ALREADY
173
    if maybeToBool (lookupFM export_envs load_mod) 
174
175
176
177
178
179
180
181
182
183
184
    then
	returnRn ifaces		-- Already in the cache; don't re-read it
    else

	-- READ THE MODULE IN
    findAndReadIface doc_str load_mod		`thenRn` \ read_result ->
    case read_result of {
	-- Check for not found
	Nothing -> 	-- Not found, so add an empty export env to the Ifaces map
			-- so that we don't look again
		   let
185
186
187
			new_export_envs = addToFM export_envs load_mod ([],[])
			new_ifaces = Ifaces this_mod mod_vers_map
					    new_export_envs
sof's avatar
sof committed
188
					    decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods
189
190
191
192
193
		   in
		   setIfacesRn new_ifaces		`thenRn_`
		   failWithRn new_ifaces (noIfaceErr load_mod) ;

	-- Found and parsed!
194
	Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
195
196

	-- LOAD IT INTO Ifaces
197
198
199
    mapRn loadExport exports				`thenRn` \ avails_s ->
    foldlRn (loadDecl load_mod) decls rd_decls		`thenRn` \ new_decls ->
    foldlRn (loadInstDecl load_mod) insts rd_insts	`thenRn` \ new_insts ->
200
    let
201
	 export_env = (concat avails_s, fixs)
202
203
204
205
206
207

			-- Exclude this module from the "special-inst" modules
	 new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)

	 new_ifaces = Ifaces this_mod
			     (addToFM mod_vers_map load_mod mod_vers)
208
209
210
			     (addToFM export_envs load_mod export_env)
			     new_decls
			     all_names imp_names
sof's avatar
sof committed
211
			     (new_insts, tycls_names)
sof's avatar
sof committed
212
			     deferred_data_decls 
213
			     new_inst_mods 
214
    in
215
216
217
218
    setIfacesRn new_ifaces		`thenRn_`
    returnRn new_ifaces
    }

219
220
221
loadExport :: ExportItem -> RnMG [AvailInfo]
loadExport (mod, entities)
  = mapRn load_entity entities
222
223
224
  where
    new_name occ = newGlobalName mod occ

225
226
227
228
229
-- The communcation between this little code fragment and the "entity" rule
-- in ParseIface.y is a bit gruesome.  The idea is that things which are
-- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas
-- things destined to be Avails show up as (occ, [])

230
231
    load_entity (occ, occs)
      =	new_name occ 		`thenRn` \ name ->
232
233
234
235
236
	if null occs then
		returnRn (Avail name)
	else
	        mapRn new_name occs 	`thenRn` \ names ->
	        returnRn (AvailTC name names)
237

238
loadDecl :: Module -> DeclsMap
239
	 -> (Version, RdrNameHsDecl)
240
241
242
	 -> RnMG DeclsMap
loadDecl mod decls_map (version, decl)
  = getDeclBinders new_implicit_name decl	`thenRn` \ avail ->
243
    returnRn (addListToFM decls_map
244
			  [(name,(version,avail,decl)) | name <- availNames avail]
245
    )
246
  where
247
248
    new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)

249
250
251
252
loadInstDecl :: Module
	     -> Bag IfaceInst
	     -> RdrNameInstDecl
	     -> RnMG (Bag IfaceInst)
253
loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
254
255
256
257
258
259
260
261
  = 
	-- Find out what type constructors and classes are "gates" for the
	-- instance declaration.  If all these "gates" are slurped in then
	-- we should slurp the instance decl too.
	-- 
	-- We *don't* want to count names in the context part as gates, though.
	-- For example:
	--		instance Foo a => Baz (T a) where ...
262
	--
263
264
265
266
267
268
269
270
271
	-- Here the gates are Baz and T, but *not* Foo.
    let 
	munged_inst_ty = case inst_ty of
				HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
				HsPreForAllTy cxt ty  -> HsPreForAllTy [] ty
				other		      -> inst_ty
    in
	-- We find the gates by renaming the instance type with in a 
	-- and returning the occurrence pool.
sof's avatar
sof committed
272
    initRnMS emptyRnEnv mod_name (InterfaceMode Compulsory) (
sof's avatar
sof committed
273
        findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)	
274
275
    )						`thenRn` \ gate_names ->
    returnRn (((mod_name, decl), gate_names) `consBag` insts)
276
\end{code}
277

278

279
280
281
282
283
284
285
286
287
288
%********************************************************
%*							*
\subsection{Loading usage information}
%*							*
%********************************************************

\begin{code}
checkUpToDate :: Module -> RnMG Bool		-- True <=> no need to recompile
checkUpToDate mod_name
  = findAndReadIface doc_str mod_name		`thenRn` \ read_result ->
289
    case read_result of
290
	Nothing -> 	-- Old interface file not found, so we'd better bail out
sof's avatar
sof committed
291
		    traceRn (sep [ptext SLIT("Didnt find old iface"), 
292
				    pprModule PprDebug mod_name])	`thenRn_`
293
294
295
296
297
		    returnRn False

	Just (ParsedIface _ _ usages _ _ _ _ _) 
		-> 	-- Found it, so now check it
		    checkModUsage usages
298
  where
299
	-- Only look in current directory, with suffix .hi
sof's avatar
sof committed
300
    doc_str = sep [ptext SLIT("Need usage info from"), pprModule PprDebug mod_name]
301

302
checkModUsage [] = returnRn True		-- Yes!  Everything is up to date!
303

304
305
306
checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
  = loadInterface doc_str mod		`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
307
	Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
308
	maybe_new_mod_vers = lookupFM mod_vers mod
309
	Just new_mod_vers  = maybe_new_mod_vers
310
    in
311
	-- If we can't find a version number for the old module then
312
	-- bail out saying things aren't up to date
313
314
315
316
317
318
    if not (maybeToBool maybe_new_mod_vers) then
	returnRn False
    else

	-- If the module version hasn't changed, just move on
    if new_mod_vers == old_mod_vers then
sof's avatar
sof committed
319
	traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod])	`thenRn_`
320
321
	checkModUsage rest
    else
sof's avatar
sof committed
322
    traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod])	`thenRn_`
323

324
	-- New module version, so check entities inside
325
    checkEntityUsage mod decls old_local_vers	`thenRn` \ up_to_date ->
326
    if up_to_date then
sof's avatar
sof committed
327
	traceRn (ptext SLIT("...but the bits I use haven't."))	`thenRn_`
328
329
330
331
	checkModUsage rest	-- This one's ok, so check the rest
    else
	returnRn False		-- This one failed, so just bail out now
  where
sof's avatar
sof committed
332
    doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod]
333
334


335
checkEntityUsage mod decls [] 
336
337
  = returnRn True	-- Yes!  All up to date!

338
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
339
  = newGlobalName mod occ_name		`thenRn` \ name ->
340
    case lookupFM decls name of
341
342

	Nothing       -> 	-- We used it before, but it ain't there now
sof's avatar
sof committed
343
			  traceRn (sep [ptext SLIT("...and this no longer exported:"), ppr PprDebug name])	`thenRn_`
344
345
			  returnRn False

346
347
348
349
350
351
352
	Just (new_vers,_,_) 	-- It's there, but is it up to date?
		| new_vers == old_vers
			-- Up to date, so check the rest
		-> checkEntityUsage mod decls rest

		| otherwise
			-- Out of date, so bale out
sof's avatar
sof committed
353
		-> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name])  `thenRn_`
354
		   returnRn False
355
356
357
\end{code}


358
359
360
361
362
%*********************************************************
%*							*
\subsection{Getting in a declaration}
%*							*
%*********************************************************
363

364
\begin{code}
365
366
367
368
369
370
importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
	-- Returns Nothing for a wired-in or already-slurped decl

importDecl name necessity
  = checkSlurped name			`thenRn` \ already_slurped ->
    if already_slurped then
sof's avatar
sof committed
371
	traceRn (sep [text "Already slurped:", ppr PprDebug name])	`thenRn_`
372
373
374
	returnRn Nothing	-- Already dealt with
    else
    if isWiredInName name then
sof's avatar
sof committed
375
	getWiredInDecl name necessity
376
377
378
    else 
       getIfacesRn 		`thenRn` \ ifaces ->
       let
sof's avatar
sof committed
379
         Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
sof's avatar
sof committed
380
         mod = nameModule name
381
382
383
384
385
386
387
388
       in
       if mod == this_mod  then    -- Don't bring in decls from
	  pprTrace "importDecl wierdness:" (ppr PprDebug name) $
	  returnRn Nothing         -- the renamed module's own interface file
			           -- 
       else
	getNonWiredInDecl name necessity
\end{code}
389

390
391
\begin{code}
getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
sof's avatar
sof committed
392
getNonWiredInDecl needed_name necessity
393
  = traceRn doc_str 			`thenRn_`
sof's avatar
sof committed
394
395
396
397
398
399
    loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
    case lookupFM decls needed_name of

	-- Special case for data/newtype type declarations
      Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
	      -> getNonWiredDataDecl needed_name version avail ty_decl	`thenRn` \ (avail', maybe_decl) ->
sof's avatar
sof committed
400
		 recordSlurp (Just version) necessity avail'	`thenRn_`
sof's avatar
sof committed
401
		 returnRn maybe_decl
402

sof's avatar
sof committed
403
      Just (version,avail,decl)
sof's avatar
sof committed
404
	      -> recordSlurp (Just version) necessity avail	`thenRn_`
sof's avatar
sof committed
405
		 returnRn (Just decl)
406
407
408

      Nothing -> 	-- Can happen legitimately for "Optional" occurrences
		   case necessity of { 
sof's avatar
sof committed
409
410
				Optional -> addWarnRn (getDeclWarn needed_name);
				other	 -> addErrRn  (getDeclErr  needed_name)
411
412
		   }						`thenRn_` 
		   returnRn Nothing
413
  where
sof's avatar
sof committed
414
     doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name]
sof's avatar
sof committed
415
     mod = nameModule needed_name
sof's avatar
sof committed
416
417
418

     is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
     is_data_or_newtype other		         = False
419
420
\end{code}

421
422
423
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
It behaves exactly as if the wired in decl were actually in an interface file.
Specifically,
424

425
426
427
  *	if the wired-in name is a data type constructor or a data constructor, 
	it brings in the type constructor and all the data constructors; and
	marks as "occurrences" any free vars of the data con.
428

429
  * 	similarly for synonum type constructor
430

431
432
  * 	if the wired-in name is another wired-in Id, it marks as "occurrences"
	the free vars of the Id's type.
433

434
435
  *	it loads the interface file for the wired-in thing for the
	sole purpose of making sure that its instance declarations are available
436

437
438
439
440
All this is necessary so that we know all types that are "in play", so
that we know just what instances to bring into scope.
	
\begin{code}
sof's avatar
sof committed
441
442
443
444
getWiredInDecl name necessity
  = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) 
	     get_wired				`thenRn` \ avail ->
    recordSlurp Nothing necessity avail		`thenRn_`
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

   	-- Force in the home module in case it has instance decls for
	-- the thing we are interested in.
	--
	-- Mini hack 1: no point for non-tycons/class; and if we
	-- do this we find PrelNum trying to import PackedString,
	-- because PrelBase's .hi file mentions PackedString.unpackString
	-- But PackedString.hi isn't built by that point!
	--
	-- Mini hack 2; GHC is guaranteed not to have
	-- instance decls, so it's a waste of time to read it
	--
	-- NB: We *must* look at the availName of the slurped avail, 
	-- not the name passed to getWiredInDecl!  Why?  Because if a data constructor 
	-- or class op is passed to getWiredInDecl we'll pull in the whole data/class
	-- decl, and recordSlurp will record that fact.  But since the data constructor
	-- isn't a tycon/class we won't force in the home module.  And even if the
	-- type constructor/class comes along later, loadDecl will say that it's already
	-- been slurped, so getWiredInDecl won't even be called.  Pretty obscure bug, this was.
    let
	main_name  = availName avail
	main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
sof's avatar
sof committed
467
	mod        = nameModule main_name
sof's avatar
sof committed
468
	doc_str    = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
469
470
471
    in
    (if not main_is_tc || mod == gHC__ then
	returnRn ()		
472
473
474
    else
	loadInterface doc_str mod	`thenRn_`
	returnRn ()
475
476
477
    )				 	`thenRn_`

    returnRn Nothing		-- No declaration to process further
478
479
  where

480
481
482
    get_wired | is_tycon			-- ... a type constructor
	      = get_wired_tycon the_tycon

sof's avatar
sof committed
483
	      | (isAlgCon the_id) 		-- ... a wired-in data constructor
484
485
486
487
488
	      = get_wired_tycon (dataConTyCon the_id)

	      | otherwise			-- ... a wired-in non data-constructor
	      = get_wired_id the_id

sof's avatar
sof committed
489
    mod_name		 = nameModule name
490
491
492
493
494
495
    maybe_wired_in_tycon = maybeWiredInTyConName name
    is_tycon		 = maybeToBool maybe_wired_in_tycon
    maybe_wired_in_id    = maybeWiredInIdName    name
    Just the_tycon	 = maybe_wired_in_tycon
    Just the_id 	 = maybe_wired_in_id

496

497
498
get_wired_id id
  = addImplicitOccsRn (nameSetToList id_mentioned)	`thenRn_`
499
    returnRn (Avail (getName id))
500
  where
501
    id_mentioned = namesOfType (idType id)
502

503
504
505
get_wired_tycon tycon 
  | isSynTyCon tycon
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
sof's avatar
sof committed
506
    returnRn (AvailTC tc_name [tc_name])
507
  where
sof's avatar
sof committed
508
    tc_name     = getName tycon
509
    (tyvars,ty) = getSynTyConDefn tycon
sof's avatar
sof committed
510
    mentioned   = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
511

512
513
514
get_wired_tycon tycon 
  | otherwise		-- data or newtype
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
515
    returnRn (AvailTC tycon_name (tycon_name : map getName data_cons))
516
  where
517
518
519
    tycon_name = getName tycon
    data_cons  = tyConDataCons tycon
    mentioned  = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
520
521
522
\end{code}


523
    
524
525
%*********************************************************
%*							*
sof's avatar
sof committed
526
\subsection{Getting what a module exports}
527
528
%*							*
%*********************************************************
529
530

\begin{code}
531
532
getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod
sof's avatar
sof committed
533
  = loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
534
535
536
537
538
539
540
541
542
    case lookupFM export_envs mod of
	Nothing ->	-- Not there; it must be that the interface file wasn't found;
			-- the error will have been reported already.
			-- (Actually loadInterface should put the empty export env in there
			--  anyway, but this does no harm.)
		      returnRn ([],[])

	Just stuff -> returnRn stuff
  where
sof's avatar
sof committed
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")]
\end{code}


%*********************************************************
%*							*
\subsection{Data type declarations are handled specially}
%*							*
%*********************************************************

Data type declarations get special treatment.  If we import a data type decl
with all its constructors, we end up importing all the types mentioned in 
the constructors' signatures, and hence {\em their} data type decls, and so on.
In effect, we get the transitive closure of data type decls.  Worse, this drags
in tons on instance decls, and their unfoldings, and so on.
558

sof's avatar
sof committed
559
560
561
If only the type constructor is mentioned, then all this is a waste of time.
If any of the data constructors are mentioned then we really have to 
drag in the whole declaration.
562

sof's avatar
sof committed
563
564
565
566
567
568
569
570
571
572
573
So when we import the type constructor for a @data@ or @newtype@ decl, we
put it in the "deferred data/newtype decl" pile in Ifaces.  Right at the end
we slurp these decls, if they havn't already been dragged in by an occurrence
of a constructor.

\begin{code}
getNonWiredDataDecl needed_name 
		    version
	 	    avail@(AvailTC tycon_name _) 
		    ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
  |  needed_name == tycon_name
sof's avatar
sof committed
574
  && opt_PruneTyDecls
sof's avatar
sof committed
575
576
577
578
579
580
581
582
583
584
585
586
587
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
626
627
628
  && not (nameUnique needed_name `elem` cCallishTyKeys)		-- Hack!  Don't prune these tycons whose constructors
								-- the desugarer must be able to see when desugaring
								-- a CCall.  Ugh!
  = 	-- Need the type constructor; so put it in the deferred set for now
    getIfacesRn 		`thenRn` \ ifaces ->
    let
	Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
	new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods

	no_constr_ty_decl       = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc
	new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl
		-- Nota bene: we nuke both the constructors and the context in the deferred decl.
		-- If we don't nuke the context then renaming the deferred data decls can give
		-- new unresolved names (for the classes).  This could be handled, but there's
		-- no point.  If the data type is completely abstract then we aren't interested
		-- its context.
    in
    setIfacesRn new_ifaces	`thenRn_`
    returnRn (AvailTC tycon_name [tycon_name], Nothing)

  | otherwise
  = 	-- Need a data constructor, so delete the data decl from the deferred set if it's there
    getIfacesRn 		`thenRn` \ ifaces ->
    let
	Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
	new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods

	new_deferred_data_decls = delFromFM deferred_data_decls tycon_name
    in
    setIfacesRn new_ifaces	`thenRn_`
    returnRn (avail, Just (TyD ty_decl))
\end{code}

\begin{code}
getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
getDeferredDataDecls 
  = getIfacesRn 		`thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) ->
    let
	deferred_list = fmToList deferred_data_decls
	trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
			4 (ppr PprDebug (map fst deferred_list))
    in
    traceRn trace_msg			`thenRn_`
    returnRn deferred_list
\end{code}


%*********************************************************
%*							*
\subsection{Instance declarations are handled specially}
%*							*
%*********************************************************

\begin{code}
629
getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
630
631
632
633
getImportedInstDecls
  = 	-- First load any special-instance modules that aren't aready loaded
    getSpecialInstModules 			`thenRn` \ inst_mods ->
    mapRn load_it inst_mods			`thenRn_`
634

635
	-- Now we're ready to grab the instance declarations
636
637
638
	-- Find the un-gated ones and return them, 
	-- removing them from the bag kept in Ifaces
    getIfacesRn 	`thenRn` \ ifaces ->
639
    let
sof's avatar
sof committed
640
	Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655

		-- An instance decl is ungated if all its gates have been slurped
        select_ungated :: IfaceInst					-- A gated inst decl

		       -> ([(Module, RdrNameInstDecl)], [IfaceInst])	-- Accumulator

		       -> ([(Module, RdrNameInstDecl)], 		-- The ungated ones
			   [IfaceInst]) 				-- Still gated, but with
									-- depeleted gates
	select_ungated (decl,gates) (ungated_decls, gated_decls)
	  | null remaining_gates
	  = (decl : ungated_decls, gated_decls)
	  | otherwise
	  = (ungated_decls, (decl, remaining_gates) : gated_decls)
	  where
sof's avatar
sof committed
656
	    remaining_gates = filter (not . (`elemNameSet` tycls_names)) gates
657
658
659
660

	(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
	
	new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
sof's avatar
sof committed
661
662
			    ((listToBag still_gated_insts), tycls_names)
				-- NB: don't throw away tycls_names; we may comre across more instance decls
sof's avatar
sof committed
663
			    deferred_data_decls 
664
			    inst_mods
665
    in
sof's avatar
sof committed
666
    traceRn (sep [text "getInstDecls:", fsep (map (ppr PprDebug) (nameSetToList tycls_names))])	`thenRn_`
667
668
    setIfacesRn new_ifaces	`thenRn_`
    returnRn un_gated_insts
669
  where
670
    load_it mod = loadInterface (doc_str mod) mod
sof's avatar
sof committed
671
    doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
672

673
674
675
676
677

getSpecialInstModules :: RnMG [Module]
getSpecialInstModules 
  = getIfacesRn						`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
678
	 Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
679
680
    in
    returnRn inst_mods
681
682
\end{code}

sof's avatar
sof committed
683
684
685
686
687
688
689

%*********************************************************
%*							*
\subsection{Keeping track of what we've slurped, and version numbers}
%*							*
%*********************************************************

690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
getImportVersions figures out what the "usage information" for this moudule is;
that is, what it must record in its interface file as the things it uses.
It records:
	- anything reachable from its body code
	- any module exported with a "module Foo".

Why the latter?  Because if Foo changes then this module's export list
will change, so we must recompile this module at least as far as
making a new interface file --- but in practice that means complete
recompilation.

What about this? 
	module A( f, g ) where		module B( f ) where
	  import B( f )			  f = h 3
	  g = ...			  h = ...

Should we record B.f in A's usages?  In fact we don't.  Certainly, if
anything about B.f changes than anyone who imports A should be recompiled;
they'll get an early exit if they don't use B.f.  However, even if B.f
doesn't change at all, B.h may do so, and this change may not be reflected
in f's version number.  So there are two things going on when compiling module A:

1.  Are A.o and A.hi correct?  Then we can bale out early.
2.  Should modules that import A be recompiled?

For (1) it is slightly harmful to record B.f in A's usages, because a change in
B.f's version will provoke full recompilation of A, producing an identical A.o,
and A.hi differing only in its usage-version of B.f (which isn't used by any importer).

For (2), because of the tricky B.h question above, we ensure that A.hi is touched
(even if identical to its previous version) if A's recompilation was triggered by
an imported .hi file date change.  Given that, there's no need to record B.f in
A's usages.

On the other hand, if A exports "module B" then we *do* count module B among
A's usages, because we must recompile A to ensure that A.hi changes appropriately.

727
\begin{code}
728
729
getImportVersions :: Module			-- Name of this module
		  -> Maybe [IE any]		-- Export list for this module
730
		  -> RnMG (VersionInfo Name)	-- Version info for these names
731

732
getImportVersions this_mod exports
733
734
  = getIfacesRn					`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
735
	 Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
736
737
738
739
740
741
742
743
744
745
746
	 mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)

	 -- mv_map groups together all the things imported from a particular module.
	 mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name]

	 mv_map_mod = foldl add_mod emptyFM export_mods
		-- mv_map_mod records all the modules that have a "module M"
		-- in this module's export list

	 mv_map = foldl add_mv mv_map_mod imp_names
		-- mv_map adds the version numbers of things exported individually
747
    in
748
749
750
751
752
753
754
755
756
757
758
759
    returnRn [ (mod, mod_version mod, local_versions)
	     | (mod, local_versions) <- fmToList mv_map
	     ]

  where
     export_mods = case exports of
			Nothing -> []
			Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod]

     add_mv mv_map v@(name, version) 
      = addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v] 
	where
sof's avatar
sof committed
760
	 mod = nameModule name
761
762

     add_mod mv_map mod = addToFM mv_map mod []
763
\end{code}
764

sof's avatar
sof committed
765
766
767
768
769
770
771
772
773
774
775
776
777
\begin{code}
checkSlurped name
  = getIfacesRn 	`thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) ->
    returnRn (name `elemNameSet` slurped_names)

getSlurpedNames :: RnMG NameSet
getSlurpedNames
  = getIfacesRn 	`thenRn` \ ifaces ->
    let
	 Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces
    in
    returnRn slurped_names

sof's avatar
sof committed
778
779
780
781
782
recordSlurp maybe_version necessity avail
  = traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail, 
					-- NB PprForDebug prints export flag, which is too
					-- strict; it's a knot-tied thing in RnNames
		  case necessity of {Compulsory -> text "comp"; Optional -> text "opt"}])	`thenRn_`
sof's avatar
sof committed
783
784
    getIfacesRn 	`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
785
	Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
sof's avatar
sof committed
786
787
788
	new_slurped_names = addAvailToNameSet slurped_names avail

	new_imp_names = case maybe_version of
sof's avatar
sof committed
789
			   Just version	-> (availName avail, version) : imp_names
sof's avatar
sof committed
790
791
			   Nothing      -> imp_names

sof's avatar
sof committed
792
793
794
795
796
797
798
799
800
		-- Add to the names that will let in instance declarations;
		-- but only (a) if it's a type/class
		--	    (b) if it's compulsory (unless the test flag opt_PruneInstDecls is off)
	new_tycls_names = case avail of
				AvailTC tc _  | not opt_PruneInstDecls || 
						case necessity of {Optional -> False; Compulsory -> True }
					      -> tycls_names `addOneToNameSet` tc
				otherwise     -> tycls_names

sof's avatar
sof committed
801
802
803
	new_ifaces = Ifaces this_mod mod_vers export_envs decls 
			    new_slurped_names 
			    new_imp_names
sof's avatar
sof committed
804
			    (insts, new_tycls_names)
sof's avatar
sof committed
805
806
807
808
809
810
811
			    deferred_data_decls 
			    inst_mods
    in
    setIfacesRn new_ifaces
\end{code}


812
813
814
815
816
817
818
819
820
821
822
823
824
%*********************************************************
%*							*
\subsection{Getting binders out of a declaration}
%*							*
%*********************************************************

@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
It's used for both source code (from @availsFromDecl@) and interface files
(from @loadDecl@).

It doesn't deal with source-code specific things: ValD, DefD.  They
are handled by the sourc-code specific stuff in RnNames.

825
\begin{code}
826
827
828
getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)		-- New-name function
		-> RdrNameHsDecl
		-> RnMG AvailInfo
829

sof's avatar
sof committed
830
getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc))
831
832
  = new_name tycon src_loc			`thenRn` \ tycon_name ->
    getConFieldNames new_name condecls		`thenRn` \ sub_names ->
sof's avatar
sof committed
833
834
835
    returnRn (AvailTC tycon_name (tycon_name : nub sub_names))
	-- The "nub" is because getConFieldNames can legitimately return duplicates,
	-- when a record declaration has the same field in multiple constructors
836

837
838
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
  = new_name tycon src_loc		`thenRn` \ tycon_name ->
sof's avatar
sof committed
839
    returnRn (AvailTC tycon_name [tycon_name])
840
841
842
843

getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
  = new_name cname src_loc			`thenRn` \ class_name ->
    mapRn (getClassOpNames new_name) sigs	`thenRn` \ sub_names ->
844
    returnRn (AvailTC class_name (class_name : sub_names))
845
846
847

getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
  = new_name var src_loc			`thenRn` \ var_name ->
848
    returnRn (Avail var_name)
849
850
851
852
853

getDeclBinders new_name (DefD _)  = returnRn NotAvailable
getDeclBinders new_name (InstD _) = returnRn NotAvailable

----------------
sof's avatar
sof committed
854
getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest)
855
856
857
  = mapRn (\n -> new_name n src_loc) (con:fields)	`thenRn` \ cfs ->
    getConFieldNames new_name rest			`thenRn` \ ns  -> 
    returnRn (cfs ++ ns)
858
  where
859
860
    fields = concat (map fst fielddecls)

sof's avatar
sof committed
861
862
863
864
865
getConFieldNames new_name (ConDecl con _ _ src_loc : rest)
  = new_name con src_loc		`thenRn` \ n ->
    getConFieldNames new_name rest	`thenRn` \ ns -> 
    returnRn (n:ns)

866
getConFieldNames new_name [] = returnRn []
867

868
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
869
870
871
\end{code}


872
873
874
875
876
877
%*********************************************************
%*							*
\subsection{Reading an interface file}
%*							*
%*********************************************************

878
\begin{code}
sof's avatar
sof committed
879
findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
880
881
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
sof's avatar
sof committed
882
findAndReadIface doc_str filename
883
884
885
886
  = traceRn trace_msg			`thenRn_`
    getSearchPathRn			`thenRn` \ dirs ->
    try dirs dirs
  where
sof's avatar
sof committed
887
888
889
890
891
    trace_msg = hang (hcat [ptext SLIT("Reading interface for "), 
				   ptext filename, semi])
		     4 (hcat [ptext SLIT("reason: "), doc_str])

    try all_dirs [] = traceRn (ptext SLIT("...failed"))	`thenRn_`
892
893
		      returnRn Nothing

sof's avatar
sof committed
894
    try all_dirs ((dir,hisuf):dirs)
895
896
897
	= readIface file_path	`thenRn` \ read_result ->
	  case read_result of
		Nothing    -> try all_dirs dirs
sof's avatar
sof committed
898
		Just iface -> traceRn (ptext SLIT("...done"))	`thenRn_`
899
900
			      returnRn (Just iface)
	where
sof's avatar
sof committed
901
	  file_path = dir ++ "/" ++ moduleString filename ++ hisuf
902
\end{code}
903

904
@readIface@ trys just one file.
905

906
907
908
909
910
\begin{code}
readIface :: String -> RnMG (Maybe ParsedIface)	
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
readIface file_path
911
912
  = ioToRnMG (hGetStringBuffer file_path)  	`thenRn` \ read_result ->
--OLD:  = ioToRnMG (readFile file_path)  	`thenRn` \ read_result ->
913
914
    case read_result of
	Right contents	  -> case parseIface contents of
915
916
917
918
				Failed err      -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ -> 
					           failWithRn Nothing err 
				Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ ->
						   returnRn (Just iface)
919

sof's avatar
sof committed
920
921
922
923
924
925
926
#if __GLASGOW_HASKELL__ >= 202 
        Left err ->
	  if isDoesNotExistError err then
	     returnRn Nothing
	  else
	     failWithRn Nothing (cannaeReadFile file_path err)
#else /* 2.01 and 0.2x */
927
	Left  (NoSuchThing _) -> returnRn Nothing
928

929
930
	Left  err	      -> failWithRn Nothing
					    (cannaeReadFile file_path err)
sof's avatar
sof committed
931
#endif
932
933
934

\end{code}

sof's avatar
sof committed
935
936
mkSearchPath takes a string consisting of a colon-separated list of directories and corresponding
suffixes, and turns it into a list of (directory, suffix) pairs.  For example:
937

sof's avatar
sof committed
938
939
940
\begin{verbatim}
 mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")]
\begin{verbatim}
941
942
943

\begin{code}
mkSearchPath :: Maybe String -> SearchPath
sof's avatar
sof committed
944
mkSearchPath Nothing = [(".",".hi")]
945
946
947
mkSearchPath (Just s)
  = go s
  where
sof's avatar
sof committed
948
    go "" = []
sof's avatar
sof committed
949
950
951
952
953
954
    go s  = 
      case span (/= '%') s of
       (dir,'%':rs) ->
         case span (/= ':') rs of
          (hisuf,_:rest) -> (dir,hisuf):go rest
          (hisuf,[])     -> [(dir,hisuf)]
955
\end{code}
956

957
958
959
960
961
%*********************************************************
%*							*
\subsection{Errors}
%*							*
%*********************************************************
962

963
\begin{code}
sof's avatar
sof committed
964
965
966
noIfaceErr filename sty
  = hcat [ptext SLIT("Could not find valid interface file "), quotes (pprModule sty filename)]
--	, text " in"]) 4 (vcat (map text dirs))
967

968
cannaeReadFile file err sty
sof's avatar
sof committed
969
  = hcat [ptext SLIT("Failed in reading file: "), text file, ptext SLIT("; error="), text (show err)]
970
971

getDeclErr name sty
sof's avatar
sof committed
972
  = sep [ptext SLIT("Failed to find interface decl for"), ppr sty name]
973
974

getDeclWarn name sty
sof's avatar
sof committed
975
  = sep [ptext SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name]
976
\end{code}