MkIface.lhs 18.2 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, 
sof's avatar
sof committed
32
			  getIdInfo, getInlinePragma, omitIfaceSigForId,
33
			  dataConStrictMarks, StrictnessMark(..), 
34
35
36
37
			  IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet, 
			  isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
			  pprId,
			  Id
sof's avatar
sof committed
38

39
			)
40
import IdInfo		( IdInfo, StrictnessInfo, ArityInfo, 
41
			  arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, 
42
			  bottomIsGuaranteed, workerExists, 
43
			)
44
import PragmaInfo	( PragmaInfo(..) )
45
import CoreSyn		( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
sof's avatar
sof committed
46
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
47
import FreeVars		( addExprFVs )
sof's avatar
sof committed
48
import Name		( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
sof's avatar
sof committed
49
50
			  OccName, occNameString, nameOccName, nameString, isExported,
			  Name {-instance NamedThing-}, Provenance, NamedThing(..)
51
			)
52
53
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
54
			)
55
56
57
58
import Class		( Class, classBigSig )
import FieldLabel	( fieldLabelName, fieldLabelType )
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy,
			  mkTyVarTys, Type, ThetaType
sof's avatar
sof committed
59
		        )
60

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

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

We have a function @startIface@ to open the output file and put
74
(something like) ``interface Foo'' in it.  It gives back a handle
75
76
77
78
79
80
81
82
83
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
84
85
86

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


ifaceDecls :: Maybe Handle
sof's avatar
sof committed
91
	   -> [TyCon] -> [Class]
92
	   -> Bag InstInfo 
93
94
95
96
97
	   -> [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 ()
98
99
100
101
102
103
\end{code}

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

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

113

114
115
116
117
118
119
120
121
122
123
124
\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
125
ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
126
ifaceDecls (Just hdl)
sof's avatar
sof committed
127
	   tycons classes
128
	   inst_infos
129
	   final_ids binds
sof's avatar
sof committed
130
  | null_decls = return ()		 
131
	--  You could have a module with just (re-)exports/instances in it
132
  | otherwise
133
134
  = ifaceInstances hdl inst_infos		>>= \ needed_ids ->
    hPutStr hdl "_declarations_\n"		>>
sof's avatar
sof committed
135
136
    ifaceClasses hdl classes			>>
    ifaceTyCons hdl tycons			>>
137
    ifaceBinds hdl needed_ids final_ids binds	>>
138
    return ()
sof's avatar
sof committed
139
  where
sof's avatar
sof committed
140
141
142
143
     null_decls = null binds      && 
		  null tycons     &&
	          null classes    && 
	          isEmptyBag inst_infos
144
145
146
147
148
149
\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)
150
  where
151
152
153
    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
154
	] <> semi
155

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

159
160
161
	-- 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 ]
162

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

169
170
171
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
  = hPutStr if_hdl "_exports_\n"			>>
172
173
174
175
176
    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
177

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

	-- Print one module's worth of stuff
sof's avatar
sof committed
184
185
    do_one_module (mod_name, avails@(avail1:_))
	= hsep [pp_hif (ifaceFlavour (availName avail1)), 
186
		pprModule mod_name,
sof's avatar
sof committed
187
188
189
190
191
192
		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 '!'
193

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

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

206
207

\begin{code}			 
208
209
210
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
  | null togo_insts = return emptyIdSet		 
211
  | otherwise 	    = hPutStr if_hdl "_instances_\n" >>
212
213
		      hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
		      return needed_ids
214
215
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
216
    needed_ids  = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
217
218
219
220
221
222
223
224
225
226
    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

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

236
237
238
239
240
241
242

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

243
\begin{code}
244
245
246
247
248
249
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
250
	    -> Bool			-- True <=> recursive, so don't print unfolding
251
252
	    -> Id
	    -> CoreExpr			-- The Id's right hand side
253
	    -> Maybe (SDoc, IdSet)	-- The emitted stuff, plus a possibly-augmented set of needed Ids
254

255
256
257
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
258
259
  = Nothing 		-- Well, that was easy!

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

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

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

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

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

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

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

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

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

sof's avatar
sof committed
299
300
    show_unfold = not implicit_unfolding && 		-- Not unnecessary
		  not dodgy_unfolding			-- Not dangerous
301

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

sof's avatar
sof committed
305
306
    dodgy_unfolding = case guidance of 			-- True <=> too big to show, or the Inline pragma
			UnfoldNever -> True		-- says it shouldn't be inlined
307
308
309
			other       -> False

    guidance    = calcUnfoldingGuidance inline_pragma
310
311
312
313
314
315
316
317
318
319
320
321
					opt_InterfaceUnfoldThreshold
					rhs

    
    ------------  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
322
323
    worker_ids | has_worker = unitIdSet work_id
	       | otherwise  = emptyIdSet
324
325
326
327
328

    unfold_ids | show_unfold = free_vars
	       | otherwise   = emptyIdSet
			     where
			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
329
330
331
			       interesting bound id = isLocallyDefined id &&
						      not (id `elementOfIdSet` bound) &&
						      not (omitIfaceSigForId id)
332
333
334
\end{code}

\begin{code}
335
ifaceBinds :: Handle
336
	   -> IdSet		-- These Ids are needed already
337
338
339
340
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBinding]	-- In dependency order, later depend on earlier
	   -> IO ()

