MkIface.lhs 31.3 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
4

5
6
7
\section[MkIface]{Print an interface for a module}

\begin{code}
8
module MkIface ( 
9
	showIface, mkIface, mkUsageInfo,
10
	pprIface, 
11
	ifaceTyThing,
12
  ) where
13

14
15
#include "HsVersions.h"

16
import HsSyn
17
import HsCore		( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
18
import HsTypes		( toHsTyVars )
19
import TysPrim		( alphaTyVars )
20
import BasicTypes	( NewOrData(..), Activation(..), FixitySig(..),
21
			  Version, initialVersion, bumpVersion 
22
			)
23
import NewDemand	( isTopSig )
24
import TcRnMonad
25
import TcRnTypes	( ImportAvails(..) )
26
import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl )
27
import HscTypes		( VersionInfo(..), ModIface(..), 
28
			  ModGuts(..), ModGuts, 
29
			  GhciMode(..), HscEnv(..), Dependencies(..),
30
			  FixityEnv, lookupFixity, collectFixities,
31
			  IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
32
			  TyThing(..), DFunId, 
33
34
			  Avails, AvailInfo, GenAvailInfo(..), availName, 
			  ExternalPackageState(..),
35
36
			  ParsedIface(..), Usage(..),
			  Deprecations(..), initialVersionInfo,
37
			  lookupVersion, lookupIfaceByModName
38
			)
39
40

import CmdLineOpts
41
import Id		( idType, idInfo, isImplicitId, idCafInfo )
42
import DataCon		( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks )
43
import IdInfo		-- Lots
sof's avatar
sof committed
44
import CoreSyn		( CoreRule(..), IdCoreRule )
45
import CoreFVs		( ruleLhsFreeNames )
46
import CoreUnfold	( neverUnfold, unfoldingTemplate )
47
import Name		( getName, nameModule, nameModule_maybe, nameOccName,
48
			  nameIsLocalOrFrom, Name, NamedThing(..) )
49
import NameEnv
50
import NameSet
51
52
53
54
55
import OccName		( OccName, pprOccName )
import TyCon		( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta,
			  isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, 
			  isSynTyCon, isAlgTyCon, isForeignTyCon,
			  getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
56
import Class		( classExtraBigSig, classTyCon )
57
import FieldLabel	( fieldLabelType )
58
59
import TcType		( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead,
			  mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys )
60
import SrcLoc		( noSrcLoc )
61
import Module		( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
62
			  ModLocation(..), mkSysModuleNameFS, 
63
64
			  ModuleEnv, emptyModuleEnv, lookupModuleEnv,
			  extendModuleEnv_C, moduleEnvElts 
65
			)
66
import Outputable
67
import Util		( sortLt, dropList, seqList )
68
import Binary		( getBinFileWithDict )
69
import BinIface		( writeBinIface, v_IgnoreHiVersion )
70
import ErrUtils		( dumpIfSet_dyn )
71
import FiniteMap
72
import FastString
73

74
import DATA_IOREF	( writeIORef )
75
import Monad		( when )
76
77
import Maybe		( catMaybes, isJust, isNothing )
import Maybes		( orElse )
78
import IO		( putStrLn )
79
80
81
\end{code}


82
83
84
85
86
87
88
89
90
%************************************************************************
%*				 					*
\subsection{Print out the contents of a binary interface}
%*				 					*
%************************************************************************

\begin{code}
showIface :: FilePath -> IO ()
showIface filename = do
91
92
93
   -- skip the version check; we don't want to worry about profiled vs.
   -- non-profiled interfaces, for example.
   writeIORef v_IgnoreHiVersion True
94
95
96
   parsed_iface <- Binary.getBinFileWithDict filename
   let ParsedIface{
      pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers,
97
      pi_deps=pi_deps,
98
99
100
101
102
103
104
105
106
107
108
      pi_orphan=pi_orphan, pi_usages=pi_usages,
      pi_exports=pi_exports, pi_decls=pi_decls,
      pi_fixity=pi_fixity, pi_insts=pi_insts,
      pi_rules=pi_rules, pi_deprecs=pi_deprecs } = parsed_iface
   putStrLn (showSDoc (vcat [
	text "__interface" <+> doubleQuotes (ppr pi_pkg)
	   <+> ppr pi_mod <+> ppr pi_vers 
	   <+> (if pi_orphan then char '!' else empty)
	   <+> ptext SLIT("where"),
	-- no instance Outputable (WhatsImported):
	pprExports id (snd pi_exports),
109
	pprDeps pi_deps,
110
111
112
113
114
115
116
117
118
	pprUsages  id pi_usages,
	hsep (map ppr_fix pi_fixity) <> semi,
	vcat (map ppr_inst pi_insts),
	vcat (map ppr_decl pi_decls),
	ppr pi_rules
	-- no instance Outputable (Either):
	-- ppr pi_deprecs
	]))
   where
119
    ppr_fix (FixitySig n f _) = ppr f <+> ppr n
120
121
122
123
    ppr_inst i  = ppr i <+> semi
    ppr_decl (v,d)  = int v <+> ppr d <> semi
\end{code}

124
125
126
127
128
129
130
%************************************************************************
%*				 					*
\subsection{Completing an interface}
%*				 					*
%************************************************************************

\begin{code}
131
132
133
134
135
mkIface :: HscEnv
	-> ModLocation
	-> Maybe ModIface	-- The old interface, if we have it
	-> ModGuts		-- The compiled, tidied module
	-> IO ModIface		-- The new one, complete with decls and versions
136
137
138
139
-- mkFinalIface 
--	a) completes the interface
--	b) writes it out to a file if necessary

