MkIface.lhs 25.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4
5
6
%
\section[MkIface]{Print an interface for a module}

\begin{code}
7
module MkIface ( 
8
	mkModDetails, mkModDetailsFromIface, completeIface, writeIface
9
  ) where
10

11
12
#include "HsVersions.h"

13
import HsSyn
14
import HsCore		( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
15
import HsTypes		( toHsTyVars )
16
import BasicTypes	( Fixity(..), NewOrData(..),
17
			  Version, initialVersion, bumpVersion, isLoopBreaker
18
			)
19
import RnMonad
20
21
import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl )
import TcHsSyn		( TypecheckedRuleDecl )
22
import HscTypes		( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
23
			  TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
24
25
26
			  WhatsImported(..), GenAvailInfo(..), 
			  ImportVersion, AvailInfo, Deprecations(..), 
			  Finder, ModuleLocation(..)
27
			)
28
29

import CmdLineOpts
30
import Id		( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
31
			  idSpecialisation, idName, setIdInfo
32
			)
33
import Var		( isId )
34
import VarSet
35
import DataCon		( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
36
37
38
39
import IdInfo		-- Lots
import CoreSyn		( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, 
			  isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
			  bindersOfBinds
40
			)
41
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
42
43
import CoreUnfold	( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
import Name		( isLocallyDefined, getName, 
44
			  Name, NamedThing(..),
45
46
			  plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
			  extendNameEnv, lookupNameEnv_NF, nameEnvElts
47
			)
48
import OccName		( pprOccName )
49
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
50
			  tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
51
			)
52
import Class		( classExtraBigSig, DefMeth(..) )
53
import FieldLabel	( fieldLabelType )
54
import Type		( splitSigmaTy, tidyTopType, deNoteType )
55
import SrcLoc		( noSrcLoc )
56
import Outputable
57
import Module		( ModuleName, moduleName )
58

59
import List		( partition )
60
import IO		( IOMode(..), openFile, hClose )
61
62
63
\end{code}


64
65
66
67
68
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
69

70
\begin{code}
71
72
73
74
75
76
77
78
79
mkModDetails :: TypeEnv -> [DFunId]	-- From typechecker
	     -> [CoreBind] -> [Id]	-- Final bindings, plus the top-level Ids from the
					-- code generator; they have authoritative arity info
	     -> [IdCoreRule]		-- Tidy orphan rules
	     -> ModDetails
mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
  = ModDetails { md_types = new_type_env,
		 md_rules = rule_dcls,
		 md_insts = dfun_ids }
80
  where
81
82
83
84
85
86
87
88
89
90
	-- The competed type environment is gotten from
	-- 	a) keeping the types and classes
	--	b) removing all Ids, and Ids with correct IdInfo
	--		gotten from the bindings
    new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
			`plusNameEnv`
		   mkNameEnv [(idName id, AnId id) | id <- final_ids]

    orig_type_env = nameEnvElts type_env

91
92
93
94
    final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
			   (mkVarSet stg_ids)
			   tidy_binds

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
	-- The complete rules are gotten by combining
	--	a) the orphan rules
	--	b) rules embedded in the top-level Ids
    rule_dcls | opt_OmitInterfacePragmas = []
	      | otherwise		  = getRules orphan_rules tidy_binds (mkVarSet final_ids)

    orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
				   | (_, rule) <- orphan_rules]


-- This version is used when we are re-linking a module
-- so we've only run the type checker on its previous interface 
mkModDetailsFromIface :: TypeEnv -> [DFunId]	-- From typechecker
		      -> [TypecheckedRuleDecl]
		      -> ModDetails
mkModDetailsFromIface type_env dfun_ids rules
  = ModDetails { md_types = type_env,
		 md_rules = rule_dcls,
		 md_insts = dfun_ids }
  where
    rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
	-- All the rules from an interface are of the IfaceRuleOut form
117

118

