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

\begin{code}
7
module RnIfaces
8
     (
9
	getInterfaceExports,
10
11
12
	recordLocalSlurps, 
	mkImportInfo, 

13
	slurpImpDecls, closeDecls,
14

15
	RecompileRequired, outOfDate, upToDate, recompileRequired
16
17
       )
where
18

19
#include "HsVersions.h"
20

21
import CmdLineOpts	( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
22
import HscTypes
23
24
25
import HsSyn		( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
			  InstDecl(..), HsType(..), hsTyVarNames, getBangType
			)
26
import HsImpExp		( ImportDecl(..) )
27
import RdrHsSyn		( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl )
28
import RnHsSyn		( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames, tyClDeclFVs )
29
30
31
import RnHiFiles	( tryLoadInterface, loadHomeInterface, loadInterface, 
			  loadOrphanModules
			)
32
import RnSource		( rnTyClDecl, rnDecl )
33
import RnEnv
34
import RnMonad
35
36
37
import Id		( idType )
import Type		( namesOfType )
import TyCon		( isSynTyCon, getSynTyConDefn )
38
import Name		( Name {-instance NamedThing-}, nameOccName,
39
			  nameModule, isLocallyDefined, nameUnique,
40
			  NamedThing(..),
41
			  elemNameEnv
42
			 )
43
import Module		( Module, ModuleEnv,
44
			  moduleName, isModuleInThisPackage,
45
			  ModuleName, WhereFrom(..),
46
			  emptyModuleEnv, lookupModuleEnvByName,
47
			  extendModuleEnv_C, lookupWithDefaultModuleEnv
48
			)
49
import NameSet
50
51
import PrelInfo		( wiredInThingEnv, fractionalClassKeys )
import TysWiredIn	( doubleTyCon )
52
import Maybes		( orElse )
53
import FiniteMap
sof's avatar
sof committed
54
import Outputable
55
import Bag
56

57
import List		( nub )
58
59
\end{code}

60

61
62
%*********************************************************
%*							*
sof's avatar
sof committed
63
\subsection{Getting what a module exports}
64
65
%*							*
%*********************************************************
66

67
@getInterfaceExports@ is called only for directly-imported modules.
68

69
\begin{code}
70
getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)])
71
getInterfaceExports mod_name from
72
73
74
75
76
77
78
79
80
81
82
  = getHomeIfaceTableRn 		`thenRn` \ hit ->
    case lookupModuleEnvByName hit mod_name of {
	Just mi -> returnRn (mi_module mi, mi_exports mi) ;
        Nothing  -> 

    loadInterface doc_str mod_name from	`thenRn` \ ifaces ->
    case lookupModuleEnvByName (iPIT ifaces) mod_name of
	Just mi -> returnRn (mi_module mi, mi_exports mi) ;
		-- loadInterface always puts something in the map
		-- even if it's a fake
	Nothing -> pprPanic "getInterfaceExports" (ppr mod_name)
83
84
    }
    where
85
      doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")]
sof's avatar
sof committed
86
87
88
89
90
\end{code}


%*********************************************************
%*							*
91
\subsection{Instance declarations are handled specially}
sof's avatar
sof committed
92
93
94
95
%*							*
%*********************************************************

\begin{code}
96
97
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
98
  =    	-- First, load any orphan-instance modules that aren't aready loaded
99
	-- Orphan-instance modules are recorded in the module dependecnies
100
    getIfacesRn 					`thenRn` \ ifaces ->
sof's avatar
sof committed
101
    let
102
	orphan_mods =
103
	  [mod | (mod, (True, _, False)) <- fmToList (iImpModInfo ifaces)]
sof's avatar
sof committed
104
    in
105
    loadOrphanModules orphan_mods			`thenRn_` 
106

107
	-- Now we're ready to grab the instance declarations
108
109
	-- Find the un-gated ones and return them, 
	-- removing them from the bag kept in Ifaces
110
    getIfacesRn 					`thenRn` \ ifaces ->
111
    let
112
113
114
	(decls, new_insts) = selectGated gates (iInsts ifaces)
    in
    setIfacesRn (ifaces { iInsts = new_insts })		`thenRn_`
115

116
    traceRn (sep [text "getImportedInstDecls:", 
117
		  nest 4 (fsep (map ppr gate_list)),
118
119
		  text "Slurped" <+> int (length decls) <+> text "instance declarations",
		  nest 4 (vcat (map ppr_brief_inst_decl decls))])	`thenRn_`
