MkIface.lhs 19.2 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
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
import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..),
21
  			  StrictnessMark(..), 
22
23
			  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
31
32
import Id		( Id, idType, idInfo, omitIfaceSigForId,
			  getIdSpecialisation
33
			)
34
35
36
import Var		( isId )
import VarSet
import DataCon		( dataConSig, dataConFieldLabels, dataConStrictMarks )
37
import IdInfo		( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
38
39
40
			  arityInfo, ppArityInfo, 
			  strictnessInfo, ppStrictnessInfo, 
			  cafInfo, ppCafInfo,
41
			  bottomIsGuaranteed, workerExists, 
42
			)
43
44
45
46
47
48
49
import CoreSyn		( CoreExpr, CoreBind, Bind(..) )
import CoreUtils	( exprSomeFreeVars )
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), 
			  Unfolding, okToUnfoldInHiFile )
import Name		( isLocallyDefined, isWiredInName, modAndOcc, nameModule,
			  OccName, occNameString, isExported,
			  Name, NamedThing(..)
50
			)
51
52
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
53
			)
54
import Class		( Class, classBigSig )
55
import SpecEnv		( specEnvToList )
56
57
import FieldLabel	( fieldLabelName, fieldLabelType )
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy,
58
			  Type, ThetaType
sof's avatar
sof committed
59
		        )
60
61
62
63

import PprType
import PprCore		( pprIfaceUnfolding )

sof's avatar
sof committed
64
import Bag		( bagToList, isEmptyBag )
65
import Maybes		( catMaybes, maybeToBool )
66
67
68
69
import FiniteMap	( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
import UniqFM		( lookupUFM, listToUFM )
import UniqSet		( uniqSetToList )
import Util		( sortLt, mapAccumL )
70
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
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
94
	   -> [CoreBind]	-- In dependency order, later depend on earlier
95
96
97
	   -> 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
      Just fn -> do
	if_hdl <- openFile fn WriteMode
106
107
	hPutStr if_hdl ("__interface "++ _UNPK_ mod ++ ' ':show (opt_HiVersion :: Int))
	hPutStrLn if_hdl " where"
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
\begin{code}
ifaceMain Nothing iface_stuff = return ()
ifaceMain (Just if_hdl)
	  (import_usages, ExportEnv avails fixities, instance_modules)
119
120
121
122
123
  = do
    ifaceImports		if_hdl import_usages
    ifaceInstanceModules	if_hdl instance_modules
    ifaceExports		if_hdl avails
    ifaceFixities		if_hdl fixities
124
125
    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
  = ifaceClasses hdl classes			>>
    ifaceInstances hdl inst_infos		>>= \ needed_ids ->
sof's avatar
sof committed
136
    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
\end{code}

\begin{code}
147
148
ifaceImports if_hdl import_usages
  = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
149
  where
150
    upp_uses (m, hif, mv, whats_imported)
151
152
      = ptext SLIT("import ") <>
	hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"),
153
	      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
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
165
166
167
168
169
  = let sorted = sortLt (<) imods
	lines = map (\m -> ptext SLIT("__instimport ") <> ptext m <>
			   ptext SLIT(" ;")) sorted
    in 
    printForIface if_hdl (vcat lines) >>
170
    hPutStr if_hdl "\n"
171

172
173
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
174
  = hPutCol if_hdl do_one_module (fmToList export_fm)
175
176
177
178
  where
	-- Sort them into groups by module
    export_fm :: FiniteMap Module [AvailInfo]
    export_fm = foldr insert emptyFM avails
179

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

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

198
199
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
200
  = hPutCol if_hdl upp_fixity fixities
201
202
203
204
205
206
207
\end{code}			 

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

209
210

\begin{code}			 
211
212
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
213
214
  | null togo_insts = return emptyVarSet		 
  | otherwise 	    = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
215
		      return needed_ids
216
217
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
218
219
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
220
221
				 
    -------			 
222
223
    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ dfun_id2 _ _ _)
224
225
226
227
228
      = 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