119
120
121
122
123
124
completeIface :: Maybe ModIface		-- The old interface, if we have it
	      -> ModIface		-- The new one, minus the decls and versions
	      -> ModDetails		-- The ModDetails for this module
	      -> Maybe (ModIface, SDoc)	-- The new one, complete with decls and versions
					-- The SDoc is a debug document giving differences
					-- Nothing => no change
125

126
127
128
129
130
131
132
	-- NB: '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.
	--
	-- The IO in the type is solely for debug output
	-- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details 
133
134
135
136
137
  = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
  where
     new_decls = IfaceDecls { dcl_tycl  = ty_cls_dcls,
			      dcl_insts = inst_dcls,
			      dcl_rules = rule_dcls }
138

139
140
141
     inst_dcls   = map ifaceInstance (md_insts mod_details)
     ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
     rule_dcls   = map ifaceRule (md_rules mod_details)
142
143
\end{code}

144

145
146
%************************************************************************
%*				 					*
147
\subsection{Types and classes}
148
149
%*				 					*
%************************************************************************
150

151
\begin{code}
152
153
154
155
156
157
158
159
160
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
  = ClassDecl (toHsContext sc_theta)
	      (getName clas)
	      (toHsTyVars clas_tyvars)
	      (toHsFDs clas_fds)
	      (map toClassOpSig op_stuff)
	      EmptyMonoBinds
	      [] noSrcLoc
161
  where
162
     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
163

164
165
166
167
168
169
170
171
172
     toClassOpSig (sel_id, def_meth)
	= ASSERT(sel_tyvars == clas_tyvars)
	  ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
	  def_meth' = case def_meth of
			 NoDefMeth  -> NoDefMeth
			 GenDefMeth -> GenDefMeth
			 DefMeth id -> DefMeth (getName id)
173

174
175
176
ifaceTyCls (ATyCon tycon)
  | isSynTyCon tycon
  = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
sof's avatar
sof committed
177
  where
178
    (tyvars, ty) = getSynTyConDefn tycon
179

180
181
182
183
184
185
186
187
ifaceTyCls (ATyCon tycon)
  | isAlgTyCon tycon
  = TyData new_or_data (toHsContext (tyConTheta tycon))
	   (getName tycon)
	   (toHsTyVars tyvars)
	   (map ifaceConDecl (tyConDataCons tycon))
	   (tyConFamilySize tycon)
	   Nothing noSrcLoc (panic "gen1") (panic "gen2")
188
  where
189
190
191
    tyvars = tyConTyVars tycon
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType
192

193
194
195
196
197
198
199
200
201
202
203
204
    ifaceConDecl data_con 
	= ConDecl (getName data_con) (error "ifaceConDecl")
		  (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
          strict_marks   = dataConStrictMarks data_con
	  details | null field_labels
	    	  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	    	    VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
205

206
207
    	    	  | otherwise
	    	  = RecCon (zipWith mk_field strict_marks field_labels)
208

209
210
211
    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
212

213
214
215
216
    mk_field strict_mark field_label
	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))

ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249

ifaceTyCls (AnId id) 
  = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
  where
    id_type = idType id
    id_info = idInfo id

    hs_idinfo | opt_OmitInterfacePragmas = []
 	      | otherwise		 = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
					   strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo

    ------------  Arity  --------------
    arity_hsinfo = case arityInfo id_info of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []

    ------------ Caf Info --------------
    caf_hsinfo = case cafInfo id_info of
		   NoCafRefs -> [HsNoCafRefs]
		   otherwise -> []

    ------------ CPR Info --------------
    cpr_hsinfo = case cprInfo id_info of
		   ReturnsCPR -> [HsCprInfo]
		   NoCPRInfo  -> []

    ------------  Strictness  --------------
    strict_hsinfo = case strictnessInfo id_info of
			NoStrictnessInfo -> []
			info		 -> [HsStrictness info]


    ------------  Worker  --------------
250
    wrkr_hsinfo = case workerInfo id_info of
