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 )
sof's avatar
sof committed
45
import Module		( moduleString, pprModule, pprModuleBoot )
46
47
import Name		( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
			  isExported,
48
			  Name, NamedThing(..)
49
			)
sof's avatar
sof committed
50
import OccName		( OccName, pprOccName )
51
52
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
53
			)
54
import Class		( Class, classBigSig )
55
import SpecEnv		( specEnvToList )
56
import FieldLabel	( fieldLabelName, fieldLabelType )
57
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
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
	hPutStr if_hdl ("__interface " ++ moduleString mod ++ ' ':show (opt_HiVersion :: Int))
107
	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, mv, whats_imported)
151
      = ptext SLIT("import ") <>
152
	hsep [pprModule m, pprModuleBoot m, int mv, dcolon,
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
  = let sorted = sortLt (<) imods
166
	lines = map (\m -> ptext SLIT("__instimport ") <> pprModule m <>
167
168
169
			   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
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
    do_one_module (mod_name, avails@(avail1:_))
187
	= ptext SLIT("__export ") <>
188
	  hsep [pprModuleBoot (nameModule (availName avail1)), 
189
		pprModule mod_name,
sof's avatar
sof committed
190
191
192
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

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

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

204
205

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

    -------			 
224
    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
225
      = let			 
226
227
228
229
230
231
232
233
234
235
		-- 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))
236
	    renumbered_ty = tidyTopType forall_ty
237
	in			 
238
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
239
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
240
241
\end{code}

242
243
244
245
246
247
248

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

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

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

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

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

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

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

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

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

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

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

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

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

319

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

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

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

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

351
352
353
354
    worker_ids | has_worker && interesting work_id = unitVarSet work_id
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
355

356
    spec_ids = foldr add emptyVarSet spec_list
357
	     where
358
	       add (_, _, rhs) = unionVarSet (find_fvs rhs)
359
360

    unfold_ids | show_unfold = find_fvs rhs
361
	       | otherwise   = emptyVarSet
362
363
364

    find_fvs expr = free_vars
		  where
365
		    free_vars = exprSomeFreeVars interesting expr
366
367
368

    interesting id = isId id && isLocallyDefined id &&
		     not (omitIfaceSigForId id)
369
370
371
\end{code}

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

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

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

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

412
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
413
414
415
416
417
418
419
420
421
    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

422
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
423
424
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
425
426
427
\end{code}


sof's avatar
sof committed
428
429
430
431
432
433
434
435
436
437
438
439
440
%************************************************************************
%*				 					*
\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)

441
442
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
443
444
445
446
\end{code}


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

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

474
475
    tyvars = tyConTyVars tycon

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

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

495
496
497
498
    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("=>")

499
    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
sof's avatar
sof committed
500

501
502
503
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
504
505

    ppr_field (strict_mark, field_label)
506
	= hsep [ ppr (fieldLabelName field_label),
507
		  dcolon,
508
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
509
510
		]

511
512
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
513

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

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

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

540
ppr_decl_context :: ThetaType -> SDoc
541
542
543
544
ppr_decl_context []    = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")

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

549
550
551
552
553
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
554
555
556
557
558
559

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

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

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

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

578
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
579
ppr_unqual_name name = pprOccName (getOccName name)
580
581
\end{code}

582

583
%************************************************************************
584
585
586
%*				 					*
\subsection{Comparisons
%*				 					*
587
%************************************************************************
588
				 
589

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

594
595
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
596

597
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
598

599
lt_name :: Name -> Name -> Bool
600
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
601

602
603
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
604

605
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
606
lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
607

608
sort_versions vs = sortLt lt_vers vs
609

610
611
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
612
613
\end{code}

614

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

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