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

\begin{code}
#include "HsVersions.h"

9
10
module MkIface (
	startIface, endIface,
11
	ifaceMain,
12
	ifaceDecls
13
    ) where
14

15
IMP_Ubiq(){-uitous-}
16
IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
17
18

import HsSyn
19
20
import RdrHsSyn		( RdrName(..) )
import RnHsSyn		( SYN_IE(RenamedHsModule) )
sof's avatar
sof committed
21
import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
22
import RnMonad
sof's avatar
sof committed
23
import RnEnv		( availName, ifaceFlavour )
24
25
26
27

import TcInstUtil	( InstInfo(..) )

import CmdLineOpts
sof's avatar
sof committed
28
import Id		( idType, dataConRawArgTys, dataConFieldLabels, 
sof's avatar
sof committed
29
			  getIdInfo, getInlinePragma, omitIfaceSigForId,
30
31
			  dataConStrictMarks, StrictnessMark(..), 
			  SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, 
sof's avatar
sof committed
32
			  isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, pprId,
sof's avatar
sof committed
33
34
			  GenId{-instance NamedThing/Outputable-}, SYN_IE(Id)

35
			)
sof's avatar
sof committed
36
import IdInfo		( StrictnessInfo, ArityInfo, 
37
			  arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, 
sof's avatar
sof committed
38
			  workerExists, bottomIsGuaranteed, IdInfo
39
			)
40
import CoreSyn		( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
sof's avatar
sof committed
41
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
42
import FreeVars		( addExprFVs )
sof's avatar
sof committed
43
import WorkWrap		( getWorkerIdAndCons )
sof's avatar
sof committed
44
import Name		( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
sof's avatar
sof committed
45
46
			  OccName, occNameString, nameOccName, nameString, isExported,
			  Name {-instance NamedThing-}, Provenance, NamedThing(..)
47
			)
sof's avatar
sof committed
48
import TyCon		( TyCon(..) {-instance NamedThing-} )
sof's avatar
sof committed
49
import Class		( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig )
sof's avatar
sof committed
50
51
import FieldLabel	( FieldLabel{-instance NamedThing-}, 
		          fieldLabelName, fieldLabelType )
sof's avatar
sof committed
52
import Type		( mkSigmaTy, mkDictTy, getAppTyCon, splitSigmaTy,
sof's avatar
sof committed
53
54
			  mkTyVarTy, SYN_IE(Type)
		        )
55
56
57
import TyVar		( GenTyVar {- instance Eq -} )
import Unique		( Unique {- instance Eq -} )

58
import PprEnv		-- not sure how much...
sof's avatar
sof committed
59
import Outputable	( PprStyle(..), Outputable(..) )
60
61
62
import PprType
import PprCore		( pprIfaceUnfolding )
import Pretty
sof's avatar
sof committed
63
import Outputable	( printDoc )
64

65

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
70
import UniqFM		( UniqFM, lookupUFM, listToUFM )
import Util		( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
sof's avatar
sof committed
71
72
73
			  assertPanic, panic{-ToDo:rm-}, pprTrace,
			  pprPanic 
			)
74
75
76
\end{code}

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

ifaceMain   :: Maybe Handle
	    -> InterfaceDetails
90
	    -> IO ()
91
92
93


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

\begin{code}
startIface mod
  = case opt_ProduceHi of
      Nothing -> return Nothing -- not producing any .hi file
      Just fn ->
	openFile fn WriteMode	>>= \ if_hdl ->
109
	hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
110
111
112
113
	return (Just if_hdl)

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

116

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

159
160
	-- For imported versions we do print the version number
    upp_import_versions nvs
sof's avatar
sof committed
161
      = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- nvs ]
162

163

164
165
166
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
  = hPutStr if_hdl "_instance_modules_\n" >>
sof's avatar
sof committed
167
    printDoc OneLineMode 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
