MkIface.lhs 25.5 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
9
	mkModDetails, mkModDetailsFromIface, completeIface, 
	writeIface, pprIface
10
  ) where
11

12
13
#include "HsVersions.h"

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

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

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


66
67
68
69
70
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
71

72
\begin{code}
73
74
75
76
77
78
79
80
81
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 }
82
  where
83
84
85
86
87
88
89
90
91
92
	-- 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

93
94
95
96
    final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
			   (mkVarSet stg_ids)
			   tidy_binds

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
	-- 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
119

120

121
122
123
124
125
126
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
127

128
129
130
131
132
133
134
	-- 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 
135
136
137
138
139
  = 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 }
140

141
142
143
     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)
144
145
\end{code}

146

147
148
%************************************************************************
%*				 					*
149
\subsection{Types and classes}
150
151
%*				 					*
%************************************************************************
152

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

166
167
168
169
170
171
172
173
174
     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)
175

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

182
183
184
185
186
187
188
189
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")
190
  where
191
192
193
    tyvars = tyConTyVars tycon
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType
194

195
196
197
198
199
200
201
202
203
204
205
206
    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)
207

208
209
    	    	  | otherwise
	    	  = RecCon (zipWith mk_field strict_marks field_labels)
210

211
212
213
    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
214

215
216
217
218
    mk_field strict_mark field_label
	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))

ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
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
250
251

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  --------------
252
    wrkr_hsinfo = case workerInfo id_info of
253
254
255
256
		    HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
		    NoWorker			 -> []

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


%************************************************************************
%*				 					*
267
\subsection{Instances and rules}
268
269
270
%*				 					*
%************************************************************************

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

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

290
291
292
293
294
295
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
296
\end{code}
297
298
299
300


%************************************************************************
%*				 					*
301
\subsection{Compute final Ids}
302
%*				 					* 
303
304
%************************************************************************

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

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

315
316
bindsToIds needed_ids codegen_ids binds
  = go needed_ids (reverse binds) []
317
318
319
		-- Reverse so that later things will 
		-- provoke earlier ones to be emitted
  where
320
321
322
323
324
	-- 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 

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

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

	-- 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
346
347
348
	-- 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)
349
    go needed (Rec pairs : binds) emitted
350
	= go needed' binds emitted' 
351
	where
352
	  (new_emitted, extras) = go_rec needed pairs
353
	  needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
354
	  emitted' = new_emitted ++ emitted 
355

356
    go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
357
    go_rec needed pairs
358
359
360
	| null needed_prs = ([], emptyVarSet)
	| otherwise 	  = (emitted ++           more_emitted,
			     extras `unionVarSet` more_extras)
361
	where
362
363
364
365
366
367
	  (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

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


372

373
\begin{code}
374
375
376
377
378
379
380
381
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)
382
  where
383
    core_idinfo = idInfo id
384
385
386
387
    stg_idinfo  = case lookupVarSet codegen_ids id of
			Just id' -> idInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
				    idInfo id
388

389
390
391
    new_idinfo | opt_OmitInterfacePragmas
	       = vanillaIdInfo
 	       | otherwise		  
392
	       = core_idinfo `setArityInfo` 	 arity_info
393
394
395
396
397
398
			     `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
399
400

    ------------  Arity  --------------
401
402
    arity_info = arityInfo stg_idinfo
    stg_arity  = arityLowerBound arity_info
sof's avatar
sof committed
403

404
    ------------  Worker  --------------
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
	-- 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".
426
    worker_info = case workerInfo core_idinfo of
427
428
		     info@(HasWorker work_id wrap_arity)
			| wrap_arity == stg_arity -> info
429
430
431
			| otherwise	          -> pprTrace "ifaceId: arity change:" (ppr id) 
						     NoWorker
		     NoWorker		          -> NoWorker
432

433
434
435
    has_worker = case worker_info of
		   HasWorker _ _ -> True
		   other	 -> False
436

437
    HasWorker work_id _ = worker_info
438

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

445
446
447
448
449
    unfolding    = mkTopUnfolding rhs
    rhs_is_small = neverUnfold unfolding

    unfold_info | show_unfold = unfolding
		| otherwise   = noUnfolding
450

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

458

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

465
466
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))

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

472
    unfold_ids | show_unfold = find_fvs rhs
473
	       | otherwise   = emptyVarSet
474

475
    find_fvs expr = exprSomeFreeVars interestingId expr
476

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

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
506
507
\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}


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
%************************************************************************
%*				 					*
\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
539
  = Just (final_iface, pp_tc_diffs)
540
541
542
543
544
545
	
  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),
546
				vers_decls   = tc_vers }
547

548
    no_output_change = no_tc_change && no_rule_change && no_export_change
549
550
551
552
553
554
555
556
557
    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
558
559
    (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
						       (dcl_tycl old_decls) (dcl_tycl new_decls)
560
561
562



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

570
diffDecls old_vers old_fixities new_fixities old new
571
572
  = diff True empty emptyNameEnv old new
  where
573
574
575
576
577
	-- 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

578
579
580
581
582
583
584
    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
585
586
		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
587
	where
588
589
 	  od_name = tyClDeclName od
 	  nd_name = tyClDeclName nd
590
591
592
593
594
595
596
597
	  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}
598
599
600
601
602
603
604
605
606
607



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

\begin{code}
608
609
writeIface :: FilePath -> Maybe ModIface -> IO ()
writeIface hi_path Nothing
610
611
  = return ()

612
613
writeIface hi_path (Just mod_iface)
  = do	{ if_hdl <- openFile hi_path WriteMode
614
615
	; printForIface if_hdl (pprIface mod_iface)
	; hClose if_hdl
616
	}
617
	 
618
pprIface :: ModIface -> SDoc
619
620
621
622
623
624
625
626
627
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")

628
	, vcat (map pprExport (mi_exports iface))
629
630
631
632
633
634
635
636
637
	, vcat (map pprUsage (mi_usages iface))

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

	, pprDeprecs (mi_deprecs iface)
	]
  where
638
    version_info = mi_version iface
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
    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)
654
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
655
  where
656
657
658
659
660
    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
661
    pp_avail (AvailTC name []) = empty
662
    pp_avail (AvailTC name ns) = hcat [ppr_name name, bang, pp_export ns']
663
664
665
666
667
668
				where
				  bang | name `elem` ns = empty
				       | otherwise	= char '|'
				  ns' = filter (/= name) ns
    
    pp_export []    = empty
669
    pp_export names = braces (hsep (map ppr_name names))
670
671
672
673
674
675
\end{code}


\begin{code}
pprUsage :: ImportVersion Name -> SDoc
pprUsage (m, has_orphans, is_boot, whats_imported)
676
  = hsep [ptext SLIT("import"), ppr m, 
677
678
679
680
681
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
	  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
713
714
715
716
    ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi
		       | (n,_) <- tyClDeclNames d, 
			 Just fix <- [lookupNameEnv fixity_map n]
		       ]
717
718
719
720
721
722
\end{code}

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

723
724
725
726
727
728
729
730
731
732
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
733
\end{code}