140
141
142
mkIface hsc_env location maybe_old_iface 
	impl@ModGuts{ mg_module = this_mod,
		      mg_usages = usages,
143
		      mg_deps   = deps,
144
145
146
147
148
149
150
151
152
153
154
155
156
		      mg_exports = exports,
		      mg_rdr_env = rdr_env,
		      mg_fix_env = fix_env,
		      mg_deprecs = deprecs,
		      mg_insts = insts, 
		      mg_rules = rules,
		      mg_types = types }
  = do	{ 	-- Sort the exports to make them easier to compare for versions
	  let { my_exports = groupAvails this_mod exports ;

	        iface_w_decls = ModIface { mi_module   = this_mod,
					   mi_package  = opt_InPackage,
					   mi_version  = initialVersionInfo,
157
					   mi_deps     = deps,
158
159
160
161
162
163
164
165
					   mi_usages   = usages,
					   mi_exports  = my_exports,
					   mi_decls    = new_decls,
					   mi_orphan   = orphan_mod,
					   mi_boot     = False,
					   mi_fixities = fix_env,
					   mi_globals  = Just rdr_env,
					   mi_deprecs  = deprecs } }
166
167

		-- Add version information
168
	; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls
169
170
171

		-- Write the interface file, if necessary
	; when (must_write_hi_file maybe_diffs)
172
173
		(writeBinIface hi_file_path final_iface)
--		(writeIface hi_file_path final_iface)
174
175
176
177

		-- Debug printing
	; write_diffs dflags final_iface maybe_diffs

178
179
	; orphan_mod `seq`
	  return final_iface }
180

181
  where
182
183
184
     dflags    = hsc_dflags hsc_env
     ghci_mode = hsc_mode hsc_env

sof's avatar
sof committed
185
186
     must_write_hi_file Nothing       = False
     must_write_hi_file (Just _diffs) = ghci_mode /= Interactive
187
188
189
190
191
192
		-- We must write a new .hi file if there are some changes
		-- and we're not in interactive mode
		-- maybe_diffs = 'Nothing' means that even the usages havn't changed, 
		--     so there's no need to write a new interface file.  But even if 
		--     the usages have changed, the module version may not have.

193
     hi_file_path = ml_hi_file location
194
     new_decls    = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
195
196
197
     inst_dcls    = map ifaceInstance insts
     ty_cls_dcls  = foldNameEnv ifaceTyThing_acc [] types
     rule_dcls    = map ifaceRule rules
198
     orphan_mod   = isOrphanModule impl
199

sof's avatar
sof committed
200
write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO ()
201
202
203
204
205
206
207
write_diffs dflags new_iface Nothing
  = do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED"))
       dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface)

write_diffs dflags new_iface (Just sdoc_diffs)
  = do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs
       dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface)
208
209
\end{code}