ifaceId get_idinfo needed_ids is_rec id rhs
258
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
259
	 (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
263
  = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
264
  where
265
    idinfo         = get_idinfo id
266
    inline_pragma  = inlinePragInfo idinfo
267

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

271
    prag_pretty 
sof's avatar
sof committed
272
     | opt_OmitInterfacePragmas = empty
273
274
275
276
277
278
279
     | otherwise		= hsep [ptext SLIT("{-##"),
					arity_pretty, 
					caf_pretty,
					strict_pretty, 
					unfold_pretty, 
					spec_pretty,
					ptext SLIT("##-}")]
280
281

    ------------  Arity  --------------
282
    arity_pretty  = ppArityInfo (arityInfo idinfo)
283

284
285
286
    ------------ Caf Info --------------
    caf_pretty = ppCafInfo (cafInfo idinfo)

287
288
    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
289
    has_worker    = workerExists strict_info
290
    strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
sof's avatar
sof committed
291
292

    wrkr_pretty | not has_worker = empty
293
294
295
		| null con_list  = ppr work_id
		| otherwise      = ppr work_id <+> 
				   braces (hsep (map ppr con_list))
sof's avatar
sof committed
296
297

    (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
298
    con_list 		    = uniqSetToList wrapper_cons
299
300

    ------------  Unfolding  --------------
301
    unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
sof's avatar
sof committed
302
		  | otherwise   = empty
303

304
    show_unfold = not implicit_unfolding &&	-- Not unnecessary
305
306
307
308
309
310
311
		  unfolding_needed		-- Not dangerous

    unfolding_needed =  case inline_pragma of
			      IMustBeINLINEd    -> definitely_ok_to_unfold
			      IWantToBeINLINEd  -> definitely_ok_to_unfold
			      NoInlinePragInfo  -> rhs_is_small
			      other	        -> False
312

sof's avatar
sof committed
313
    implicit_unfolding = has_worker ||
314
315
			 bottomIsGuaranteed strict_info

316
317
318
319
320
321
322
    unfold_herald = case inline_pragma of
			NoInlinePragInfo -> ptext SLIT("__u")
			other		 -> ppr inline_pragma

    rhs_is_small = case calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs of
			UnfoldNever -> False	-- Too big
			other	    ->  definitely_ok_to_unfold -- Small enough
323

sof's avatar
sof committed
324
    definitely_ok_to_unfold =  okToUnfoldInHiFile rhs
325
326

    ------------  Specialisations --------------
327
328
    spec_list = specEnvToList (getIdSpecialisation id)
    spec_pretty = hsep (map pp_spec spec_list)
329
    pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
330
				       if null tyvars then ptext SLIT("[ ]")
331
						      else brackets (interppSP tyvars),
332
					-- The lexer interprets "[]" as a CONID.  Sigh.
333
334
				       hsep (map pprParendType tys),
				       ptext SLIT("="),
335
				       pprIfaceUnfolding rhs
336
				 ]
337
338
    
    ------------  Extra free Ids  --------------
339
    new_needed_ids = (needed_ids `minusVarSet` unitVarSet id)	`unionVarSet` 
340
341
		     extra_ids

342
343
344
    extra_ids | opt_OmitInterfacePragmas = emptyVarSet
	      | otherwise		 = worker_ids	`unionVarSet`
					   unfold_ids	`unionVarSet`
345
					   spec_ids
346

347
348
    worker_ids | has_worker = unitVarSet work_id
	       | otherwise  = emptyVarSet
349

350
    spec_ids = foldr add emptyVarSet spec_list
351
	     where
352
	       add (_, _, rhs) = unionVarSet (find_fvs rhs)
353
354

    unfold_ids | show_unfold = find_fvs rhs
355
	       | otherwise   = emptyVarSet
356
357
358

    find_fvs expr = free_vars
		  where
359
360
		    free_vars = exprSomeFreeVars interesting expr
		    interesting id = isId id && isLocallyDefined id &&
361
				     not (omitIfaceSigForId id)
362
363
364
\end{code}

\begin{code}
365
ifaceBinds :: Handle
366
	   -> IdSet		-- These Ids are needed already
367
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
368
	   -> [CoreBind]	-- In dependency order, later depend on earlier
369
370
	   -> IO ()

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

381
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
382
						-- provoke earlier ones to be emitted
383
    go needed [] = if not (isEmptyVarSet needed) then
384
			pprTrace "ifaceBinds: free vars:" 
385
				  (sep (map ppr (varSetElems needed))) $
386
387
388
389
390
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
391
	= case ifaceId get_idinfo needed False id rhs of
392
393
394
395
396
397
398
399
400
401
		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
402
	  needed'' = needed' `minusVarSet` mkVarSet (map fst pairs)
403
404
		-- Later ones may spuriously cause earlier ones to be "needed" again

405
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
406
407
408
409
410
411
412
413
414
    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

415
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
416
417
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
418
419
420
\end{code}


sof's avatar
sof committed
421
422
423
424
425
426
427
428
429
430
431
432
433
%************************************************************************
%*				 					*
\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)

