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

\begin{code}
7
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 BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..),
20
  			  StrictnessMark(..) 
21
			)
22
import RnMonad
23
import RnEnv		( availName )
24
25

import TcInstUtil	( InstInfo(..) )
26
import WorkWrap		( getWorkerIdAndCons )
27
28

import CmdLineOpts
29
30
import Id		( Id, idType, idInfo, omitIfaceSigForId,
			  getIdSpecialisation
31
			)
32
33
34
import Var		( isId )
import VarSet
import DataCon		( dataConSig, dataConFieldLabels, dataConStrictMarks )
35
import IdInfo		( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
36
37
38
			  arityInfo, ppArityInfo, 
			  strictnessInfo, ppStrictnessInfo, 
			  cafInfo, ppCafInfo,
39
			  workerExists, isBottomingStrictness
40
			)
41
42
43
44
import CoreSyn		( CoreExpr, CoreBind, Bind(..) )
import CoreUtils	( exprSomeFreeVars )
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), 
			  Unfolding, okToUnfoldInHiFile )
45
46
import Name		( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
			  isExported,
47
			  Name, NamedThing(..)
48
			)
49
import OccName		( OccName, pprOccName, moduleString, pprModule, pprModuleBoot )
50
51
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
52
			)
53
import Class		( Class, classBigSig )
54
import SpecEnv		( specEnvToList )
55
import FieldLabel	( fieldLabelName, fieldLabelType )
56
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
57
			  Type, ThetaType
sof's avatar
sof committed
58
		        )
59
60
61
62

import PprType
import PprCore		( pprIfaceUnfolding )

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

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

171
172
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
173
  = hPutCol if_hdl do_one_module (fmToList export_fm)
174
175
176
177
  where
	-- Sort them into groups by module
    export_fm :: FiniteMap Module [AvailInfo]
    export_fm = foldr insert emptyFM avails
178
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
    do_one_module :: (Module, [AvailInfo]) -> SDoc
sof's avatar
sof committed
185
    do_one_module (mod_name, avails@(avail1:_))
186
	= ptext SLIT("__export ") <>
187
	  hsep [pprModuleBoot (nameModule (availName avail1)), 
188
		pprModule mod_name,
sof's avatar
sof committed
189
190
191
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

192
193
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
194
  = hPutCol if_hdl upp_fixity fixities
195
196
197
198
199
200
201
\end{code}			 

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

203
204

\begin{code}			 
205
206
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
207
208
  | null togo_insts = return emptyVarSet		 
  | otherwise 	    = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
209
		      return needed_ids
210
211
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
212
213
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
214
215
				 
    -------			 
216
217
    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ dfun_id2 _ _ _)
218
219
220
221
222
      = 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

    -------			 
223
    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
224
      = let			 
225
226
227
228
229
230
231
232
233
234
		-- The deNoteType is very important.   It removes all type
		-- synonyms from the instance type in interface files.
		-- That in turn makes sure that when reading in instance decls
		-- from interface files that the 'gating' mechanism works properly.
		-- Otherwise you could have
		--	type Tibble = T Int
		--	instance Foo Tibble where ...
		-- and this instance decl wouldn't get imported into a module
		-- that mentioned T but not Tibble.
	    forall_ty     = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
235
	    renumbered_ty = tidyTopType forall_ty
236
	in			 
237
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
238
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
239
240
\end{code}

241
242
243
244
245
246
247

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

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