120
121
    returnRn decls
  where
122
123
    gate_list      = nameSetToList gates

124
125
126
127
128
ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
  = case inst_ty of
	HsForAllTy _ _ tau -> ppr tau
	other		   -> ppr inst_ty

129
getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
130
131
132
getImportedRules 
  | opt_IgnoreIfacePragmas = returnRn []
  | otherwise
133
134
135
  = getIfacesRn 	`thenRn` \ ifaces ->
    let
	gates		   = iSlurp ifaces	-- Anything at all that's been slurped
136
137
	rules		   = iRules ifaces
	(decls, new_rules) = selectGated gates rules
138
    in
139
140
141
142
    if null decls then
	returnRn []
    else
    setIfacesRn (ifaces { iRules = new_rules })		     `thenRn_`
143
    traceRn (sep [text "getImportedRules:", 
144
		  text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
145
    returnRn decls
146

147
selectGated gates decl_bag
148
	-- Select only those decls whose gates are *all* in 'gates'
149
150
151
#ifdef DEBUG
  | opt_NoPruneDecls	-- Just to try the effect of not gating at all
  = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag)	-- Grab them all
152

153
154
155
  | otherwise
#endif
  = foldrBag select ([], emptyBag) decl_bag
156
  where
157
158
159
    select (reqd, decl) (yes, no)
	| isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
	| otherwise				     = (yes,      (reqd,decl) `consBag` no)
160
161
\end{code}

sof's avatar
sof committed
162
163
164
165
166
167
168

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

169
170
171
172
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:

173
\begin{itemize}
174
175
176
\item	(a) anything reachable from its body code
\item	(b) any module exported with a @module Foo@
\item   (c) anything reachable from an exported item
177
\end{itemize}
178
179

Why (b)?  Because if @Foo@ changes then this module's export list
180
181
182
183
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.

184
Why (c)?  Consider this:
185
186
187
188
189
\begin{verbatim}
	module A( f, g ) where	|	module B( f ) where
	  import B( f )		|	  f = h 3
	  g = ...		|	  h = ...
\end{verbatim}
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
Here, @B.f@ isn't used in A.  Should we nevertheless record @B.f@ in
@A@'s usages?  Our idea is that we aren't going to touch A.hi if it is
*identical* to what it was before.  If anything about @B.f@ changes
than anyone who imports @A@ should be recompiled in case they use
@B.f@ (they'll get an early exit if they don't).  So, if anything
about @B.f@ changes we'd better make sure that something in A.hi
changes, and the convenient way to do that is to record the version
number @B.f@ in A.hi in the usage list.  If B.f changes that'll force a
complete recompiation of A, which is overkill but it's the only way to 
write a new, slightly different, A.hi.

But the example is tricker.  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.  But with -O, a module that imports A must be recompiled if
@B.h@ changes!  So A must record a dependency on @B.h@.  So we treat
the occurrence of @B.f@ in the export list *just as if* it were in the
code of A, and thereby haul in all the stuff reachable from it.

[NB: If B was compiled with -O, but A isn't, we should really *still*
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O.  I think this is the case.]

Even if B is used at all we get a usage line for B
	import B <n> :: ... ;
215
216
217
218
in A.hi, to record the fact that A does import B.  This is used to decide
to look to look for B.hi rather than B.hi-boot when compiling a module that
imports A.  This line says that A imports B, but uses nothing in it.
So we'll get an early bale-out when compiling A if B's version changes.
219

220
\begin{code}
221
222
223
224
225
mkImportInfo :: ModuleName			-- Name of this module
	     -> [ImportDecl n]			-- The import decls
	     -> RnMG [ImportVersion Name]

mkImportInfo this_mod imports
226
  = getIfacesRn					`thenRn` \ ifaces ->
227
    getHomeIfaceTableRn				`thenRn` \ hit -> 
228
    let
229
230
231
	import_all_mods :: [ModuleName]
		-- Modules where we imported all the names
		-- (apart from hiding some, perhaps)
232
233
	import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports,
				    import_all imp_list ]
234
235
236

	import_all (Just (False, _)) = False	-- Imports are specified explicitly
	import_all other	     = True	-- Everything is imported
237

238
239
	mod_map   = iImpModInfo ifaces
	imp_names = iVSlurp     ifaces
240
	pit	  = iPIT 	ifaces