341
ifaceBinds hdl needed_ids final_ids binds
342
  = mapIO (printForIface hdl) pretties >>
343
    hPutStr hdl "\n"
344
  where
345
346
347
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
			Just id' -> getIdInfo id'
348
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
349
350
				    getIdInfo id

351
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
352
353
354
						-- provoke earlier ones to be emitted
    go needed [] = if not (isEmptyIdSet needed) then
			pprTrace "ifaceBinds: free vars:" 
355
				  (sep (map ppr (idSetToList needed))) $
356
357
358
359
360
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
361
	= case ifaceId get_idinfo needed False id rhs of
362
363
364
365
366
367
368
369
370
371
372
373
374
		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

375
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
376
377
378
379
380
381
382
383
384
    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

385
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
386
387
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
388
389
390
\end{code}


sof's avatar
sof committed
391
392
393
394
395
396
397
398
399
400
401
402
403
%************************************************************************
%*				 					*
\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)

404
405
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
406
407
408
409
\end{code}


\begin{code}
410
411
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
412
413
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
414
415
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
416
	   ptext SLIT("="),
417
	   ppr ty,
418
419
	   semi
    ]
sof's avatar
sof committed
420
  where
421
422
    (tyvars, ty) = getSynTyConDefn tycon

423
ifaceTyCon tycon
424
425
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
426
427
428
	   ppr_decl_context (tyConTheta tycon),
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
429
430
431
432
433
434
435
	   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
436
437
438

    ppr_con data_con 
	| null field_labels
439
	= hsep [ ppr name,
sof's avatar
sof committed
440
441
442
443
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
444
	= hsep [ ppr name,
sof's avatar
sof committed
445
446
447
448
449
450
451
452
		  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

453
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
454
455
456
457
458
459
460
461

    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)
462
	= hsep [ ppr (fieldLabelName field_label),
sof's avatar
sof committed
463
		  ptext SLIT("::"),
464
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
465
466
		]

467
468
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
469

470
ifaceClass clas
sof's avatar
sof committed
471
  = hsep [ptext SLIT("class"),
472
473
474
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
475
476
477
478
	   pp_ops,
	   semi
	  ]
   where
479
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
480

sof's avatar
sof committed
481
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
482
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
483
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
484
485
			  ]

sof's avatar
sof committed
486
     ppr_classop sel_id maybe_defm
487
488
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
489
490
		if maybeToBool maybe_defm then equals else empty,
	        ptext SLIT("::"),
491
		ppr op_ty
sof's avatar
sof committed
492
493
494
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
495

496
497
498
ppr_decl_context :: ThetaType -> SDoc
ppr_decl_context [] = empty
ppr_decl_context theta
sof's avatar
sof committed
499
500
501
502
  = braces (hsep (punctuate comma (map (ppr_dict) theta)))
    <> 
    ptext SLIT(" =>")
  where
503
    ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys)
sof's avatar
sof committed
504
505
\end{code}

506
507
508
509
510
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
511
512
513
514
515
516

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

517
\begin{code}
sof's avatar
sof committed
518
upp_avail NotAvailable      = empty
519
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
520
521
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
522
			    where
sof's avatar
sof committed
523
			      bang | name `elem` ns = empty
sof's avatar
sof committed
524
				   | otherwise	    = char '|'
525
			      ns' = filter (/= name) ns
526

sof's avatar
sof committed
527
upp_export []    = empty
sof's avatar
sof committed
528
upp_export names = parens (hsep (map (upp_occname . getOccName) names)) 
529

530
upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
531

532
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
533
534
ppr_unqual_name name = upp_occname (getOccName name)

535
upp_occname :: OccName -> SDoc
sof's avatar
sof committed
536
upp_occname occ = ptext (occNameString occ)
537
538
\end{code}

539

540
%************************************************************************
541
542
543
%*				 					*
\subsection{Comparisons
%*				 					*
544
%************************************************************************
545
				 
546

547
548
549
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
550

551
552
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
553

554
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
555

556
557
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
558

559
560
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
561

562
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
563
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
564

565
sort_versions vs = sortLt lt_vers vs
566

567
568
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
569
570
\end{code}

571

572
\begin{code}
573
hPutCol :: Handle 
574
	-> (a -> SDoc)
575
576
	-> [a]
	-> IO ()
577
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
578
579
580
581

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