251
252
253
254
		    HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
		    NoWorker			 -> []

    ------------  Unfolding  --------------
255
256
257
    unfold_info = unfoldingInfo id_info
    inline_prag = inlinePragInfo id_info
    rhs		= unfoldingTemplate unfold_info
258
259
    unfold_hsinfo | neverUnfold unfold_info = []
		  | otherwise		    = [HsUnfold inline_prag (toUfExpr rhs)]
260
261
262
263
264
\end{code}


%************************************************************************
%*				 					*
265
\subsection{Instances and rules}
266
267
268
%*				 					*
%************************************************************************

269
270
271
272
\begin{code}			 
ifaceInstance :: DFunId -> RenamedInstDecl
ifaceInstance dfun_id
  = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc			 
273
  where
274
275
276
277
278
279
280
281
282
283
    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.
284

285
286
ifaceRule (id, BuiltinRule _)
  = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
287

288
289
290
291
292
293
ifaceRule (id, Rule name bndrs args rhs)
  = IfaceRule name (map toUfBndr bndrs) (getName id)
	      (map toUfExpr args) (toUfExpr rhs) noSrcLoc

bogusIfaceRule id
  = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
294
\end{code}
295
296
297
298


%************************************************************************
%*				 					*
299
\subsection{Compute final Ids}
300
%*				 					* 
301
302
%************************************************************************

303
304
305
A "final Id" has exactly the IdInfo for going into an interface file, or
exporting to another module.

306
\begin{code}
307
308
bindsToIds :: IdSet		-- These Ids are needed already
	   -> IdSet		-- Ids used at code-gen time; they have better pragma info!
309
	   -> [CoreBind]	-- In dependency order, later depend on earlier
310
311
	   -> [Id]		-- Set of Ids actually spat out, complete with exactly the IdInfo
				-- they need for exporting to another module
312

313
314
bindsToIds needed_ids codegen_ids binds
  = go needed_ids (reverse binds) []
315
316
317
		-- Reverse so that later things will 
		-- provoke earlier ones to be emitted
  where
318
319
320
321
322
	-- The 'needed' set contains the Ids that are needed by earlier
	-- interface file emissions.  If the Id isn't in this set, and isn't
	-- exported, there's no need to emit anything
    need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id 

323
    go needed [] emitted
324
325
	| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
					  (sep (map ppr (varSetElems needed)))
326
327
				       emitted
	| otherwise 		     = emitted
328

329
    go needed (NonRec id rhs : binds) emitted
330
331
	| need_id needed id
	= if omitIfaceSigForId id then
332
	    go (needed `delVarSet` id) binds (id:emitted)
333
334
335
	  else
	    go ((needed `unionVarSet` extras) `delVarSet` id)
	       binds
336
	       (new_id:emitted)
337
	| otherwise
338
	= go needed binds emitted
339
	where
340
	  (new_id, extras) = mkFinalId codegen_ids False id rhs
341
342
343

	-- Recursive groups are a bit more of a pain.  We may only need one to
	-- start with, but it may call out the next one, and so on.  So we
344
345
346
	-- have to look for a fixed point.  We don't want necessarily them all, 
	-- because without -O we may only need the first one (if we don't emit
	-- its unfolding)
347
    go needed (Rec pairs : binds) emitted
348
	= go needed' binds emitted' 
349
	where
350
	  (new_emitted, extras) = go_rec needed pairs
351
	  needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
352
	  emitted' = new_emitted ++ emitted 
353

354
    go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
355
    go_rec needed pairs
356
357
358
	| null needed_prs = ([], emptyVarSet)
	| otherwise 	  = (emitted ++           more_emitted,
			     extras `unionVarSet` more_extras)
359
	where
