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

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

76
77


sof's avatar
sof committed
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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
%*********************************************************
%*							*
\subsection{Statistics}
%*							*
%*********************************************************

\begin{code}
getRnStats :: [RenamedHsDecl] -> RnMG Doc
getRnStats all_decls
  = getIfacesRn 		`thenRn` \ ifaces ->
    let
	Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
	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}    

155
156
157
158
159
%*********************************************************
%*							*
\subsection{Loading a new interface file}
%*							*
%*********************************************************
160

161
\begin{code}
sof's avatar
sof committed
162
loadInterface :: Doc -> Module -> RnMG Ifaces
163
164
loadInterface doc_str load_mod 
  = getIfacesRn 		`thenRn` \ ifaces ->
165
    let
sof's avatar
sof committed
166
	Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts deferred_data_decls inst_mods = ifaces
167
    in
168
	-- CHECK WHETHER WE HAVE IT ALREADY
169
    if maybeToBool (lookupFM export_envs load_mod) 
170
171
172
173
174
175
176
177
178
179
180
    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
181
182
183
			new_export_envs = addToFM export_envs load_mod ([],[])
			new_ifaces = Ifaces this_mod mod_vers_map
					    new_export_envs
sof's avatar
sof committed
184
					    decls all_names imp_names insts deferred_data_decls inst_mods
185
186
187
188
189
		   in
		   setIfacesRn new_ifaces		`thenRn_`
		   failWithRn new_ifaces (noIfaceErr load_mod) ;

	-- Found and parsed!
190
	Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
191
192

	-- LOAD IT INTO Ifaces
193
194
195
    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 ->
196
    let
197
	 export_env = (concat avails_s, fixs)
198
199
200
201
202
203

			-- 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)
204
205
206
207
			     (addToFM export_envs load_mod export_env)
			     new_decls
			     all_names imp_names
			     new_insts
sof's avatar
sof committed
208
			     deferred_data_decls 
209
			     new_inst_mods 
210
    in
211
212
213
214
    setIfacesRn new_ifaces		`thenRn_`
    returnRn new_ifaces
    }

215
216
217
loadExport :: ExportItem -> RnMG [AvailInfo]
loadExport (mod, entities)
  = mapRn load_entity entities
218
219
220
  where
    new_name occ = newGlobalName mod occ

221
222
223
224
225
-- 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, [])

226
227
    load_entity (occ, occs)
      =	new_name occ 		`thenRn` \ name ->
228
229
230
231
232
	if null occs then
		returnRn (Avail name)
	else
	        mapRn new_name occs 	`thenRn` \ names ->
	        returnRn (AvailTC name names)
233

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

245
246
247
248
loadInstDecl :: Module
	     -> Bag IfaceInst
	     -> RdrNameInstDecl
	     -> RnMG (Bag IfaceInst)
249
loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
250
251
252
253
254
255
256
257
  = 
	-- 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 ...
258
	--
259
260
261
262
263
264
265
266
267
268
	-- 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.
    initRnMS emptyRnEnv mod_name InterfaceMode (
sof's avatar
sof committed
269
        findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)	
270
271
    )						`thenRn` \ gate_names ->
    returnRn (((mod_name, decl), gate_names) `consBag` insts)
272
\end{code}
273

274

275
276
277
278
279
280
281
282
283
284
%********************************************************
%*							*
\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 ->
285
    case read_result of
286
	Nothing -> 	-- Old interface file not found, so we'd better bail out
sof's avatar
sof committed
287
		    traceRn (sep [ptext SLIT("Didnt find old iface"), 
288
				    pprModule PprDebug mod_name])	`thenRn_`
289
290
291
292
293
		    returnRn False

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

298
checkModUsage [] = returnRn True		-- Yes!  Everything is up to date!
299