210
\begin{code}
211
212
isOrphanModule :: ModGuts -> Bool
isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules})
213
214
  = any orphan_inst insts || any orphan_rule rules
  where
215
	-- A rule is an orphan if the LHS mentions nothing defined locally
216
    orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id))
217
	-- A instance is an orphan if its head mentions nothing defined locally
218
    orphan_rule rule    = no_locals (ruleLhsFreeNames rule)
219

220
221
    no_locals names     = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
\end{code}
222

223
224
225
226
Implicit Ids and class tycons aren't included in interface files, so
we miss them out of the accumulating parameter here.

\begin{code}
227
ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
228
-- Don't put implicit things into the result
229
ifaceTyThing_acc (ADataCon dc) so_far 		      = so_far
230
231
232
ifaceTyThing_acc (AnId   id) so_far | isImplicitId id = so_far
ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far
ifaceTyThing_acc other so_far = ifaceTyThing other : so_far
233
234
235
236
237
\end{code}

Convert *any* TyThing into a RenamedTyClDecl.  Used both for
generating interface files and for the ':info' command in GHCi.

238
\begin{code}
239
240
ifaceTyThing :: TyThing -> RenamedTyClDecl
ifaceTyThing (AClass clas) = cls_decl
241
  where
242
243
244
245
246
247
248
    cls_decl = ClassDecl { tcdCtxt	= toHsContext sc_theta,
			   tcdName	= getName clas,
			   tcdTyVars	= toHsTyVars clas_tyvars,
			   tcdFDs 	= toHsFDs clas_fds,
			   tcdSigs	= map toClassOpSig op_stuff,
			   tcdMeths	= Nothing, 
			   tcdLoc	= noSrcLoc }
249

250
251
252
    (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
    tycon     = classTyCon clas
    data_con  = head (tyConDataCons tycon)
253
254

    toClassOpSig (sel_id, def_meth)
255
	= ASSERT(sel_tyvars == clas_tyvars)
256
	  ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc
257
	where
258
259
260
261
262
263
264
		-- Be careful when splitting the type, because of things
		-- like  	class Foo a where
		--		  op :: (?x :: String) => a -> a
		-- and  	class Baz a where
		--		  op :: (Ord a) => a -> a
	  (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
	  op_ty		       = tcFunResultTy rho_ty
265

266
ifaceTyThing (ATyCon tycon) = ty_decl
267
  where
268
    ty_decl | isSynTyCon tycon
269
270
271
272
	    = TySynonym { tcdName   = getName tycon,
		 	  tcdTyVars = toHsTyVars tyvars,
			  tcdSynRhs = toHsType syn_ty,
			  tcdLoc    = noSrcLoc }
273
274

	    | isAlgTyCon tycon
275
276
277
278
279
280
281
282
283
	    = TyData {	tcdND	   = new_or_data,
			tcdCtxt    = toHsContext (tyConTheta tycon),
			tcdName    = getName tycon,
		 	tcdTyVars  = toHsTyVars tyvars,
			tcdCons    = ifaceConDecls (tyConDataConDetails tycon),
			tcdDerivs  = Nothing,
		        tcdGeneric = Just (isJust (tyConGenInfo tycon)),
				-- Just True <=> has generic stuff
			tcdLoc	   = noSrcLoc }
284

285
	    | isForeignTyCon tycon
sof's avatar
sof committed
286
287
288
289
	    = ForeignType { tcdName    = getName tycon,
	    		    tcdExtName = Nothing,
			    tcdFoType  = DNType,	-- The only case at present
			    tcdLoc     = noSrcLoc }
290

291
	    | isPrimTyCon tycon || isFunTyCon tycon
292
293
294
295
296
		-- needed in GHCi for ':info Int#', for example
	    = TyData {  tcdND     = DataType,
			tcdCtxt   = [],
			tcdName   = getName tycon,
		 	tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
297
			tcdCons   = Unknown,
298
			tcdDerivs = Nothing,
299
		        tcdGeneric  = Just False,
300
301
			tcdLoc	     = noSrcLoc }

302
	    | otherwise = pprPanic "ifaceTyThing" (ppr tycon)
303
304
305

    tyvars      = tyConTyVars tycon
    (_, syn_ty) = getSynTyConDefn tycon
306
307
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType
308

309
310
311
312
    ifaceConDecls Unknown       = Unknown
    ifaceConDecls (HasCons n)   = HasCons n
    ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)

313
    ifaceConDecl data_con 
314
	= ConDecl (dataConName data_con)
315
316
317
318
319
320
		  (toHsTyVars ex_tyvars)
		  (toHsContext ex_theta)
		  details noSrcLoc
	where
	  (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
          field_labels   = dataConFieldLabels data_con
sof's avatar
sof committed
321
          strict_marks   = dropList ex_theta (dataConStrictMarks data_con)
322
323
				-- The 'drop' is because dataConStrictMarks
				-- includes the existential dictionaries
324
325
	  details | null field_labels
	    	  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
326
	    	    PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys))