186
187
188
189
190
191
192
193
    do_one_module (mod_name, avails@(avail1:_))
	= hsep [pp_hif (ifaceFlavour (availName avail1)), 
		upp_module mod_name,
		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 '!'
194

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

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

207
208

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

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

237
238
239
240
241
242
243

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

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

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

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

sof's avatar
sof committed
268
    ty_pretty  = pprType PprInterface (nmbrGlobalType (idType id))
sof's avatar
sof committed
269
    sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
270

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

    ------------  Arity  --------------
    arity_pretty  = ppArityInfo PprInterface (arityInfo idinfo)

    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
280
281
282
283
284
285
286
287
288
    has_worker    = workerExists strict_info
    strict_pretty = ppStrictnessInfo PprInterface strict_info <+> wrkr_pretty

    wrkr_pretty | not has_worker = empty
		| null con_list  = pprId PprInterface work_id
		| otherwise      = pprId PprInterface work_id <+> braces (hsep (map (pprId PprInterface) con_list))

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

    ------------  Unfolding  --------------
sof's avatar
sof committed
291
292
    unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs]
		  | otherwise   = empty
293

sof's avatar
sof committed
294
295
    show_unfold = not implicit_unfolding && 		-- Not unnecessary
		  not dodgy_unfolding			-- Not dangerous
296

sof's avatar
sof committed
297
    implicit_unfolding = has_worker ||
298
299
			 bottomIsGuaranteed strict_info

sof's avatar
sof committed
300
301
    dodgy_unfolding = case guidance of 			-- True <=> too big to show, or the Inline pragma
			UnfoldNever -> True		-- says it shouldn't be inlined
302
303
304
			other       -> False

    guidance    = calcUnfoldingGuidance inline_pragma
305
306
307
308
309
310
311
312
313
314
315
316
					opt_InterfaceUnfoldThreshold
					rhs

    
    ------------  Extra free Ids  --------------
    new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)	`unionIdSets` 
		     extra_ids

    extra_ids | opt_OmitInterfacePragmas = emptyIdSet
	      | otherwise		 = worker_ids	`unionIdSets`
					   unfold_ids

sof's avatar
sof committed
317
318
    worker_ids | has_worker = unitIdSet work_id
	       | otherwise  = emptyIdSet
319
320
321
322
323

    unfold_ids | show_unfold = free_vars
	       | otherwise   = emptyIdSet
			     where
			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
324
325
326
			       interesting bound id = isLocallyDefined id &&
						      not (id `elementOfIdSet` bound) &&
						      not (omitIfaceSigForId id)
327
328
329
\end{code}

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

336
ifaceBinds hdl needed_ids final_ids binds
sof's avatar
sof committed
337
  = mapIO (printDoc OneLineMode hdl) pretties >>
338
    hPutStr hdl "\n"
339
  where
340
341
342
343
344
345
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
			Just id' -> getIdInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
				    getIdInfo id

346
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
347
348
349
						-- provoke earlier ones to be emitted
    go needed [] = if not (isEmptyIdSet needed) then
			pprTrace "ifaceBinds: free vars:" 
sof's avatar
sof committed
350
				  (sep (map (ppr PprDebug) (idSetToList needed))) $
351
352
353
354
355
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
356
	= case ifaceId get_idinfo needed False id rhs of
357
358
359
360
361
362
363
364
365
366
367
368
369
		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

sof's avatar
sof committed
370
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc])
371
372
373
374
375
376
377
378
379
    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

380
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
381
382
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
383
384
385
\end{code}


sof's avatar
sof committed
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
%************************************************************************
%*				 					*
\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)

upp_tycon tycon = ifaceTyCon PprInterface tycon
upp_class clas  = ifaceClass PprInterface clas
\end{code}


\begin{code}
ifaceTyCon :: PprStyle -> TyCon -> Doc	
ifaceTyCon sty tycon
  = case tycon of
	DataTyCon uniq name kind tyvars theta data_cons deriv new_or_data
	   -> hsep [	ptext (keyword new_or_data), 
			ppr_decl_context sty theta,
			ppr sty name,
			hsep (map (pprTyVarBndr sty) tyvars),
			ptext SLIT("="),
			hsep (punctuate (ptext SLIT(" | ")) (map ppr_con data_cons)),
			semi
		    ]

	SynTyCon uniq name kind arity tyvars ty
	   -> hsep [	ptext SLIT("type"),
			ppr sty name,
			hsep (map (pprTyVarBndr sty) tyvars),
			ptext SLIT("="),
			ppr sty ty,
			semi
		    ]
	other -> pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon)
  where
    keyword NewType  = SLIT("newtype")
    keyword DataType = SLIT("data")

    ppr_con data_con 
	| null field_labels
	= hsep [ ppr sty name,
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
	= hsep [ ppr sty name,
		  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

    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType sty ty

    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)
	= hsep [ ppr sty (fieldLabelName field_label),
		  ptext SLIT("::"),
		  ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label)
		]

