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

\begin{code}
7
8
module MkIface (
	startIface, endIface,
9
	ifaceMain,
10
	ifaceDecls
11
    ) where
12

13
14
#include "HsVersions.h"

sof's avatar
sof committed
15
16
import IO		( Handle, hPutStr, openFile, 
			  hClose, hPutStrLn, IOMode(..) )
17
18

import HsSyn
19
import RdrHsSyn		( RdrName(..) )
20
21
22
23
import RnHsSyn		( RenamedHsModule )
import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..),
			  pprModule
			)
24
import RnMonad
sof's avatar
sof committed
25
import RnEnv		( availName, ifaceFlavour )
26
27

import TcInstUtil	( InstInfo(..) )
28
import WorkWrap		( getWorkerIdAndCons )
29
30

import CmdLineOpts
sof's avatar
sof committed
31
import Id		( idType, dataConRawArgTys, dataConFieldLabels, 
32
			  idInfo, omitIfaceSigForId,
33
			  dataConStrictMarks, StrictnessMark(..), 
34
35
			  IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet, 
			  isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
36
			  pprId, getIdSpecialisation,
37
			  Id
38
			)
39
import IdInfo		( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
40
			  arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, 
41
			  bottomIsGuaranteed, workerExists, 
42
			)
43
import CoreSyn		( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
sof's avatar
sof committed
44
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
45
import FreeVars		( addExprFVs )
sof's avatar
sof committed
46
import Name		( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
sof's avatar
sof committed
47
48
			  OccName, occNameString, nameOccName, nameString, isExported,
			  Name {-instance NamedThing-}, Provenance, NamedThing(..)
49
			)
50
51
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
52
			)
53
import Class		( Class, classBigSig )
54
import SpecEnv		( specEnvToList )
55
56
57
import FieldLabel	( fieldLabelName, fieldLabelType )
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy,
			  mkTyVarTys, Type, ThetaType
sof's avatar
sof committed
58
		        )
59

60
import PprEnv		-- not sure how much...
61
62
63
import PprType
import PprCore		( pprIfaceUnfolding )

sof's avatar
sof committed
64
import Bag		( bagToList, isEmptyBag )
65
import Maybes		( catMaybes, maybeToBool )
66
import FiniteMap	( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap )
67
import UniqFM		( UniqFM, lookupUFM, listToUFM )
68
69
import Util		( sortLt, zipWithEqual, zipWith3Equal, mapAccumL )
import Outputable
70
71
72
\end{code}

We have a function @startIface@ to open the output file and put
73
(something like) ``interface Foo'' in it.  It gives back a handle
74
75
76
77
78
79
80
81
82
for subsequent additions to the interface file.

We then have one-function-per-block-of-interface-stuff, e.g.,
@ifaceExportList@ produces the @__exports__@ section; it appends
to the handle provided by @startIface@.

\begin{code}
startIface  :: Module
	    -> IO (Maybe Handle) -- Nothing <=> don't do an interface
83
84
85

ifaceMain   :: Maybe Handle
	    -> InterfaceDetails
86
	    -> IO ()
87
88
89


ifaceDecls :: Maybe Handle
sof's avatar
sof committed
90
	   -> [TyCon] -> [Class]
91
	   -> Bag InstInfo 
92
93
94
95
96
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBinding]	-- In dependency order, later depend on earlier
	   -> IO ()

endIface    :: Maybe Handle -> IO ()
97
98
99
100
101
102
\end{code}

\begin{code}
startIface mod
  = case opt_ProduceHi of
      Nothing -> return Nothing -- not producing any .hi file
sof's avatar
sof committed
103
104
105
      Just fn -> do
	if_hdl <- openFile fn WriteMode
	hPutStrLn if_hdl ("_interface_ "++ _UNPK_ mod ++ ' ':show (PROJECTVERSION :: Int))
106
107
108
109
	return (Just if_hdl)

endIface Nothing	= return ()
endIface (Just if_hdl)	= hPutStr if_hdl "\n" >> hClose if_hdl
110
111
\end{code}

112

113
114
115
116
117
118
119
120
121
122
123
\begin{code}
ifaceMain Nothing iface_stuff = return ()
ifaceMain (Just if_hdl)
	  (import_usages, ExportEnv avails fixities, instance_modules)
  =
    ifaceInstanceModules	if_hdl instance_modules		>>
    ifaceUsages			if_hdl import_usages		>>
    ifaceExports		if_hdl avails			>>
    ifaceFixities		if_hdl fixities			>>
    return ()

sof's avatar
sof committed
124
ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
125
ifaceDecls (Just hdl)
sof's avatar
sof committed
126
	   tycons classes
127
	   inst_infos
128
	   final_ids binds