327

328
329
    	    	  | otherwise
	    	  = RecCon (zipWith mk_field strict_marks field_labels)
330

331
    mk_field strict_mark field_label
332
	= (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label)))
333

334
ifaceTyThing (AnId id) = iface_sig
335
  where
336
337
338
    iface_sig = IfaceSig { tcdName   = getName id, 
			   tcdType   = toHsType id_type,
			   tcdIdInfo = hs_idinfo,
339
			   tcdLoc    = noSrcLoc }
340

341
342
    id_type = idType id
    id_info = idInfo id
343
    arity_info = arityInfo id_info
344
    caf_info   = idCafInfo id
345

346
347
348
349
350
351
    hs_idinfo | opt_OmitInterfacePragmas
	      = []
 	      | otherwise
  	      = catMaybes [arity_hsinfo,  caf_hsinfo,
			   strict_hsinfo, wrkr_hsinfo,
			   unfold_hsinfo] 
352
353

    ------------  Arity  --------------
sof's avatar
sof committed
354
355
    arity_hsinfo | arity_info == 0 = Nothing
		 | otherwise       = Just (HsArity arity_info)
356
357

    ------------ Caf Info --------------
358
    caf_hsinfo = case caf_info of
sof's avatar
sof committed
359
360
		   NoCafRefs -> Just HsNoCafRefs
		   _other    -> Nothing
361
362

    ------------  Strictness  --------------
363
	-- No point in explicitly exporting TopSig
364
    strict_hsinfo = case newStrictnessInfo id_info of
sof's avatar
sof committed
365
366
			Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
			_other			      -> Nothing
367
368

    ------------  Worker  --------------
369
370
371
    work_info   = workerInfo id_info
    has_worker  = case work_info of { HasWorker _ _ -> True; other -> False }
    wrkr_hsinfo = case work_info of
372
		    HasWorker work_id wrap_arity -> 
sof's avatar
sof committed
373
374
			Just (HsWorker (getName work_id) wrap_arity)
		    NoWorker -> Nothing
375
376

    ------------  Unfolding  --------------
377
	-- The unfolding is redundant if there is a worker
378
379
380
    unfold_info = unfoldingInfo id_info
    inline_prag = inlinePragInfo id_info
    rhs		= unfoldingTemplate unfold_info
381
    unfold_hsinfo |  neverUnfold unfold_info 
sof's avatar
sof committed
382
383
		  || has_worker = Nothing
		  | otherwise	= Just (HsUnfold inline_prag (toUfExpr rhs))
384
385


386
ifaceTyThing (ADataCon dc)
387
388
	-- This case only happens in the call to ifaceThing in InteractiveUI
	-- Otherwise DataCons are filtered out in ifaceThing_acc