260
ifaceId get_idinfo needed_ids is_rec id rhs
261
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
262
	 (isExported id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
263
264
  = Nothing 		-- Well, that was easy!

265
ifaceId get_idinfo needed_ids is_rec id rhs
266
  = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
267
  where
268
    idinfo         = get_idinfo id
269
    inline_pragma  = inlinePragInfo idinfo
270

271
272
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
273

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

    ------------  Arity  --------------
285
    arity_pretty  = ppArityInfo (arityInfo idinfo)
286

287
288
289
    ------------ Caf Info --------------
    caf_pretty = ppCafInfo (cafInfo idinfo)

290
291
    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
292
    has_worker    = workerExists strict_info
293
    bottoming_fn  = isBottomingStrictness strict_info
294
    strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
sof's avatar
sof committed
295
296

    wrkr_pretty | not has_worker = empty
297
298
299
		| null con_list  = ppr work_id
		| otherwise      = ppr work_id <+> 
				   braces (hsep (map ppr con_list))
sof's avatar
sof committed
300
301

    (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
302
    con_list 		    = uniqSetToList wrapper_cons
303
304

    ------------  Unfolding  --------------
305
    unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
sof's avatar
sof committed
306
		  | otherwise   = empty
307

308
309
    show_unfold = not has_worker	&&	-- Not unnecessary
		  not bottoming_fn	&&	-- Not necessary
310
311
312
313
314
315
316
		  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
317

318

319
320
321
322
323
324
325
    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
326

sof's avatar
sof committed
327
    definitely_ok_to_unfold =  okToUnfoldInHiFile rhs
328
329

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

345
346
347
    extra_ids | opt_OmitInterfacePragmas = emptyVarSet
	      | otherwise		 = worker_ids	`unionVarSet`
					   unfold_ids	`unionVarSet`
348
					   spec_ids
349

350
351
    worker_ids | has_worker = unitVarSet work_id
	       | otherwise  = emptyVarSet
352

353
    spec_ids = foldr add emptyVarSet spec_list
354
	     where
355
	       add (_, _, rhs) = unionVarSet (find_fvs rhs)
356
357

    unfold_ids | show_unfold = find_fvs rhs
358
	       | otherwise   = emptyVarSet
359
360
361

    find_fvs expr = free_vars
		  where
362
363
		    free_vars = exprSomeFreeVars interesting expr
		    interesting id = isId id && isLocallyDefined id &&
364
				     not (omitIfaceSigForId id)
365
366
367
\end{code}

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

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

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

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

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

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


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

437
438
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
439
440
441
442
\end{code}


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

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

470
471
    tyvars = tyConTyVars tycon

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

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

491
492
493
494
    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("=>")

495
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
496
497
498
499
500
501
502
503

    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)
504
	= hsep [ ppr (fieldLabelName field_label),
505
		  dcolon,
506
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
507
508
		]

509
510
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
511

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

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

sof's avatar
sof committed
528
     ppr_classop sel_id maybe_defm
529
530
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
531
		if maybeToBool maybe_defm then equals else empty,
532
	        dcolon,
533
		ppr op_ty
sof's avatar
sof committed
534
535
536
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
537

538
ppr_decl_context :: ThetaType -> SDoc
539
540
541
542
543
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
544
545
\end{code}

546
547
548
549
550
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
551
552
553
554
555
556

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

557
\begin{code}
558
559
upp_avail :: AvailInfo -> SDoc
upp_avail (Avail name)      = pprOccName (getOccName name)
sof's avatar
sof committed
560
upp_avail (AvailTC name []) = empty
561
upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
562
			    where
sof's avatar
sof committed
563
			      bang | name `elem` ns = empty
sof's avatar
sof committed
564
				   | otherwise	    = char '|'
565
			      ns' = filter (/= name) ns
566

567
upp_export :: [Name] -> SDoc
sof's avatar
sof committed
568
upp_export []    = empty
569
upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
570

571
572
573
upp_fixity :: (Name, Fixity) -> SDoc
upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
	-- Dummy version number!
574

575
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
576
ppr_unqual_name name = pprOccName (getOccName name)
577
578
\end{code}

579

580
%************************************************************************
581
582
583
%*				 					*
\subsection{Comparisons
%*				 					*
584
%************************************************************************
585
				 
586

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

591
592
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
593

594
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
595

596
lt_name :: Name -> Name -> Bool
597
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
598

599
600
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
601

602
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
603
lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
604

605
sort_versions vs = sortLt lt_vers vs
606

607
608
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
609
610
\end{code}

611

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

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