300
301
302
checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
  = loadInterface doc_str mod		`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
303
	Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
304
	maybe_new_mod_vers = lookupFM mod_vers mod
305
	Just new_mod_vers  = maybe_new_mod_vers
306
    in
307
	-- If we can't find a version number for the old module then
308
	-- bail out saying things aren't up to date
309
310
311
312
313
314
    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
315
	traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod])	`thenRn_`
316
317
	checkModUsage rest
    else
sof's avatar
sof committed
318
    traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod])	`thenRn_`
319

320
	-- New module version, so check entities inside
321
    checkEntityUsage mod decls old_local_vers	`thenRn` \ up_to_date ->
322
    if up_to_date then
sof's avatar
sof committed
323
	traceRn (ptext SLIT("...but the bits I use haven't."))	`thenRn_`
324
325
326
327
	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
328
    doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod]
329
330


331
checkEntityUsage mod decls [] 
332
333
  = returnRn True	-- Yes!  All up to date!

334
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
335
  = newGlobalName mod occ_name		`thenRn` \ name ->
336
    case lookupFM decls name of
337
338

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

342
343
344
345
346
347
348
	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
349
		-> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name])  `thenRn_`
350
		   returnRn False
351
352
353
\end{code}


354
355
356
357
358
%*********************************************************
%*							*
\subsection{Getting in a declaration}
%*							*
%*********************************************************
359

360
\begin{code}
361
362
363
364
365
366
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
367
	-- traceRn (sep [text "Already slurped:", ppr PprDebug name])	`thenRn_`
368
369
370
371
372
373
374
	returnRn Nothing	-- Already dealt with
    else
    if isWiredInName name then
	getWiredInDecl name
    else 
       getIfacesRn 		`thenRn` \ ifaces ->
       let
sof's avatar
sof committed
375
         Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
376
377
378
379
380
381
382
383
384
         (mod,_) = modAndOcc name
       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}
385

386
387
\begin{code}
getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
sof's avatar
sof committed
388
getNonWiredInDecl needed_name necessity
389
  = traceRn doc_str 			`thenRn_`
sof's avatar
sof committed
390
391
392
393
394
395
396
397
    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) ->
		 recordSlurp (Just version) avail'	`thenRn_`
		 returnRn maybe_decl
398

sof's avatar
sof committed
399
400
401
      Just (version,avail,decl)
	      -> recordSlurp (Just version) avail	`thenRn_`
		 returnRn (Just decl)
402
403
404

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

     is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
     is_data_or_newtype other		         = False
415
416
\end{code}

417
418
419
@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,
420

421
422
423
  *	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.
424

425
  * 	similarly for synonum type constructor
426

427
428
  * 	if the wired-in name is another wired-in Id, it marks as "occurrences"
	the free vars of the Id's type.
429

430
431
  *	it loads the interface file for the wired-in thing for the
	sole purpose of making sure that its instance declarations are available
432

433
434
435
436
437
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}
getWiredInDecl name
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
  = get_wired				`thenRn` \ avail ->
    recordSlurp Nothing avail		`thenRn_`

   	-- 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 }
	(mod,_)    = modAndOcc main_name
sof's avatar
sof committed
463
	doc_str    = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
464
465
466
    in
    (if not main_is_tc || mod == gHC__ then
	returnRn ()		
467
468
469
    else
	loadInterface doc_str mod	`thenRn_`
	returnRn ()
470
471
472
    )				 	`thenRn_`

    returnRn Nothing		-- No declaration to process further
473
474
  where

475
476
477
478
479
480
481
482
483
    get_wired | is_tycon			-- ... a type constructor
	      = get_wired_tycon the_tycon

	      | (isDataCon the_id) 		-- ... a wired-in data constructor
	      = get_wired_tycon (dataConTyCon the_id)

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

484
485
486
487
488
489
    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

490

491
492
get_wired_id id
  = addImplicitOccsRn (nameSetToList id_mentioned)	`thenRn_`
493
    returnRn (Avail (getName id))
494
  where
495
    id_mentioned = namesOfType (idType id)
496

497
498
499
get_wired_tycon tycon 
  | isSynTyCon tycon
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
sof's avatar
sof committed
500
    returnRn (AvailTC tc_name [tc_name])
501
  where
sof's avatar
sof committed
502
    tc_name     = getName tycon
503
    (tyvars,ty) = getSynTyConDefn tycon
sof's avatar
sof committed
504
    mentioned   = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
505

506
507
508
get_wired_tycon tycon 
  | otherwise		-- data or newtype
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
509
    returnRn (AvailTC tycon_name (tycon_name : map getName data_cons))
510
  where
511
512
513
    tycon_name = getName tycon
    data_cons  = tyConDataCons tycon
    mentioned  = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
514
515
516
\end{code}


517
    
518
519
%*********************************************************
%*							*
sof's avatar
sof committed
520
\subsection{Getting what a module exports}
521
522
%*							*
%*********************************************************
523
524

\begin{code}
525
526
getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod
sof's avatar
sof committed
527
  = loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
528
529
530
531
532
533
534
535
536
    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
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
    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.
552

sof's avatar
sof committed
553
554
555
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.
556

sof's avatar
sof committed
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
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
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
  && opt_TyConPruning
  && 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}
623
getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
624
625
626
627
getImportedInstDecls
  = 	-- First load any special-instance modules that aren't aready loaded
    getSpecialInstModules 			`thenRn` \ inst_mods ->
    mapRn load_it inst_mods			`thenRn_`
628

629
	-- Now we're ready to grab the instance declarations
630
631
632
	-- Find the un-gated ones and return them, 
	-- removing them from the bag kept in Ifaces
    getIfacesRn 	`thenRn` \ ifaces ->
633
    let
sof's avatar
sof committed
634
	Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
635
636
637
638
639
640
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
	    remaining_gates = filter (not . (`elemNameSet` slurped_names)) gates

	(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
	
	new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
			    (listToBag still_gated_insts)
sof's avatar
sof committed
656
			    deferred_data_decls 
657
			    inst_mods
658
    in
659
660
    setIfacesRn new_ifaces	`thenRn_`
    returnRn un_gated_insts
661
  where
662
    load_it mod = loadInterface (doc_str mod) mod
sof's avatar
sof committed
663
    doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
664

665
666
667
668
669

getSpecialInstModules :: RnMG [Module]
getSpecialInstModules 
  = getIfacesRn						`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