sof's avatar
sof committed
129
  | null_decls = return ()		 
130
	--  You could have a module with just (re-)exports/instances in it
131
  | otherwise
132
133
  = ifaceInstances hdl inst_infos		>>= \ needed_ids ->
    hPutStr hdl "_declarations_\n"		>>
sof's avatar
sof committed
134
135
    ifaceClasses hdl classes			>>
    ifaceTyCons hdl tycons			>>
136
    ifaceBinds hdl needed_ids final_ids binds	>>
137
    return ()
sof's avatar
sof committed
138
  where
sof's avatar
sof committed
139
140
141
142
     null_decls = null binds      && 
		  null tycons     &&
	          null classes    && 
	          isEmptyBag inst_infos
143
144
145
146
147
148
\end{code}

\begin{code}
ifaceUsages if_hdl import_usages
  = hPutStr if_hdl "_usages_\n"   >>
    hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
149
  where
150
151
152
    upp_uses (m, hif, mv, whats_imported)
      = hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"),
	      upp_import_versions whats_imported
sof's avatar
sof committed
153
	] <> semi
154

155
156
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
157

158
159
160
	-- For imported versions we do print the version number
    upp_import_versions (Specifically nvs)
      = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]
161

162
163
164
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
  = hPutStr if_hdl "_instance_modules_\n" >>
165
    printForIface if_hdl (hsep (map ptext (sortLt (<) imods))) >>
166
    hPutStr if_hdl "\n"
167

168
169
170
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
  = hPutStr if_hdl "_exports_\n"			>>
171
172
173
174
175
    hPutCol if_hdl do_one_module (fmToList export_fm)
  where
	-- Sort them into groups by module
    export_fm :: FiniteMap Module [AvailInfo]
    export_fm = foldr insert emptyFM avails
176

177
    insert NotAvailable efm = efm
178
179
    insert avail efm = addToFM_C (++) efm mod [avail] 
		     where
sof's avatar
sof committed
180
		       mod = nameModule (availName avail)
181
182

	-- Print one module's worth of stuff