ifaceClass sty clas
  = hsep [ptext SLIT("class"),
	   ppr_decl_context sty theta,
	   ppr sty clas,			-- Print the name
sof's avatar
sof committed
465
	   pprTyVarBndr sty clas_tyvar,
sof's avatar
sof committed
466
467
468
469
	   pp_ops,
	   semi
	  ]
   where
sof's avatar
sof committed
470
471
     (clas_tyvar, super_classes, _, sel_ids, defms) = classBigSig clas
     theta = super_classes `zip` repeat (mkTyVarTy clas_tyvar)
sof's avatar
sof committed
472

sof's avatar
sof committed
473
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
474
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
475
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
476
477
			  ]

sof's avatar
sof committed
478
479
480
481
482
483
484
485
486
     ppr_classop sel_id maybe_defm
	= ASSERT( sel_tyvars == [clas_tyvar])
	  hsep [ppr sty (getOccName sel_id),
		if maybeToBool maybe_defm then equals else empty,
	        ptext SLIT("::"),
		ppr sty op_ty
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
487
488
489
490
491
492
493
494
495
496
497

ppr_decl_context :: PprStyle -> [(Class,Type)] -> Doc
ppr_decl_context sty [] = empty
ppr_decl_context sty theta
  = braces (hsep (punctuate comma (map (ppr_dict) theta)))
    <> 
    ptext SLIT(" =>")
  where
    ppr_dict (clas,ty) = hsep [ppr sty clas, ppr sty ty]
\end{code}

498
499
500
501
502
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
503
504
505
506
507
508

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

509
\begin{code}
sof's avatar
sof committed
510
upp_avail NotAvailable      = empty
511
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
512
513
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
514
			    where
sof's avatar
sof committed
515
			      bang | name `elem` ns = empty
sof's avatar
sof committed
516
				   | otherwise	    = char '|'
517
			      ns' = filter (/= name) ns
518

sof's avatar
sof committed
519
upp_export []    = empty
sof's avatar
sof committed
520
upp_export names = parens (hsep (map (upp_occname . getOccName) names)) 
521

sof's avatar
sof committed
522
523
524
525
526
527
upp_fixity (occ, (Fixity prec dir, prov)) = hcat [upp_dir dir, space, 
						        int prec, space, 
					       	        upp_occname occ, semi]
upp_dir InfixR = ptext SLIT("infixr")
upp_dir InfixL = ptext SLIT("infixl")
upp_dir InfixN = ptext SLIT("infix")
528

sof's avatar
sof committed
529
ppr_unqual_name :: NamedThing a => a -> Doc		-- Just its occurrence name
530
531
ppr_unqual_name name = upp_occname (getOccName name)

sof's avatar
sof committed
532
533
ppr_name :: NamedThing a => a -> Doc		-- Its full name
ppr_name   n = ptext (nameString (getName n))
534

sof's avatar
sof committed
535
536
upp_occname :: OccName -> Doc
upp_occname occ = ptext (occNameString occ)
537

sof's avatar
sof committed
538
539
upp_module :: Module -> Doc
upp_module mod = ptext mod
540

sof's avatar
sof committed
541
uppSemid   x = ppr PprInterface x <> semi -- micro util
542

sof's avatar
sof committed
543
544
545
ppr_ty	  ty = pprType PprInterface ty
ppr_tyvar tv = ppr PprInterface tv
ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv
546

sof's avatar
sof committed
547
ppr_decl decl = ppr PprInterface decl <> semi
548
549
\end{code}

550

551
%************************************************************************
552
553
554
%*				 					*
\subsection{Comparisons
%*				 					*
555
%************************************************************************
556
				 
557

558
559
560
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
561

562
563
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
564

565
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
566

567
568
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
569

570
571
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
572

573
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
574
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
575

576
sort_versions vs = sortLt lt_vers vs
577

578
579
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
580
581
\end{code}

582

583
\begin{code}
584
hPutCol :: Handle 
sof's avatar
sof committed
585
	-> (a -> Doc)
586
587
	-> [a]
	-> IO ()
sof's avatar
sof committed
588
589
590
591
592
hPutCol hdl fmt xs = mapIO (printDoc OneLineMode hdl . fmt) xs

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