360
361
362
363
364
365
	  (needed_prs,leftover_prs)   = partition is_needed pairs
	  (emitted, extras_s)         = unzip [ mkFinalId codegen_ids True id rhs 
				    	      | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
	  extras	              = unionVarSets extras_s
	  (more_emitted, more_extras) = go_rec extras leftover_prs

366
	  is_needed (id,_) = need_id needed id
367
368
369
\end{code}


370

371
\begin{code}
372
373
374
375
376
377
378
379
mkFinalId :: IdSet		-- The Ids with arity info from the code generator
	  -> Bool			-- True <=> recursive, so don't include unfolding
	  -> Id
	  -> CoreExpr		-- The Id's right hand side
	  -> (Id, IdSet)		-- The emitted id, plus any *extra* needed Ids

mkFinalId codegen_ids is_rec id rhs
  = (id `setIdInfo` new_idinfo, new_needed_ids)
380
  where
381
    core_idinfo = idInfo id
382
383
384
385
    stg_idinfo  = case lookupVarSet codegen_ids id of
			Just id' -> idInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
				    idInfo id
386

387
388
389
    new_idinfo | opt_OmitInterfacePragmas
	       = vanillaIdInfo
 	       | otherwise		  
390
	       = core_idinfo `setArityInfo` 	 arity_info
391
392
393
394
395
396
			     `setCafInfo`   	 cafInfo stg_idinfo
			     `setUnfoldingInfo`	 unfold_info
			     `setWorkerInfo`	 worker_info
			     `setSpecInfo`	 emptyCoreRules
	-- We zap the specialisations because they are
	-- passed on separately through the modules IdCoreRules
397
398

    ------------  Arity  --------------
399
400
    arity_info = arityInfo stg_idinfo
    stg_arity  = arityLowerBound arity_info
sof's avatar
sof committed
401

402
    ------------  Worker  --------------
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
	-- We only treat a function as having a worker if
	-- the exported arity (which is now the number of visible lambdas)
	-- is the same as the arity at the moment of the w/w split
	-- If so, we can safely omit the unfolding inside the wrapper, and
	-- instead re-generate it from the type/arity/strictness info
	-- But if the arity has changed, we just take the simple path and
	-- put the unfolding into the interface file, forgetting the fact
	-- that it's a wrapper.  
	--
	-- How can this happen?  Sometimes we get
	--	f = coerce t (\x y -> $wf x y)
	-- at the moment of w/w split; but the eta reducer turns it into
	--	f = coerce t $wf
	-- which is perfectly fine except that the exposed arity so far as
	-- the code generator is concerned (zero) differs from the arity
	-- when we did the split (2).  
	--
	-- All this arises because we use 'arity' to mean "exactly how many
	-- top level lambdas are there" in interface files; but during the
	-- compilation of this module it means "how many things can I apply
	-- this to".
424
    worker_info = case workerInfo core_idinfo of
425
426
		     info@(HasWorker work_id wrap_arity)
			| wrap_arity == stg_arity -> info
427
428
429
			| otherwise	          -> pprTrace "ifaceId: arity change:" (ppr id) 
						     NoWorker
		     NoWorker		          -> NoWorker
430

431
432
433
    has_worker = case worker_info of
		   HasWorker _ _ -> True
		   other	 -> False
434

435
    HasWorker work_id _ = worker_info
436

437
    ------------  Unfolding  --------------
438
    inline_pragma  = inlinePragInfo core_idinfo
439
    dont_inline	   = isNeverInlinePrag inline_pragma
440
441
    loop_breaker   = isLoopBreaker (occInfo core_idinfo)
    bottoming_fn   = isBottomingStrictness (strictnessInfo core_idinfo)
442

443
444
445
446
447
    unfolding    = mkTopUnfolding rhs
    rhs_is_small = neverUnfold unfolding

    unfold_info | show_unfold = unfolding
		| otherwise   = noUnfolding
448

449
450
451
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
452
		  not loop_breaker	 &&
453
454
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
455

456

457
    ------------  Extra free Ids  --------------
458
459
460
461
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
462

463
464
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))

465
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
466
467
			-- Conceivably, the worker might come from
			-- another module
468
	       | otherwise = emptyVarSet
469