sof's avatar
sof committed
183
184
    do_one_module (mod_name, avails@(avail1:_))
	= hsep [pp_hif (ifaceFlavour (availName avail1)), 
185
		pprModule mod_name,
sof's avatar
sof committed
186
187
188
189
190
191
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

-- The "!" indicates that the exported things came from a hi-boot interface 
pp_hif HiFile     = empty
pp_hif HiBootFile = char '!'
192

193
194
195
196
197
198
199
200
201
202
203
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
  = hPutStr if_hdl "_fixities_\n"		>>
    hPutCol if_hdl upp_fixity fixities
\end{code}			 

%************************************************************************
%*				 					*
\subsection{Instance declarations}
%*				 					*
%************************************************************************
204

205
206

\begin{code}			 
207
208
209
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
  | null togo_insts = return emptyIdSet		 
210
  | otherwise 	    = hPutStr if_hdl "_instances_\n" >>
211
212
		      hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
		      return needed_ids
213
214
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
215
    needed_ids  = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
216
217
218
219
220
221
222
223
224
225
    is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
				 
    -------			 
    lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
      = getOccName dfun_id1 < getOccName dfun_id2
	-- The dfuns are assigned names df1, df2, etc, in order of original textual
	-- occurrence, and this makes as good a sort order as any

    -------			 
226
    pp_inst (InstInfo clas tvs tys theta _ dfun_id _ _ _)
227
      = let			 
228
	    forall_ty     = mkSigmaTy tvs theta (mkDictTy clas tys)
sof's avatar
sof committed
229
	    renumbered_ty = nmbrGlobalType forall_ty
230
	in			 
231
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
232
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
233
234
\end{code}

235
236
237
238
239
240
241

%************************************************************************
%*				 					*
\subsection{Printing values}
%*				 					*
%************************************************************************

242
\begin{code}
243
244
245
246
247
248
ifaceId :: (Id -> IdInfo)		-- This function "knows" the extra info added
					-- by the STG passes.  Sigh

	    -> IdSet			-- Set of 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
249
	    -> Bool			-- True <=> recursive, so don't print unfolding
250
251
	    -> Id
	    -> CoreExpr			-- The Id's right hand side
252
	    -> Maybe (SDoc, IdSet)	-- The emitted stuff, plus a possibly-augmented set of needed Ids
253

254
255
256
ifaceId get_idinfo needed_ids is_rec id rhs
  | not (id `elementOfIdSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
	 (isExported id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
257
258
  = Nothing 		-- Well, that was easy!

259
ifaceId get_idinfo needed_ids is_rec id rhs
sof's avatar
sof committed
260
  = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
261
  where
sof's avatar
sof committed
262
    pp_double_semi = ptext SLIT(";;")
263
    idinfo         = get_idinfo id
264
    inline_pragma  = inlinePragInfo idinfo
265

266
267
    ty_pretty  = pprType (nmbrGlobalType (idType id))
    sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
268

269
    prag_pretty 
sof's avatar
sof committed
270
     | opt_OmitInterfacePragmas = empty
271
     | otherwise		= hsep [arity_pretty, strict_pretty, unfold_pretty, spec_pretty, pp_double_semi]
272
273

    ------------  Arity  --------------
274
    arity_pretty  = ppArityInfo (arityInfo idinfo)
275
276
277

    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
278
    has_worker    = workerExists strict_info
279
    strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
sof's avatar
sof committed
280
281

    wrkr_pretty | not has_worker = empty
282
283
284
		| null con_list  = pprId work_id
		| otherwise      = pprId work_id <+> 
				   braces (hsep (map (pprId) con_list))
sof's avatar
sof committed
285
286
287

    (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
    con_list 		   = idSetToList wrapper_cons
288
289

    ------------  Unfolding  --------------
290
    unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
sof's avatar
sof committed
291
		  | otherwise   = empty
292

293
294
295
296
297
    unfold_herald = case inline_pragma of
			IMustBeINLINEd   -> SLIT("_U_")
			IWantToBeINLINEd -> SLIT("_U_")
			other		 -> SLIT("_u_")

298
299
    show_unfold = not implicit_unfolding &&	-- Not unnecessary
		  unfolding_is_ok		-- Not dangerous
300

sof's avatar
sof committed
301
    implicit_unfolding = has_worker ||
302
303
			 bottomIsGuaranteed strict_info

304
305
306
307
308
309
310
311
312
313
314
315
316
317
    unfolding_is_ok
	= case inline_pragma of
	    IMustBeINLINEd    -> True
	    IWantToBeINLINEd  -> True
	    IMustNotBeINLINEd -> False
	    NoPragmaInfo      -> case guidance of
					UnfoldNever -> False	-- Too big
					other       -> True

    guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs

    ------------  Specialisations --------------
    spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
    pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
318
319
320
				       if null tyvars then ptext SLIT("[ ]")
						      else brackets (interpp'SP tyvars),
					-- The lexer interprets "[]" as a CONID.  Sigh.
321
322
				       hsep (map pprParendType tys),
				       ptext SLIT("="),
323
				       pprIfaceUnfolding rhs
324
				 ]					
325
326
327
328
329
330
331
332
333
    
    ------------  Extra free Ids  --------------
    new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)	`unionIdSets` 
		     extra_ids

    extra_ids | opt_OmitInterfacePragmas = emptyIdSet
	      | otherwise		 = worker_ids	`unionIdSets`
					   unfold_ids

sof's avatar
sof committed
334
335
    worker_ids | has_worker = unitIdSet work_id
	       | otherwise  = emptyIdSet
336
337
338
339
340

    unfold_ids | show_unfold = free_vars
	       | otherwise   = emptyIdSet
			     where
			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
341
342
343
			       interesting bound id = isLocallyDefined id &&
						      not (id `elementOfIdSet` bound) &&
						      not (omitIfaceSigForId id)
344
345
346
\end{code}

\begin{code}
347
ifaceBinds :: Handle
348
	   -> IdSet		-- These Ids are needed already
349
350
351
352
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBinding]	-- In dependency order, later depend on earlier
	   -> IO ()

353
ifaceBinds hdl needed_ids final_ids binds
354
  = mapIO (printForIface hdl) pretties >>
355
    hPutStr hdl "\n"
356
  where
357
358
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
359
			Just id' -> idInfo id'
360
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
361
				    idInfo id
362

363
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
364
365
366
						-- provoke earlier ones to be emitted
    go needed [] = if not (isEmptyIdSet needed) then
			pprTrace "ifaceBinds: free vars:" 
367
				  (sep (map ppr (idSetToList needed))) $
368
369
370
371
372
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
373
	= case ifaceId get_idinfo needed False id rhs of
374
375
376
377
378
379
380
381
382
383
384
385
386
		Nothing		       -> go needed binds
		Just (pretty, needed') -> pretty : go needed' binds

	-- 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
	-- have to look for a fixed point.
    go needed (Rec pairs : binds)
	= pretties ++ go needed'' binds
	where
	  (needed', pretties) = go_rec needed pairs
	  needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
		-- Later ones may spuriously cause earlier ones to be "needed" again

387
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
388
389
390
391
392
393
394
395
396
    go_rec needed pairs
	| null pretties = (needed, [])
	| otherwise	= (final_needed, more_pretties ++ pretties)
	where
	  reduced_pairs		 	= [pair | (pair,Nothing) <- pairs `zip` maybes]
	  pretties		 	= catMaybes maybes
	  (needed', maybes)	 	= mapAccumL do_one needed pairs
	  (final_needed, more_pretties) = go_rec needed' reduced_pairs

397
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
398
399
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
400
401
402
\end{code}


sof's avatar
sof committed
403
404
405
406
407
408
409
410
411
412
413
414
415
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************

\begin{code}
ifaceTyCons hdl tycons   = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons ))
ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))

for_iface_name name = isLocallyDefined name && 
		      not (isWiredInName name)

416
417
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
418
419
420
421
\end{code}


\begin{code}
422
423
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
424
425
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
426
427
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
428
	   ptext SLIT("="),
429
	   ppr ty,
430
431
	   semi
    ]
sof's avatar
sof committed
432
  where
433
434
    (tyvars, ty) = getSynTyConDefn tycon

435
ifaceTyCon tycon
436
437
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
438
439
440
	   ppr_decl_context (tyConTheta tycon),
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
441
442
443
444
445
446
447
	   ptext SLIT("="),
	   hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))),
	   semi
    ]
  where
    keyword | isNewTyCon tycon = SLIT("newtype")
	    | otherwise	       = SLIT("data")
sof's avatar
sof committed
448
449
450

    ppr_con data_con 
	| null field_labels
451
	= hsep [ ppr name,
sof's avatar
sof committed
452
453
454
455
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
456
	= hsep [ ppr name,
sof's avatar
sof committed
457
458
459
460
461
462
463
464
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
           field_labels   = dataConFieldLabels data_con
	   arg_tys        = dataConRawArgTys   data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

465
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
466
467
468
469
470
471
472
473

    ppr_strict_mark NotMarkedStrict = empty
    ppr_strict_mark MarkedStrict    = ptext SLIT("! ")
				-- The extra space helps the lexical analyser that lexes
				-- interface files; it doesn't make the rigid operator/identifier
				-- distinction, so "!a" is a valid identifier so far as it is concerned

    ppr_field (strict_mark, field_label)
474
	= hsep [ ppr (fieldLabelName field_label),
sof's avatar
sof committed
475
		  ptext SLIT("::"),
476
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
477
478
		]

479
480
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
481

482
ifaceClass clas
sof's avatar
sof committed
483
  = hsep [ptext SLIT("class"),
484
485
486
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
487
488
489
490
	   pp_ops,
	   semi
	  ]
   where
491
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
492

sof's avatar
sof committed
493
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
494
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
495
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
496
497
			  ]

sof's avatar
sof committed
498
     ppr_classop sel_id maybe_defm
499
500
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
501
502
		if maybeToBool maybe_defm then equals else empty,
	        ptext SLIT("::"),
503
		ppr op_ty
sof's avatar
sof committed
504
505
506
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
507

508
509
510
ppr_decl_context :: ThetaType -> SDoc
ppr_decl_context [] = empty
ppr_decl_context theta
sof's avatar
sof committed
511
512
513
514
  = braces (hsep (punctuate comma (map (ppr_dict) theta)))
    <> 
    ptext SLIT(" =>")
  where
515
    ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys)
sof's avatar
sof committed
516
517
\end{code}

518
519
520
521
522
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
523
524
525
526
527
528

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

529
\begin{code}
sof's avatar
sof committed
530
upp_avail NotAvailable      = empty
531
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
532
533
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
534
			    where
sof's avatar
sof committed
535
			      bang | name `elem` ns = empty
sof's avatar
sof committed
536
				   | otherwise	    = char '|'
537
			      ns' = filter (/= name) ns
538

sof's avatar
sof committed
539
upp_export []    = empty
sof's avatar
sof committed
540
upp_export names = parens (hsep (map (upp_occname . getOccName) names)) 
541

542
upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
543

544
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
545
546
ppr_unqual_name name = upp_occname (getOccName name)

547
upp_occname :: OccName -> SDoc
sof's avatar
sof committed
548
upp_occname occ = ptext (occNameString occ)
549
550
\end{code}

551

552
%************************************************************************
553
554
555
%*				 					*
\subsection{Comparisons
%*				 					*
556
%************************************************************************
557
				 
558

559
560
561
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
562

563
564
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
565

566
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
567

568
569
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
570

571
572
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
573

574
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
575
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
576

577
sort_versions vs = sortLt lt_vers vs
578

579
580
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
581
582
\end{code}

583

584
\begin{code}
585
hPutCol :: Handle 
586
	-> (a -> SDoc)
587
588
	-> [a]
	-> IO ()
589
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
590
591
592
593

mapIO :: (a -> IO b) -> [a] -> IO ()
mapIO f []     = return ()
mapIO f (x:xs) = f x >> mapIO f xs
594
\end{code}