670
	 Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
671
672
    in
    returnRn inst_mods
673
674
\end{code}

sof's avatar
sof committed
675
676
677
678
679
680
681

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

682
683
684
685
686
687
688
689
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
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.

719
\begin{code}
720
721
getImportVersions :: Module			-- Name of this module
		  -> Maybe [IE any]		-- Export list for this module
722
		  -> RnMG (VersionInfo Name)	-- Version info for these names
723

724
getImportVersions this_mod exports
725
726
  = getIfacesRn					`thenRn` \ ifaces ->
    let
sof's avatar
sof committed
727
	 Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
728
729
730
731
732
733
734
735
736
737
738
	 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
739
    in
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
    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
	 (mod,_) = modAndOcc name

     add_mod mv_map mod = addToFM mv_map mod []
755
\end{code}
756

sof's avatar
sof committed
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
\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

recordSlurp maybe_version avail
  = -- traceRn (sep [text "Record slurp:", pprAvail PprDebug avail])	`thenRn_`
    getIfacesRn 	`thenRn` \ ifaces ->
    let
	Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
	new_slurped_names = addAvailToNameSet slurped_names avail

	new_imp_names = case maybe_version of
			   Just version -> (availName avail, version) : imp_names
			   Nothing      -> imp_names

	new_ifaces = Ifaces this_mod mod_vers export_envs decls 
			    new_slurped_names 
			    new_imp_names
			    insts
			    deferred_data_decls 
			    inst_mods
    in
    setIfacesRn new_ifaces
\end{code}


792
793
794
795
796
797
798
799
800
801
802
803
804
%*********************************************************
%*							*
\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.

805
\begin{code}
806
807
808
getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)		-- New-name function
		-> RdrNameHsDecl
		-> RnMG AvailInfo
809

sof's avatar
sof committed
810
getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc))
811
812
  = new_name tycon src_loc			`thenRn` \ tycon_name ->
    getConFieldNames new_name condecls		`thenRn` \ sub_names ->
813
    returnRn (AvailTC tycon_name (tycon_name : sub_names))
814

815
816
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
  = new_name tycon src_loc		`thenRn` \ tycon_name ->
sof's avatar
sof committed
817
    returnRn (AvailTC tycon_name [tycon_name])
818
819
820
821

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 ->
822
    returnRn (AvailTC class_name (class_name : sub_names))
823
824
825

getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
  = new_name var src_loc			`thenRn` \ var_name ->
