MkIface.lhs 19.2 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
			)
48
49
50
51
52
import TyCon		( TyCon {-instance NamedThing-},
			  isSynTyCon, isAlgTyCon, isNewTyCon, tyConDataCons,
			  tyConTheta, tyConTyVars,
			  getSynTyConDefn
			)
sof's avatar
sof committed
53
import Class		( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig )
sof's avatar
sof committed
54
55
import FieldLabel	( FieldLabel{-instance NamedThing-}, 
		          fieldLabelName, fieldLabelType )
sof's avatar
sof committed
56
import Type		( mkSigmaTy, mkDictTy, getAppTyCon, splitSigmaTy,
sof's avatar
sof committed
57
58
			  mkTyVarTy, SYN_IE(Type)
		        )
59
60
61
import TyVar		( GenTyVar {- instance Eq -} )
import Unique		( Unique {- instance Eq -} )

62
import PprEnv		-- not sure how much...
sof's avatar
sof committed
63
import Outputable	( PprStyle(..), Outputable(..) )
64
65
66
import PprType
import PprCore		( pprIfaceUnfolding )
import Pretty
sof's avatar
sof committed
67
import Outputable	( printDoc )
68

69

sof's avatar
sof committed
70
import Bag		( bagToList, isEmptyBag )
71
import Maybes		( catMaybes, maybeToBool )
72
import FiniteMap	( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap )
73
74
import UniqFM		( UniqFM, lookupUFM, listToUFM )
import Util		( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
sof's avatar
sof committed
75
76
77
			  assertPanic, panic{-ToDo:rm-}, pprTrace,
			  pprPanic 
			)
78
79
80
\end{code}

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

ifaceMain   :: Maybe Handle
	    -> InterfaceDetails
94
	    -> IO ()
95
96
97


ifaceDecls :: Maybe Handle
sof's avatar
sof committed
98
	   -> [TyCon] -> [Class]
99
	   -> Bag InstInfo 
100
101
102
103
104
	   -> [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 ()
105
106
107
108
109
110
111
112
\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 ->
113
	hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
114
115
116
117
	return (Just if_hdl)

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

120

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

163
164
	-- For imported versions we do print the version number
    upp_import_versions nvs
sof's avatar
sof committed
165
      = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- nvs ]
166

167

168
169
170
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
  = hPutStr if_hdl "_instance_modules_\n" >>
sof's avatar
sof committed
171
    printDoc OneLineMode if_hdl (hsep (map ptext (sortLt (<) imods))) >>
172
    hPutStr if_hdl "\n"
173

174
175
176
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
  = hPutStr if_hdl "_exports_\n"			>>
177
178
179
180
181
    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
182

183
    insert NotAvailable efm = efm
184
185
    insert avail efm = addToFM_C (++) efm mod [avail] 
		     where
sof's avatar
sof committed
186
		       mod = nameModule (availName avail)
187
188

	-- Print one module's worth of stuff
sof's avatar
sof committed
189
190
191
192
193
194
195
196
197
    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 '!'
198

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

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

211
212

\begin{code}			 
213
214
215
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
  | null togo_insts = return emptyIdSet		 
216
  | otherwise 	    = hPutStr if_hdl "_instances_\n" >>
217
218
		      hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
		      return needed_ids
219
220
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
221
    needed_ids  = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
222
223
224
225
226
227
228
229
230
231
232
233
234
    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
235
	    renumbered_ty = nmbrGlobalType forall_ty
236
	in			 
sof's avatar
sof committed
237
238
	hcat [ptext SLIT("instance "), ppr_ty renumbered_ty, 
		    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
sof's avatar
sof committed
258
	    -> Maybe (Doc, IdSet)	-- The emitted stuff, plus a possibly-augmented set of needed Ids
259

260
261
262
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
263
264
  = Nothing 		-- Well, that was easy!

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

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

275
    prag_pretty 
sof's avatar
sof committed
276
277
     | opt_OmitInterfacePragmas = empty
     | otherwise		= hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
278
279
280
281
282
283

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

    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
sof's avatar
sof committed
284
285
286
287
288
289
290
291
292
    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
293
294

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

sof's avatar
sof committed
298
299
    show_unfold = not implicit_unfolding && 		-- Not unnecessary
		  not dodgy_unfolding			-- Not dangerous
300

sof's avatar
sof committed
301
    implicit_unfolding = has_worker ||
302
303
			 bottomIsGuaranteed strict_info

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

    guidance    = calcUnfoldingGuidance inline_pragma
309
310
311
312
313
314
315
316
317
318
319
320
					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
321
322
    worker_ids | has_worker = unitIdSet work_id
	       | otherwise  = emptyIdSet
323
324
325
326
327

    unfold_ids | show_unfold = free_vars
	       | otherwise   = emptyIdSet
			     where
			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
328
329
330
			       interesting bound id = isLocallyDefined id &&
						      not (id `elementOfIdSet` bound) &&
						      not (omitIfaceSigForId id)
331
332
333
\end{code}

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

340
ifaceBinds hdl needed_ids final_ids binds
sof's avatar
sof committed
341
  = mapIO (printDoc OneLineMode hdl) pretties >>
342
    hPutStr hdl "\n"
343
  where
344
345
346
347
348
349
    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

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

    go needed (NonRec id rhs : binds)
360
	= case ifaceId get_idinfo needed False id rhs of
361
362
363
364
365
366
367
368
369
370
371
372
373
		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
374
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc])
375
376
377
378
379
380
381
382
383
    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

