MkIface.lhs 19.1 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
45
46
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding,
			  okToUnfoldInHiFile
			)
47
import FreeVars		( exprFreeVars )
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
import Class		( Class, classBigSig )
56
import SpecEnv		( specEnvToList )
57
58
59
import FieldLabel	( fieldLabelName, fieldLabelType )
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy,
			  mkTyVarTys, Type, ThetaType
sof's avatar
sof committed
60
		        )
61

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

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

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

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


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

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

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

114

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

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

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

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

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

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

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

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

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

208
209

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

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

238
239
240
241
242
243
244

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

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

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

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

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

272
    prag_pretty 
sof's avatar
sof committed
273
     | opt_OmitInterfacePragmas = empty
274
275
     | otherwise		= hsep [arity_pretty, strict_pretty, unfold_pretty, 
					spec_pretty, pp_double_semi]
276
277

    ------------  Arity  --------------
278
    arity_pretty  = ppArityInfo (arityInfo idinfo)
279
280
281

    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
282
    has_worker    = workerExists strict_info
283
    strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
sof's avatar
sof committed
284
285

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

    (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
    con_list 		   = idSetToList wrapper_cons
292
293

    ------------  Unfolding  --------------
294
    unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
sof's avatar
sof committed
295
		  | otherwise   = empty
296

297
298
299
300
301
    unfold_herald = case inline_pragma of
			IMustBeINLINEd   -> SLIT("_U_")
			IWantToBeINLINEd -> SLIT("_U_")
			other		 -> SLIT("_u_")

302
303
    show_unfold = not implicit_unfolding &&	-- Not unnecessary
		  unfolding_is_ok		-- Not dangerous
304

sof's avatar
sof committed
305
    implicit_unfolding = has_worker ||
306
307
			 bottomIsGuaranteed strict_info

308
309
    unfolding_is_ok
	= case inline_pragma of
sof's avatar
sof committed
310
311
	    IMustBeINLINEd       -> definitely_ok_to_unfold
	    IWantToBeINLINEd     -> definitely_ok_to_unfold
312
313
314
	    IDontWantToBeINLINEd -> False
	    IMustNotBeINLINEd    -> False
	    NoPragmaInfo         -> case guidance of
315
					UnfoldNever -> False	-- Too big
sof's avatar
sof committed
316
					other       -> definitely_ok_to_unfold
317

sof's avatar
sof committed
318
    definitely_ok_to_unfold =  okToUnfoldInHiFile rhs
319
320
321
    guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs

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

    extra_ids | opt_OmitInterfacePragmas = emptyIdSet
	      | otherwise		 = worker_ids	`unionIdSets`
339
340
					   unfold_ids	`unionIdSets`
					   spec_ids
341

sof's avatar
sof committed
342
343
    worker_ids | has_worker = unitIdSet work_id
	       | otherwise  = emptyIdSet
344

345
346
347
348
349
    spec_ids = foldr add emptyIdSet spec_list
	     where
	       add (_, _, rhs) = unionIdSets (find_fvs rhs)

    unfold_ids | show_unfold = find_fvs rhs
350
	       | otherwise   = emptyIdSet
351
352
353

    find_fvs expr = free_vars
		  where
354
355
356
		    free_vars = exprFreeVars interesting expr
		    interesting id = isLocallyDefined id &&
				     not (omitIfaceSigForId id)
357
358
359
\end{code}

\begin{code}
360
ifaceBinds :: Handle
361
	   -> IdSet		-- These Ids are needed already
362
363
364
365
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBinding]	-- In dependency order, later depend on earlier
	   -> IO ()

366
ifaceBinds hdl needed_ids final_ids binds
367
  = mapIO (printForIface hdl) pretties >>
368
    hPutStr hdl "\n"
369
  where
370
371
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
372
			Just id' -> idInfo id'
373
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
374
				    idInfo id
375

376
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
377
378
379
						-- provoke earlier ones to be emitted
    go needed [] = if not (isEmptyIdSet needed) then
			pprTrace "ifaceBinds: free vars:" 