470
    unfold_ids | show_unfold = find_fvs rhs
471
	       | otherwise   = emptyVarSet
472

473
    find_fvs expr = exprSomeFreeVars interestingId expr
474

475
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
476
477
\end{code}

478

479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
\begin{code}
getRules :: [IdCoreRule] 	-- Orphan rules
	 -> [CoreBind]		-- Bindings, with rules in the top-level Ids
	 -> IdSet		-- Ids that are exported, so we need their rules
	 -> [IdCoreRule]
getRules orphan_rules binds emitted
  = orphan_rules ++ local_rules
  where
    local_rules  = [ (fn, rule)
 		   | fn <- bindersOfBinds binds,
		     fn `elemVarSet` emitted,
		     rule <- rulesRules (idSpecialisation fn),
		     not (isBuiltinRule rule),
				-- We can't print builtin rules in interface files
				-- Since they are built in, an importing module
				-- will have access to them anyway

			-- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
			-- from coming out, and to make it work properly we need to add ????
			--	(put it back in for now)
		     all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
				-- Spit out a rule only if all its lhs free vars are emitted
				-- This is a good reason not to do it when we emit the Id itself
		   ]
\end{code}


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
%************************************************************************
%*				 					*
\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
	       -> Maybe (ModIface, SDoc)	-- Nothing => no change; no need to write new Iface
						-- 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!
  = Just (new_iface, text "No old interface available")

addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, 
				       	   mi_decls   = old_decls,
				       	   mi_fixities = old_fixities }))
	       new_iface@(ModIface { mi_decls = new_decls,
				     mi_fixities = new_fixities })

  | no_output_change && no_usage_change
  = Nothing

  | otherwise		-- Add updated version numbers
537
  = Just (final_iface, pp_tc_diffs)
538
539
540
541
542
543
	
  where
    final_iface = new_iface { mi_version = new_version }
    new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
				vers_exports = bumpVersion no_export_change (vers_exports old_version),
				vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
544
				vers_decls   = tc_vers }
545

546
    no_output_change = no_tc_change && no_rule_change && no_export_change
547
548
549
550
551
552
553
554
555
    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

	-- 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.
    old_vers_decls = vers_decls old_version
556
557
    (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
						       (dcl_tycl old_decls) (dcl_tycl new_decls)
558
559
560



561
diffDecls :: NameEnv Version				-- Old version map
562
	  -> NameEnv Fixity -> NameEnv Fixity		-- Old and new fixities
563
	  -> [RenamedTyClDecl] -> [RenamedTyClDecl]	-- Old and new decls
564
565
566
567
	  -> (Bool,		-- True <=> no change
	      SDoc,		-- Record of differences
	      NameEnv Version)	-- New version

568
diffDecls old_vers old_fixities new_fixities old new
569
570
  = diff True empty emptyNameEnv old new
  where
571
572
573
574
575
	-- 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)
    same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n

576
577
578
579
580
581
582
    diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
    diff ok_so_far pp new_vers old []      = (False,     pp, new_vers)
    diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
    diff ok_so_far pp new_vers (od:ods) (nd:nds)
	= case od_name `compare` nd_name of
		LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
		GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
583
584
		EQ | od `eq_tc` nd -> diff ok_so_far pp 		   new_vers  ods nds
		   | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
585
	where
586
587
 	  od_name = tyClDeclName od
 	  nd_name = tyClDeclName nd
588
589
590
591
592
593
594
595
	  new_vers' = extendNameEnv new_vers nd_name 
				    (bumpVersion True (lookupNameEnv_NF old_vers od_name))

    only_old d   = ptext SLIT("Only in old iface:") <+> ppr d
    only_new d   = ptext SLIT("Only in new iface:") <+> ppr d
    changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$ 
							 (ptext SLIT("New:") <+> ppr nd))
\end{code}
596
597
598
599
600
601
602
603
604
605



%************************************************************************
%*				 					*
\subsection{Writing an interface file}
%*				 					*
%************************************************************************