241

242
	-- mv_map groups together all the things imported from a particular module.
243
	mv_map :: ModuleEnv [Name]
244
	mv_map = foldr add_mv emptyModuleEnv imp_names
245

246
        add_mv name mv_map = addItem mv_map (nameModule name) name
247

248
	-- Build the result list by adding info for each module.
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
	-- For (a) a library module, we don't record it at all unless it contains orphans
	-- 	   (We must never lose track of orphans.)
	-- 
	--     (b) a source-imported module, don't record the dependency at all
	--	
	-- (b) may seem a bit strange.  The idea is that the usages in a .hi file records
	-- *all* the module's dependencies other than the loop-breakers.  We use
	-- this info in findAndReadInterface to decide whether to look for a .hi file or
	-- a .hi-boot file.  
	--
	-- This means we won't track version changes, or orphans, from .hi-boot files.
	-- The former is potentially rather bad news.  It could be fixed by recording
	-- whether something is a boot file along with the usage info for it, but 
	-- I can't be bothered just now.

264
	mk_imp_info mod_name (has_orphans, is_boot, opened) so_far
265
266
267
268
269
270
	   | mod_name == this_mod	-- Check if M appears in the set of modules 'below' M
					-- This seems like a convenient place to check
	   = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> 
			        ptext SLIT("imports itself (perhaps indirectly)") )
	     so_far
 
271
	   | not opened 		-- We didn't even open the interface
272
	   =		-- This happens when a module, Foo, that we explicitly imported has 
273
274
275
			-- 'import Baz' in its interface file, recording that Baz is below
			-- Foo in the module dependency hierarchy.  We want to propagate this
			-- information.  The Nothing says that we didn't even open the interface
276
			-- file but we must still propagate the dependency info.
277
			-- The module in question must be a local module (in the same package)
278
279
	     go_for_it NothingAtAll

280

281
	   | is_lib_module && not has_orphans
282
	   = so_far		
283
	   
284
	   | is_lib_module 			-- Record the module version only
285
	   = go_for_it (Everything module_vers)
286

287
	   | otherwise
288
	   = go_for_it whats_imported
289
290
291

	     where
		go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far
292
	        mod_iface 	  = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo"
293
294
295
296
		mod		  = mi_module mod_iface
	        is_lib_module     = not (isModuleInThisPackage mod)
	        version_info      = mi_version mod_iface
	        version_env       = vers_decls version_info
297
		module_vers	  = vers_module version_info
298

299
300
		whats_imported = Specifically module_vers
					      export_vers import_items 
301
302
303
					      (vers_rules version_info)

	        import_items = [(n,v) | n <- lookupWithDefaultModuleEnv mv_map [] mod,
304
				        let v = lookupNameEnv version_env n `orElse` 
305
306
					        pprPanic "mk_whats_imported" (ppr n)
			       ]
307
308
309
310
	        export_vers | moduleName mod `elem` import_all_mods 
			    = Just (vers_exports version_info)
			    | otherwise
			    = Nothing
311
	
312
	import_info = foldFM mk_imp_info [] mod_map
sof's avatar
sof committed
313
    in
314
    traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map)))	`thenRn_`
315
    returnRn import_info
316

317

318
addItem :: ModuleEnv [a] -> Module -> a -> ModuleEnv [a]
319
addItem fm mod x = extendModuleEnv_C add_item fm mod [x]
320
321
		 where
		   add_item xs _ = x:xs
322
\end{code}
323

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
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
416
417
418
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
%*********************************************************
%*						 	 *
\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 ->
    slurpSourceRefs source_binders source_fvs	`thenRn` \ (decls, needed) ->

	-- Then get everything else
    closeDecls decls needed			`thenRn` \ decls1 ->

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

    returnRn final_decls


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