389
390
391
392
393
394
395
396
397
398
399
400
 = IfaceSig { tcdName   = getName dc, 
	      tcdType   = toHsType full_ty,
	      tcdIdInfo = [],
	      tcdLoc    = noSrcLoc }
 where
    (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc

	-- The "stupid context" isn't part of the wrapper-Id type
	-- (for better or worse -- see note in DataCon.lhs), so we
	-- have to make it up here
    full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) 
			(mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
401
402
\end{code}

403
\begin{code}
404
405
406
ifaceInstance :: DFunId -> RenamedInstDecl
ifaceInstance dfun_id
  = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc			 
407
  where
408
409
410
411
412
413
414
415
416
417
    tidy_ty = tidyTopType (deNoteType (idType dfun_id))
		-- The deNoteType is very important.   It removes all type
		-- synonyms from the instance type in interface files.
		-- That in turn makes sure that when reading in instance decls
		-- from interface files that the 'gating' mechanism works properly.
		-- Otherwise you could have
		--	type Tibble = T Int
		--	instance Foo Tibble where ...
		-- and this instance decl wouldn't get imported into a module
		-- that mentioned T but not Tibble.
418

419
ifaceRule :: IdCoreRule -> RuleDecl Name
420
ifaceRule (id, BuiltinRule _ _)
421
  = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
422

423
424
ifaceRule (id, Rule name act bndrs args rhs)
  = IfaceRule name act (map toUfBndr bndrs) (getName id)
425
426
	      (map toUfExpr args) (toUfExpr rhs) noSrcLoc

427
bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name
428
bogusIfaceRule id
429
  = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc
430
\end{code}
431
432


433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
%*********************************************************
%*							*
\subsection{Keeping track of what we've slurped, and version numbers}
%*							*
%*********************************************************

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

We produce a line for every module B below the module, A, currently being
compiled:
	import B <n> ;
to record the fact that A does import B indirectly.  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.

The usage information records:

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

Why (b)?  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.

Why (c)?  Consider this:
\begin{verbatim}
	module A( f, g ) where	|	module B( f ) where
	  import B( f )		|	  f = h 3
	  g = ...		|	  h = ...
\end{verbatim}

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.

	*** Conclusion: if A mentions B.f in its export list,
	    behave just as if A mentioned B.f in its source code,
	    and slurp in B.f and all its transitive closure ***

[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.]

\begin{code}
mkUsageInfo :: HscEnv -> ExternalPackageState
499
500
	    -> ImportAvails -> EntityUsage
	    -> [Usage Name]
501
502

mkUsageInfo hsc_env eps
503
	    (ImportAvails { imp_mods = dir_imp_mods,
504
			    imp_dep_mods = dep_mods })
505
506
	    used_names
  = -- seq the list of Usages returned: occasionally these
507
508
    -- don't get evaluated for a while and we can end up hanging on to
    -- the entire collection of Ifaces.
509
510
    usages `seqList` usages
  where
511
    usages = catMaybes [ mkUsage mod_name 
512
		       | (mod_name,_) <- moduleEnvElts dep_mods]
513
	-- ToDo: do we need to sort into canonical order?
514
515
516

    hpt = hsc_HPT hsc_env
    pit = eps_PIT eps
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
    
    import_all mod = case lookupModuleEnv dir_imp_mods mod of
    			Just (_,imp_all) -> imp_all
    			Nothing		 -> False
    
    -- ent_map groups together all the things imported and used
    -- from a particular module in this package
    ent_map :: ModuleEnv [Name]
    ent_map  = foldNameSet add_mv emptyModuleEnv used_names
    add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
    		   where
    		     mod = nameModule name
    		     add_item names _ = name:names
    
    -- We want to create a Usage for a home module if 
    --	a) we used something from; has something in used_names
    --	b) we imported all of it, even if we used nothing from it
    --		(need to recompile if its export list changes: export_vers)
    --	c) is a home-package orphan module (need to recompile if its
    --	 	instance decls change: rules_vers)
537
538
539
540
541
542
543
544
    mkUsage :: ModuleName -> Maybe (Usage Name)
    mkUsage mod_name
      |  isNothing maybe_iface	-- We can't depend on it if we didn't
      || not (isHomeModule mod)	-- even open the interface!
      || (null used_names
	  && not all_imported
	  && not orphan_mod)
      = Nothing			-- Record no usage info
545
546
547
548
549
550
551
552
    
      | otherwise	
      = Just (Usage { usg_name     = moduleName mod,
    	  	      usg_mod      = mod_vers,
    		      usg_exports  = export_vers,
    		      usg_entities = ent_vers,
    		      usg_rules    = rules_vers })
      where
553
554
555
556
557
	maybe_iface  = lookupIfaceByModName hpt pit mod_name
		-- In one-shot mode, the interfaces for home-package 
		-- modules accumulate in the PIT not HPT.  Sigh.

        Just iface   = maybe_iface
558
559
        mod   	     = mi_module iface
        version_info = mi_version iface
560
	orphan_mod   = mi_orphan iface