384
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
385
386
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
387
388
389
\end{code}


sof's avatar
sof committed
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
%************************************************************************
%*				 					*
\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	
410

sof's avatar
sof committed
411
ifaceTyCon sty tycon
412
413
414
415
416
417
418
419
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
	   ppr sty (getName tycon),
	   hsep (map (pprTyVarBndr sty) tyvars),
	   ptext SLIT("="),
	   ppr sty ty,
	   semi
    ]
sof's avatar
sof committed
420
  where
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
    (tyvars, ty) = getSynTyConDefn tycon

ifaceTyCon sty tycon
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
	   ppr_decl_context sty (tyConTheta tycon),
	   ppr sty (getName tycon),
	   hsep (map (pprTyVarBndr sty) (tyConTyVars tycon)),
	   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
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
465
466

    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)
		]

467
468
469
ifaceTyCon sty tycon
  = pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon)

sof's avatar
sof committed
470
471
472
473
ifaceClass sty clas
  = hsep [ptext SLIT("class"),
	   ppr_decl_context sty theta,
	   ppr sty clas,			-- Print the name
sof's avatar
sof committed
474
	   pprTyVarBndr sty clas_tyvar,
sof's avatar
sof committed
475
476
477
478
	   pp_ops,
	   semi
	  ]
   where
sof's avatar
sof committed
479
480
     (clas_tyvar, super_classes, _, sel_ids, defms) = classBigSig clas
     theta = super_classes `zip` repeat (mkTyVarTy clas_tyvar)
sof's avatar
sof committed
481

sof's avatar
sof committed
482
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
483
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
484
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
485
486
			  ]

sof's avatar
sof committed
487
488
489
490
491
492
493
494
495
     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
496
497
498
499
500
501
502
503
504
505
506

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}

507
508
509
510
511
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
512
513
514
515
516
517

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

518
\begin{code}
sof's avatar
sof committed
519
upp_avail NotAvailable      = empty
520
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
521
522
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
523
			    where
sof's avatar
sof committed
524
			      bang | name `elem` ns = empty
sof's avatar
sof committed
525
				   | otherwise	    = char '|'
526
			      ns' = filter (/= name) ns
527

sof's avatar
sof committed
528
upp_export []    = empty
sof's avatar
sof committed
529
upp_export names = parens (hsep (map (upp_occname . getOccName) names)) 
530

sof's avatar
sof committed
531
532
533
534
535
536
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")
537

sof's avatar
sof committed
538
ppr_unqual_name :: NamedThing a => a -> Doc		-- Just its occurrence name
539
540
ppr_unqual_name name = upp_occname (getOccName name)

sof's avatar
sof committed
541
542
ppr_name :: NamedThing a => a -> Doc		-- Its full name
ppr_name   n = ptext (nameString (getName n))
543

sof's avatar
sof committed
544
545
upp_occname :: OccName -> Doc
upp_occname occ = ptext (occNameString occ)
546

sof's avatar
sof committed
547
548
upp_module :: Module -> Doc
upp_module mod = ptext mod
549

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

sof's avatar
sof committed
552
553
554
ppr_ty	  ty = pprType PprInterface ty
ppr_tyvar tv = ppr PprInterface tv
ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv
555

sof's avatar
sof committed
556
ppr_decl decl = ppr PprInterface decl <> semi
557
558
\end{code}

559

560
%************************************************************************
561
562
563
%*				 					*
\subsection{Comparisons
%*				 					*
564
%************************************************************************
565
				 
566

567
568
569
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
570

571
572
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
573

574
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
575

576
577
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
578

579
580
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
581

582
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
sof's avatar
sof committed
583
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
584

585
sort_versions vs = sortLt lt_vers vs
586

587
588
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
589
590
\end{code}

591

592
\begin{code}
593
hPutCol :: Handle 
sof's avatar
sof committed
594
	-> (a -> Doc)
595
596
	-> [a]
	-> IO ()
sof's avatar
sof committed
597
598
599
600
601
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
602
\end{code}