slurpSourceRefs source_binders source_fvs
  = go_outer [] 			-- Accumulating decls
	     emptyFVs 			-- Unsatisfied needs
	     emptyFVs			-- Accumulating gates
  	     (nameSetToList source_fvs)	-- Things whose defn hasn't been loaded yet
  where
	-- 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_`
	  foldlRn go_inner (decls, fvs, emptyFVs) refs		`thenRn` \ (decls1, fvs1, gates1) ->
	  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))
		-- Knock out the all_gates because even if we don't slurp any new
		-- decls we can get some apparently-new gates from wired-in names

    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 -> rnIfaceTyClDecl decl		`thenRn` \ (new_decl, fvs1) ->
			     returnRn (TyClD new_decl : decls, 
				       fvs1 `plusFV` fvs,
			   	       gates `plusFV` getGates source_fvs new_decl)

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}


\begin{code}
-------------------------------------------------------
-- 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
  = importDecl wanted_name 		`thenRn` \ import_result ->
    case import_result of
	-- Found a declaration... rename it
	HereItIs decl -> rnIfaceTyClDecl decl		`thenRn` \ (new_decl, fvs1) ->
			 returnRn (TyClD 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)	
459
460
rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)	`thenRn` \ decl' ->
			      returnRn (decl', tyClDeclFVs decl')
461
462
463
\end{code}


sof's avatar
sof committed
464
\begin{code}
465
getSlurped
sof's avatar
sof committed
466
  = getIfacesRn 	`thenRn` \ ifaces ->
467
    returnRn (iSlurp ifaces)
sof's avatar
sof committed
468

469
recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names })
470
	    avail
471
  = let
sof's avatar
sof committed
472
	new_slurped_names = addAvailToNameSet slurped_names avail
473
	new_imp_names     = availName avail : imp_names
474
475
    in
    ifaces { iSlurp  = new_slurped_names, iVSlurp = new_imp_names }
sof's avatar
sof committed
476

477
478
479
480
recordLocalSlurps local_avails
  = getIfacesRn 	`thenRn` \ ifaces ->
    let
	new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails
sof's avatar
sof committed
481
    in
482
    setIfacesRn (ifaces { iSlurp  = new_slurped_names })
sof's avatar
sof committed
483
484
485
\end{code}


486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
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
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638

%*********************************************************
%*						 	 *
\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 = returnRn decls

{-	OMIT FOR NOW
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 name1 name2))
  = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
		name1 name2))
	-- Nuke the context and constructors
	-- But retain the *number* of constructors!
	-- Also the tvs will have kinds on them.
-}
\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 (IfaceSig _ ty _ _)
  = extractHsTyNames ty

getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
  = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
		        (hsTyVarNames tvs)
     `addOneToNameSet` cls)
    `plusFV` maybe_double
  where
    get (ClassOpSig n _ ty _) 
	| n `elemNameSet` source_fvs = extractHsTyNames ty
	| otherwise		     = emptyFVs

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

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

getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
  = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
		       (hsTyVarNames tvs)
    `addOneToNameSet` tycon
  where
    get (ConDecl n _ tvs ctxt details _)
	| n `elemNameSet` source_fvs
		-- If the constructor is method, get fvs from all its fields
	= delListFromNameSet (get_details details `plusFV` 
		  	      extractHsCtxtTyNames ctxt)
			     (hsTyVarNames tvs)
    get (ConDecl n _ tvs ctxt (RecCon fields) _)
		-- 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_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
		     | otherwise			 = emptyFVs

    get_bang bty = extractHsTyNames (getBangType bty)
\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
  = case lookupNameEnv wiredInThingEnv name of
	Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))

	Just (ATyCon tc)
	  |  isSynTyCon tc
	  -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
	  where
	     (tyvars,ty)  = getSynTyConDefn tc

	other -> unitFV name

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}


639
640
%*********************************************************
%*							*
641
\subsection{Getting in a declaration}
642
643
644
%*							*
%*********************************************************

645
646
\begin{code}
importDecl :: Name -> RnMG ImportDeclResult
647

648
649
650
651
data ImportDeclResult
  = AlreadySlurped
  | WiredIn	
  | Deferred
652
  | HereItIs (Module, RdrNameTyClDecl)
653

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
importDecl name
  = 	-- Check if it was loaded before beginning this module
    checkAlreadyAvailable name		`thenRn` \ done ->
    if done then
	returnRn AlreadySlurped
    else

	-- Check if we slurped it in while compiling this module
    getIfacesRn				`thenRn` \ ifaces ->
    if name `elemNameSet` iSlurp ifaces then	
	returnRn AlreadySlurped	
    else 

	-- Don't slurp in decls from this module's own interface file
	-- (Indeed, this shouldn't happen.)
    if isLocallyDefined name then
	addWarnRn (importDeclWarn name) `thenRn_`
	returnRn AlreadySlurped
    else

	-- When we find a wired-in name we must load its home
	-- module so that we find any instance decls lurking therein
    if name `elemNameEnv` wiredInThingEnv then
	loadHomeInterface doc name	`thenRn_`
	returnRn WiredIn
679

680
    else getNonWiredInDecl name
681
  where
682
    doc = ptext SLIT("need home module for wired in thing") <+> ppr name
683

684
685
686
687
688
getNonWiredInDecl :: Name -> RnMG ImportDeclResult
getNonWiredInDecl needed_name 
  = traceRn doc_str				`thenRn_`
    loadHomeInterface doc_str needed_name	`thenRn` \ ifaces ->
    case lookupNameEnv (iDecls ifaces) needed_name of
689

690
691
692
{- 		OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
      Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
	-- This case deals with deferred import of algebraic data types
693

694
695
696
697
698
699
700
701
702
703
704
	|  not opt_NoPruneTyDecls

	&& (opt_IgnoreIfacePragmas || ncons > 1)
		-- We only defer if imported interface pragmas are ingored
		-- or if it's not a product type.
		-- Sole reason: The wrapper for a strict function may need to look
		-- inside its arg, and hence need to see its arg type's constructors.

	&& not (getUnique tycon_name `elem` cCallishTyKeys)
		-- Never defer ccall types; we have to unbox them, 
		-- and importing them does no harm
705

706

707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
	->  	-- OK, so we're importing a deferrable data type
	    if needed_name == tycon_name
	 	-- The needed_name is the TyCon of a data type decl
		-- Record that it's slurped, put it in the deferred set
		-- and don't return a declaration at all
		setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces 
							      `addOneToNameSet` tycon_name})
				    	 version (AvailTC needed_name [needed_name]))	`thenRn_`
		returnRn Deferred

	    else
	  	-- The needed name is a constructor of a data type decl,
		-- getting a constructor, so remove the TyCon from the deferred set
		-- (if it's there) and return the full declaration
		setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces 
							       `delFromNameSet` tycon_name})
				    version avail)	`thenRn_`
		returnRn (HereItIs decl)
	where
	   tycon_name = availName avail
-}

      Just (avail,_,decl)
	-> setIfacesRn (recordSlurp ifaces avail)	`thenRn_`
	   returnRn (HereItIs decl)

      Nothing 
	-> addErrRn (getDeclErr needed_name)	`thenRn_` 
	   returnRn AlreadySlurped
  where
     doc_str = ptext SLIT("need decl for") <+> ppr needed_name

{-		OMIT FOR NOW
getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)]
getDeferredDecls 
  = getIfacesRn		`thenRn` \ ifaces ->
    let
	decls_map   	    = iDecls ifaces
	deferred_names	    = nameSetToList (iDeferred ifaces)
        get_abstract_decl n = case lookupNameEnv decls_map n of
				 Just (_, _, _, decl) -> decl
    in
    traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))])	`thenRn_`
    returnRn (map get_abstract_decl deferred_names)
-}
752
\end{code}
753

754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
@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,
\begin{itemize}
\item	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.

\item 	similarly for synonum type constructor

\item 	if the wired-in name is another wired-in Id, it marks as ``occurrences''
	the free vars of the Id's type.

\item	it loads the interface file for the wired-in thing for the
	sole purpose of making sure that its instance declarations are available
\end{itemize}
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.
	

%********************************************************
775
%*							*
776
\subsection{Checking usage information}
777
%*							*
778
%********************************************************
779

780
781
782
783
784
@recompileRequired@ is called from the HscMain.   It checks whether
a recompilation is required.  It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.

785
\begin{code}
786
787
788
789
type RecompileRequired = Bool
upToDate  = False	-- Recompile not required
outOfDate = True	-- Recompile required

790
recompileRequired :: Module 
791
792
		  -> Bool 		-- Source unchanged
		  -> Maybe ModIface 	-- Old interface, if any
793
794
795
		  -> RnMG RecompileRequired
recompileRequired mod source_unchanged maybe_iface
  = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon)	`thenRn_`
796
797
798
799
800
801

	-- CHECK WHETHER THE SOURCE HAS CHANGED
    if not source_unchanged then
	traceRn (nest 4 (text "Source file changed or recompilation check turned off"))	`thenRn_` 
	returnRn outOfDate
    else
802

803
804
805
806
807
808
	-- CHECK WHETHER WE HAVE AN OLD IFACE
    case maybe_iface of 
	Nothing -> traceRn (nest 4 (ptext SLIT("No old interface file")))	`thenRn_`
		   returnRn outOfDate ;

	Just iface  ->    	-- Source code unchanged and no errors yet... carry on 
809
			checkList [checkModUsage u | u <- mi_usages iface]
810
811
812
813
814
815
816
817

checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList []		 = returnRn upToDate
checkList (check:checks) = check	`thenRn` \ recompile ->
			   if recompile then 
				returnRn outOfDate
			   else
				checkList checks
818
\end{code}
819
820
	
\begin{code}
821
checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
822
823
824
825
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.

826
checkModUsage (mod_name, _, _, NothingAtAll)
827
828
829
830
831
832
833
	-- If CurrentModule.hi contains 
	--	import Foo :: ;
	-- then that simply records that Foo lies below CurrentModule in the
	-- hierarchy, but CurrentModule doesn't depend in any way on Foo.
	-- In this case we don't even want to open Foo's interface.
  = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)

834
checkModUsage (mod_name, _, _, whats_imported)
835
836
837
838
839
840
841
842
843
  = tryLoadInterface doc_str mod_name ImportBySystem	`thenRn` \ (ifaces, maybe_err) ->
    case maybe_err of {
	Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), 
				      ppr mod_name]) ;
		-- Couldn't find or parse a module mentioned in the
		-- old interface file.  Don't complain -- it might just be that
		-- the current module doesn't need that import and it's been deleted

	Nothing -> 
844
845

    getHomeIfaceTableRn					`thenRn` \ hit ->
846
847
848
849
850
851
852
    let
	mod_details   = lookupTableByModName hit (iPIT ifaces) mod_name
			`orElse` panic "checkModUsage"
	new_vers      = mi_version mod_details
	new_decl_vers = vers_decls new_vers
    in
    case whats_imported of {	-- NothingAtAll dealt with earlier
853

854
855
856
857
858
      Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers	`thenRn` \ recompile ->
				 if recompile then
					out_of_date (ptext SLIT("...and I needed the whole module"))
				 else
					returnRn upToDate ;
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
      Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers ->

	-- CHECK MODULE
    checkModuleVersion old_mod_vers new_vers	`thenRn` \ recompile ->
    if not recompile then
	returnRn upToDate
    else
				 
	-- CHECK EXPORT LIST
    if checkExportList maybe_old_export_vers new_vers then
	out_of_date (ptext SLIT("Export list changed"))
    else

	-- CHECK RULES
    if old_rule_vers /= vers_rules new_vers then
	out_of_date (ptext SLIT("Rules changed"))
    else

	-- CHECK ITEMS ONE BY ONE
    checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]	`thenRn` \ recompile ->
    if recompile then
	returnRn outOfDate	-- This one failed, so just bail out now
    else
	up_to_date (ptext SLIT("...but the bits I use haven't."))

    }}
886
  where
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
    doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]

------------------------
checkModuleVersion old_mod_vers new_vers
  | vers_module new_vers == old_mod_vers
  = up_to_date (ptext SLIT("Module version unchanged"))

  | otherwise
  = out_of_date (ptext SLIT("Module version has changed"))

------------------------
checkExportList Nothing  new_vers = upToDate
checkExportList (Just v) new_vers = v /= vers_exports new_vers

------------------------
checkEntityUsage new_vers (name,old_vers)
  = case lookupNameEnv new_vers name of

	Nothing       -> 	-- We used it before, but it ain't there now
			  out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])

	Just new_vers 	-- It's there, but is it up to date?
	  | new_vers == old_vers -> returnRn upToDate
	  | otherwise	 	 -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])

up_to_date  msg = traceRn msg `thenRn_` returnRn upToDate
out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
914
\end{code}
915

916

917
%*********************************************************
sof's avatar
sof committed
918
%*						 	 *
919
\subsection{Errors}
sof's avatar
sof committed
920
%*							 *
921
%*********************************************************
922

923
\begin{code}
924
getDeclErr name
925
926
927
  = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
	  ptext SLIT("from module") <+> quotes (ppr (nameModule name))
	 ]
928

929
importDeclWarn name
930
931
932
933
  = sep [ptext SLIT(
    "Compiler tried to import decl from interface file with same name as module."), 
	 ptext SLIT(
    "(possible cause: module name clashes with interface file already in scope.)")
sof's avatar
sof committed
934
	] $$
935
    hsep [ptext SLIT("name:"), quotes (ppr name)]
936
\end{code}