561
562
563
564
565
566
567
568
569
570
571
572
        version_env  = vers_decls   version_info
        mod_vers     = vers_module  version_info
        rules_vers   = vers_rules   version_info
        all_imported = import_all mod 
        export_vers | all_imported = Just (vers_exports version_info)
    		    | otherwise    = Nothing
    
    	-- The sort is to put them into canonical order
        used_names = lookupModuleEnv ent_map mod `orElse` []
        ent_vers = [(n, lookupVersion version_env n) 
    	           | n <- sortLt lt_occ used_names ]
        lt_occ n1 n2 = nameOccName n1 < nameOccName n2
573
	-- ToDo: is '<' on OccNames the right thing; may differ between runs?
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
\end{code}

\begin{code}
groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
  -- Group by module and sort by occurrence
  -- This keeps the list in canonical order
groupAvails this_mod avails 
  = [ (mkSysModuleNameFS fs, sortLt lt avails)
    | (fs,avails) <- fmToList groupFM
    ]
  where
    groupFM :: FiniteMap FastString Avails
	-- Deliberately use the FastString so we
	-- get a canonical ordering
    groupFM = foldl add emptyFM avails

    add env avail = addToFM_C combine env mod_fs [avail']
		  where
		    mod_fs = moduleNameFS (moduleName avail_mod)
		    avail_mod = case nameModule_maybe (availName avail) of
					  Just m  -> m
					  Nothing -> this_mod
		    combine old _ = avail':old
		    avail'	  = sortAvail avail

    a1 `lt` a2 = occ1 < occ2
	       where
		 occ1  = nameOccName (availName a1)
		 occ2  = nameOccName (availName a2)

sortAvail :: AvailInfo -> AvailInfo
-- Sort the sub-names into canonical order.
-- The canonical order has the "main name" at the beginning 
-- (if it's there at all)
sortAvail (Avail n) = Avail n
sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
			 | otherwise   = AvailTC n (    sortLt lt ns)
			 where
			   n1 `lt` n2 = nameOccName n1 < nameOccName n2
\end{code}

615
616
617
618
619
620
621
622
623
%************************************************************************
%*				 					*
\subsection{Checking if the new interface is up to date
%*				 					*
%************************************************************************

\begin{code}
addVersionInfo :: Maybe ModIface		-- The old interface, read from M.hi
	       -> ModIface			-- The new interface decls
624
	       -> (ModIface, Maybe SDoc)	-- Nothing => no change; no need to write new Iface
625
626
627
628
629
630
631
632
633
						-- Just mi => Here is the new interface to write
						-- 	      with correct version numbers

-- NB: the fixities, declarations, rules are all assumed
-- to be sorted by increasing order of hsDeclName, so that 
-- we can compare for equality

addVersionInfo Nothing new_iface
-- No old interface, so definitely write a new one!
634
  = (new_iface, Just (text "No old interface available"))
635

636
637
638
639
640
641
642
addVersionInfo (Just old_iface@(ModIface { mi_version  = old_version, 
				       	   mi_decls    = old_decls,
				       	   mi_fixities = old_fixities,
					   mi_deprecs  = old_deprecs }))
	       new_iface@(ModIface { mi_decls    = new_decls,
				     mi_fixities = new_fixities,
				     mi_deprecs  = new_deprecs })
643
644

  | no_output_change && no_usage_change
645
646
647
  = (new_iface, Nothing)
	-- don't return the old iface because it may not have an
	-- mi_globals field set to anything reasonable.
648
649

  | otherwise		-- Add updated version numbers
650
  = --pprTrace "completeIface" (ppr (dcl_tycl old_decls))
651
    (final_iface, Just pp_diffs)
652
653
654
	
  where
    final_iface = new_iface { mi_version = new_version }
655
656
    old_mod_vers = vers_module  old_version
    new_version = VersionInfo { vers_module  = bumpVersion no_output_change old_mod_vers,
657
658
				vers_exports = bumpVersion no_export_change (vers_exports old_version),
				vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
659
				vers_decls   = tc_vers }
660

661
    no_output_change = no_tc_change && no_rule_change && no_export_change && no_deprec_change
662
663
664
665
    no_usage_change  = mi_usages old_iface == mi_usages new_iface

    no_export_change = mi_exports old_iface == mi_exports new_iface		-- Kept sorted
    no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls		-- Ditto
666
		     && dcl_insts old_decls == dcl_insts  new_decls
667
    no_deprec_change = old_deprecs	    == new_deprecs
668
669
670
671

	-- Fill in the version number on the new declarations by looking at the old declarations.
	-- Set the flag if anything changes. 
	-- Assumes that the decls are sorted by hsDeclName.
672
    (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_version old_fixities new_fixities
673
						       (dcl_tycl old_decls) (dcl_tycl new_decls)
674
675
676
    pp_diffs = vcat [pp_tc_diffs,
		     pp_change no_export_change "Export list",
		     pp_change no_rule_change   "Rules",
677
		     pp_change no_deprec_change "Deprecations",
678
679
680
		     pp_change no_usage_change  "Usages"]
    pp_change True  what = empty
    pp_change False what = text what <+> ptext SLIT("changed")
681

682
diffDecls :: VersionInfo				-- Old version
683
	  -> FixityEnv -> FixityEnv			-- Old and new fixities
684
	  -> [RenamedTyClDecl] -> [RenamedTyClDecl]	-- Old and new decls
685
686
	  -> (Bool,		-- True <=> no change
	      SDoc,		-- Record of differences
687
	      NameEnv Version)	-- New version map
688

689
690
diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers })
	  old_fixities new_fixities old new
691
692
  = diff True empty emptyNameEnv old new
  where
693
694
695
	-- When seeing if two decls are the same, 
	-- remember to check whether any relevant fixity has changed
    eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
696
    same_fixity n = lookupFixity old_fixities n == lookupFixity new_fixities n
697

698
    diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
699
700
701
702
703
704
705
706
707
    diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers	      ods []
    diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new []  nds
	where
	  new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers)
		-- When adding a new item, start from the old module version
		-- This way, if you have version 4 of f, then delete f, then add f again,
		-- you'll get version 6 of f, which will (correctly) force recompilation of
		-- clients

708
    diff ok_so_far pp new_vers (od:ods) (nd:nds)
709
	= case od_name `compare` nd_name of
710
711
		LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
		GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
712
713
		EQ | od `eq_tc` nd -> diff ok_so_far pp 		   new_vers	      ods nds
		   | otherwise     -> diff False     (pp $$ changed od nd) new_vers_with_diff ods nds
714
	where
715
716
 	  od_name = tyClDeclName od
 	  nd_name = tyClDeclName nd
717
718
	  new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version)
	  old_version = lookupVersion old_decls_vers od_name