826
    returnRn (Avail var_name)
827
828
829
830
831

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

----------------
sof's avatar
sof committed
832
getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest)
833
834
835
  = mapRn (\n -> new_name n src_loc) (con:fields)	`thenRn` \ cfs ->
    getConFieldNames new_name rest			`thenRn` \ ns  -> 
    returnRn (cfs ++ ns)
836
  where
837
838
    fields = concat (map fst fielddecls)

sof's avatar
sof committed
839
840
841
842
843
getConFieldNames new_name (ConDecl con _ _ src_loc : rest)
  = new_name con src_loc		`thenRn` \ n ->
    getConFieldNames new_name rest	`thenRn` \ ns -> 
    returnRn (n:ns)

844
getConFieldNames new_name [] = returnRn []
845

846
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
847
848
849
\end{code}


850
851
852
853
854
855
%*********************************************************
%*							*
\subsection{Reading an interface file}
%*							*
%*********************************************************

856
\begin{code}
sof's avatar
sof committed
857
findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
858
859
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
sof's avatar
sof committed
860
findAndReadIface doc_str filename
861
862
863
864
  = traceRn trace_msg			`thenRn_`
    getSearchPathRn			`thenRn` \ dirs ->
    try dirs dirs
  where
sof's avatar
sof committed
865
866
867
868
869
    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_`
870
871
		      returnRn Nothing

sof's avatar
sof committed
872
    try all_dirs ((dir,hisuf):dirs)
873
874
875
	= readIface file_path	`thenRn` \ read_result ->
	  case read_result of
		Nothing    -> try all_dirs dirs
sof's avatar
sof committed
876
		Just iface -> traceRn (ptext SLIT("...done"))	`thenRn_`
877
878
			      returnRn (Just iface)
	where
sof's avatar
sof committed
879
	  file_path = dir ++ "/" ++ moduleString filename ++ hisuf
880
\end{code}
881

882
@readIface@ trys just one file.
883

884
885
886
887
888
\begin{code}
readIface :: String -> RnMG (Maybe ParsedIface)	
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
readIface file_path
889
890
  = ioToRnMG (hGetStringBuffer file_path)  	`thenRn` \ read_result ->
--OLD:  = ioToRnMG (readFile file_path)  	`thenRn` \ read_result ->
891
892
    case read_result of
	Right contents	  -> case parseIface contents of
893
894
895
896
				Failed err      -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ -> 
					           failWithRn Nothing err 
				Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ ->
						   returnRn (Just iface)
897

sof's avatar
sof committed
898
899
900
901
902
903
904
#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 */
905
	Left  (NoSuchThing _) -> returnRn Nothing
906

907
908
	Left  err	      -> failWithRn Nothing
					    (cannaeReadFile file_path err)
sof's avatar
sof committed
909
#endif
910
911
912

\end{code}

sof's avatar
sof committed
913
914
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:
915

sof's avatar
sof committed
916
917
918
\begin{verbatim}
 mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")]
\begin{verbatim}
919
920
921

\begin{code}
mkSearchPath :: Maybe String -> SearchPath
sof's avatar
sof committed
922
mkSearchPath Nothing = [(".",".hi")]
923
924
925
mkSearchPath (Just s)
  = go s
  where
sof's avatar
sof committed
926
    go "" = []
sof's avatar
sof committed
927
928
929
930
931
932
    go s  = 
      case span (/= '%') s of
       (dir,'%':rs) ->
         case span (/= ':') rs of
          (hisuf,_:rest) -> (dir,hisuf):go rest
          (hisuf,[])     -> [(dir,hisuf)]
933
\end{code}
934

935
936
937
938
939
%*********************************************************
%*							*
\subsection{Errors}
%*							*
%*********************************************************
940

941
\begin{code}
sof's avatar
sof committed
942
943
944
noIfaceErr filename sty
  = hcat [ptext SLIT("Could not find valid interface file "), quotes (pprModule sty filename)]
--	, text " in"]) 4 (vcat (map text dirs))
945

946
cannaeReadFile file err sty
sof's avatar
sof committed
947
  = hcat [ptext SLIT("Failed in reading file: "), text file, ptext SLIT("; error="), text (show err)]
948
949

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

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