380
				  (sep (map ppr (idSetToList needed))) $
381
382
383
384
385
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
386
	= case ifaceId get_idinfo needed False id rhs of
387
388
389
390
391
392
393
394
395
396
397
398
399
		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

400
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
401
402
403
404
405
406
407
408
409
    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

410
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
411
412
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
413
414
415
\end{code}


sof's avatar
sof committed
416
417
418
419
420
421
422
423
424
425
426
427
428
%************************************************************************
%*				 					*
\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)

429
430
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
431
432
433
434
\end{code}


\begin{code}
435
436
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
437
438
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
439
440
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
441
	   ptext SLIT("="),
442
	   ppr ty,
443
444
	   semi
    ]
sof's avatar
sof committed
445
  where
446
447
    (tyvars, ty) = getSynTyConDefn tycon

448
ifaceTyCon tycon
449
450
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
451
452
453
	   ppr_decl_context (tyConTheta tycon),
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
454
455
456
457
458
459
460
	   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
461
462
463

    ppr_con data_con 
	| null field_labels
464
	= hsep [ ppr name,
sof's avatar
sof committed
465
466
467
468
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
469
	= hsep [ ppr name,
sof's avatar
sof committed
470
471
472
473
474
475
476
477
		  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

478
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
479
480
481
482
483
484
485
486

    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)
487
	= hsep [ ppr (fieldLabelName field_label),
sof's avatar
sof committed
488
		  ptext SLIT("::"),
489
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
490
491
		]

492
493
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
494

495
ifaceClass clas
sof's avatar
sof committed
496
  = hsep [ptext SLIT("class"),
497
498
499
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
500
501
502
503
	   pp_ops,
	   semi
	  ]
   where
504
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
505

sof's avatar
sof committed
506
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
507
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
508
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
509
510
			  ]

sof's avatar
sof committed
511
     ppr_classop sel_id maybe_defm
512
513
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
514
515
		if maybeToBool maybe_defm then equals else empty,
	        ptext SLIT("::"),
516
		ppr op_ty
sof's avatar
sof committed
517
518
519
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
520

521
522
523
ppr_decl_context :: ThetaType -> SDoc
ppr_decl_context [] = empty
ppr_decl_context theta
sof's avatar
sof committed
524
525
526
527
  = braces (hsep (punctuate comma (map (ppr_dict) theta)))
    <> 
    ptext SLIT(" =>")
  where
528
    ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys)
sof's avatar
sof committed
529
530
\end{code}

531
532
533
534
535
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
536
537
538
539
540
541

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

542
\begin{code}
sof's avatar
sof committed
543
upp_avail NotAvailable      = empty
544
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
545
546
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
547
			    where
sof's avatar
sof committed
548
			      bang | name `elem` ns = empty
sof's avatar
sof committed
549
				   | otherwise	    = char '|'
550
			      ns' = filter (/= name) ns
551

sof's avatar
sof committed
552
upp_export []    = empty
sof's avatar
sof committed
553
upp_export names = parens (hsep (map (upp_occname . getOccName) names)) 
554

555
upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
556

557
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
558
559
ppr_unqual_name name = upp_occname (getOccName name)

560
upp_occname :: OccName -> SDoc
sof's avatar
sof committed
561
upp_occname occ = ptext (occNameString occ)
562
563
\end{code}

564

565
%************************************************************************
566
567
568
%*				 					*
\subsection{Comparisons
%*				 					*
569
%************************************************************************
570
				 
571

572
573
574
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
575

576
577
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
578

579
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
580

581
582
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
583

584
585
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
586

587
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
588
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
589

590
sort_versions vs = sortLt lt_vers vs
591

592
593
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
594
595
\end{code}

596

597
\begin{code}
598
hPutCol :: Handle 
599
	-> (a -> SDoc)
600
601
	-> [a]
	-> IO ()
602
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
603
604
605
606

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