719

720
721
722
723
    only_old d    = ptext SLIT("Only in old iface:") <+> ppr d
    only_new d    = ptext SLIT("Only in new iface:") <+> ppr d
    changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$ 
							 (ptext SLIT("New:")  <+> ppr nd))
724
\end{code}
725
726


727
b%************************************************************************
728
729
730
731
732
733
%*				 					*
\subsection{Writing an interface file}
%*				 					*
%************************************************************************

\begin{code}
734
pprIface :: ModIface -> SDoc
735
736
pprIface iface
 = vcat [ ptext SLIT("__interface")
737
		<+> doubleQuotes (ftext (mi_package iface))
738
739
740
741
742
743
		<+> ppr (mi_module iface) <+> ppr (vers_module version_info)
		<+> pp_sub_vers
		<+> (if mi_orphan iface then char '!' else empty)
		<+> int opt_HiVersion
		<+> ptext SLIT("where")

744
	, pprExports nameOccName (mi_exports iface)
745
	, pprDeps    (mi_deps iface)
746
	, pprUsages  nameOccName (mi_usages iface)
747

748
749
	, pprFixities (mi_fixities iface) (dcl_tycl decls)
	, pprIfaceDecls (vers_decls version_info) decls
750
	, pprRulesAndDeprecs (dcl_rules decls) (mi_deprecs iface)
751
752
	]
  where
753
    version_info = mi_version iface
754
    decls	 = mi_decls iface
755
    exp_vers     = vers_exports version_info
756

757
758
759
760
761
762
763
764
765
766
767
768
    rule_vers	 = vers_rules version_info

    pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
		| otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
\end{code}