\begin{code}
606
607
608
609
610
611
612
613
614
615
616
writeIface :: Finder -> Maybe ModIface -> IO ()
writeIface finder Nothing
  = return ()

writeIface finder (Just mod_iface)
  = do	{ maybe_found <- finder mod_name ;
	; case maybe_found of {
	    Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ;
	    Just (_, locn) ->

    do	{ let filename = hi_file locn 
617
618
619
	; if_hdl <- openFile filename WriteMode
	; printForIface if_hdl (pprIface mod_iface)
	; hClose if_hdl
620
621
622
623
	}}}
  where
    mod_name = moduleName (mi_module mod_iface)
	 
624
625
626
627
628
629
630
631
632
pprIface iface
 = vcat [ ptext SLIT("__interface")
		<+> doubleQuotes (ptext opt_InPackage)
		<+> 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")

633
	, vcat (map pprExport (mi_exports iface))
634
635
636
637
638
639
640
641
642
	, vcat (map pprUsage (mi_usages iface))

	, pprIfaceDecls (vers_decls version_info) 
			(mi_fixities iface)
			(mi_decls iface)

	, pprDeprecs (mi_deprecs iface)
	]
  where
643
    version_info = mi_version iface
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
    exp_vers     = vers_exports version_info
    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}
pprExport :: (ModuleName, Avails) -> SDoc
pprExport (mod, items)
659
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
660
  where
661
662
663
664
665
    ppr_name :: Name -> SDoc	-- Print the occurrence name only
    ppr_name n = ppr (nameOccName n)

    pp_avail :: AvailInfo -> SDoc
    pp_avail (Avail name)      = ppr_name name
666
    pp_avail (AvailTC name []) = empty
667
    pp_avail (AvailTC name ns) = hcat [ppr_name name, bang, pp_export ns']
668
669
670
671
672
673
				where
				  bang | name `elem` ns = empty
				       | otherwise	= char '|'
				  ns' = filter (/= name) ns
    
    pp_export []    = empty
674
    pp_export names = braces (hsep (map ppr_name names))
675
676
677
678
679
680
\end{code}


\begin{code}
pprUsage :: ImportVersion Name -> SDoc
pprUsage (m, has_orphans, is_boot, whats_imported)
681
  = hsep [ptext SLIT("import"), ppr m, 
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
	  pp_orphan, pp_boot,
	  pp_versions whats_imported
    ] <> semi
  where
    pp_orphan | has_orphans = char '!'
	      | otherwise   = empty
    pp_boot   | is_boot     = char '@'
              | otherwise   = empty

	-- Importing the whole module is indicated by an empty list
    pp_versions NothingAtAll   		    = empty
    pp_versions (Everything v) 		    = dcolon <+> int v
    pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr 
					      <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]

	-- HACK for the moment: print the export-list version even if
	-- we don't use it, so that syntax of interface files doesn't change
    pp_export_version Nothing  = int 1
    pp_export_version (Just v) = int v
\end{code}

\begin{code}
pprIfaceDecls version_map fixity_map decls
  = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
	 , vcat (map ppr_decl (dcl_tycl decls))
	 , pprRules (dcl_rules decls)
	 ]
  where
    ppr_decl d  = (ppr_vers d <+> ppr d <> semi) $$ ppr_fixes d

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

	-- Print fixities relevant to the decl
718
719
720
721
    ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi
		       | (n,_) <- tyClDeclNames d, 
			 Just fix <- [lookupNameEnv fixity_map n]
		       ]
722
723
724
725
726
727
\end{code}

\begin{code}
pprRules []    = empty
pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]

728
729
730
731
732
733
734
735
736
737
pprDeprecs NoDeprecs = empty
pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
		     where
		       guts = case deprecs of
				DeprecAll txt  -> ptext txt
				DeprecSome env -> pp_deprecs env

pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
	       where
		 pp_deprec (name, txt) = pprOccName (nameOccName name) <+> ptext txt
738
\end{code}