434
435
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
436
437
438
439
\end{code}


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

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

467
468
    tyvars = tyConTyVars tycon

sof's avatar
sof committed
469
470
    ppr_con data_con 
	| null field_labels
471
472
473
	= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	  hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
474
475
476
477
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
478
479
	= hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
480
481
482
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
483
	   (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
sof's avatar
sof committed
484
485
486
487
           field_labels   = dataConFieldLabels data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

488
489
490
491
    ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
    ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
			     <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>")

492
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
493
494
495
496
497
498
499
500

    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)
501
	= hsep [ ppr (fieldLabelName field_label),
sof's avatar
sof committed
502
		  ptext SLIT("::"),
503
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
504
505
		]

506
507
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
508

509
ifaceClass clas
sof's avatar
sof committed
510
  = hsep [ptext SLIT("class"),
511
512
513
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
514
515
516
517
	   pp_ops,
	   semi
	  ]
   where
518
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
519

sof's avatar
sof committed
520
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
521
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
522
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
523
524
			  ]

sof's avatar
sof committed
525
     ppr_classop sel_id maybe_defm
526
527
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
528
529
		if maybeToBool maybe_defm then equals else empty,
	        ptext SLIT("::"),
530
		ppr op_ty
sof's avatar
sof committed
531
532
533
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
534

535
ppr_decl_context :: ThetaType -> SDoc
536
537
538
539
540
ppr_decl_context []    = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")

pprIfaceTheta :: ThetaType -> SDoc	-- Use braces rather than parens in interface files
pprIfaceTheta theta =  braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
541
542
\end{code}

543
544
545
546
547
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
548
549
550
551
552
553

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

554
\begin{code}
sof's avatar
sof committed
555
upp_avail NotAvailable      = empty
556
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
557
558
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
559
			    where
sof's avatar
sof committed
560
			      bang | name `elem` ns = empty
sof's avatar
sof committed
561
				   | otherwise	    = char '|'
562
			      ns' = filter (/= name) ns
563

sof's avatar
sof committed
564
upp_export []    = empty
565
upp_export names = braces (hsep (map (upp_occname . getOccName) names)) 
566

567
upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
568

569
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
570
571
ppr_unqual_name name = upp_occname (getOccName name)

572
upp_occname :: OccName -> SDoc
sof's avatar
sof committed
573
upp_occname occ = ptext (occNameString occ)
574
575
\end{code}

576

577
%************************************************************************
578
579
580
%*				 					*
\subsection{Comparisons
%*				 					*
581
%************************************************************************
582
				 
583

584
585
586
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
587

588
589
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
590

591
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
592

593
594
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
595

596
597
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
598

599
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
600
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
601

602
sort_versions vs = sortLt lt_vers vs
603

604
605
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
606
607
\end{code}

608

609
\begin{code}
610
hPutCol :: Handle 
611
	-> (a -> SDoc)
612
613
	-> [a]
	-> IO ()
614
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
615
616
617
618

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