When printing export lists, we print like this:
	Avail   f		f
	AvailTC C [C, x, y]	C(x,y)
	AvailTC C [x, y]	C!(x,y)		-- Exporting x, y but not C

\begin{code}
769
770
771
772
773
pprExports :: Eq a => (a -> OccName) -> [(ModuleName, [GenAvailInfo a])] -> SDoc
pprExports getOcc exports = vcat (map (pprExport getOcc) exports)

pprExport :: Eq a => (a -> OccName) -> (ModuleName, [GenAvailInfo a]) -> SDoc
pprExport getOcc (mod, items)
774
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
775
  where
776
777
    --pp_avail :: GenAvailInfo a -> SDoc
    pp_avail (Avail name)    		     = ppr (getOcc name)
sof's avatar
sof committed
778
    pp_avail (AvailTC _ [])		     = empty
779
780
781
    pp_avail (AvailTC n (n':ns)) 
	| n==n'     = ppr (getOcc n) <> pp_export ns
 	| otherwise = ppr (getOcc n) <> char '|' <> pp_export (n':ns)
782
783
    
    pp_export []    = empty
784
    pp_export names = braces (hsep (map (ppr.getOcc) names))
785
786
787

pprOcc :: Name -> SDoc	-- Print the occurrence name only
pprOcc n = pprOccName (nameOccName n)
788
789
790
791
\end{code}


\begin{code}
792
pprUsages :: (a -> OccName) -> [Usage a] -> SDoc
793
794
pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages)

795
796
797
798
799
800
801
pprUsage :: (a -> OccName) -> Usage a -> SDoc
pprUsage getOcc usage
  = hsep [ptext SLIT("import"), ppr (usg_name usage), 
	  int (usg_mod usage), 
	  pp_export_version (usg_exports usage),
	  int (usg_rules usage),
	  pp_versions (usg_entities usage)
802
803
    ] <> semi
  where
804
    pp_versions nvs = hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ]
805

806
    pp_export_version Nothing  = empty
807
    pp_export_version (Just v) = int v
808
809
810


pprDeps :: Dependencies -> SDoc
811
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs})
812
  = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods),
813
814
815
	  ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), 
	  ptext SLIT("orphans:") <+> fsep (map ppr orphs)
	]
816
  where
817
    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
818
   
819
    ppr_boot   True  = text "[boot]"
820
    ppr_boot   False = empty
821
822
823
\end{code}

\begin{code}
sof's avatar
sof committed
824
pprIfaceDecls :: NameEnv Int -> IfaceDecls -> SDoc
825
pprIfaceDecls version_map decls
826
827
828
829
  = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
	 , vcat (map ppr_decl (dcl_tycl decls))
	 ]
  where
830
    ppr_decl d  = ppr_vers d <+> ppr d <> semi
831
832
833
834
835
836
837
838

	-- Print the version for the decl
    ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
		   Nothing -> empty
		   Just v  -> int v
\end{code}

\begin{code}
839
840
pprFixities :: FixityEnv
	    -> [TyClDecl Name]
sof's avatar
sof committed
841
	    -> SDoc
842
843
pprFixities fixity_map decls
  = hsep [ ppr fix <+> ppr n 
844
	 | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi
845

846
847
-- Disgusting to print these two together, but that's 
-- the way the interface parser currently expects them.
sof's avatar
sof committed
848
pprRulesAndDeprecs :: (Outputable a) => [a] -> Deprecations -> SDoc
849
pprRulesAndDeprecs [] NoDeprecs = empty
850
pprRulesAndDeprecs rules deprecs
851
852
853
854
855
  = ptext SLIT("{-##") <+> (pp_rules rules $$ pp_deprecs deprecs) <+> ptext SLIT("##-}")
  where
    pp_rules []    = empty
    pp_rules rules = ptext SLIT("__R") <+> vcat (map ppr rules)

856
857
    pp_deprecs NoDeprecs = empty
    pp_deprecs deprecs   = ptext SLIT("__D") <+> guts
858
859
			  where
			    guts = case deprecs of
860
					DeprecAll txt  -> doubleQuotes (ftext txt)
861
					DeprecSome env -> ppr_deprec_env env
862

863
ppr_deprec_env :: NameEnv (Name, FastString) -> SDoc
864
865
ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
	           where
866
   	 	     pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ftext txt)
867
\end{code}