MkIface.lhs 18.4 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(..) )
22
import RnMonad
23
import RnEnv		( availName )
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
32
			  dataConStrictMarks, StrictnessMark(..), 
			  SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, 
			  isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
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
			  getWorkerId_maybe, 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 Name		( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
sof's avatar
sof committed
44
45
			  OccName, occNameString, nameOccName, nameString, isExported,
			  Name {-instance NamedThing-}, Provenance, NamedThing(..)
46
			)
sof's avatar
sof committed
47
48
49
50
51
import TyCon		( TyCon(..) {-instance NamedThing-} )
import Class		( GenClass(..){-instance NamedThing-}, SYN_IE(Class), GenClassOp, 
			  classOpLocalType, classSig )
import FieldLabel	( FieldLabel{-instance NamedThing-}, 
		          fieldLabelName, fieldLabelType )
sof's avatar
sof committed
52
import Type		( mkSigmaTy, mkDictTy, getAppTyCon,
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
143
144
145
146
    where
     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
154
    upp_uses (m, mv, versions)
sof's avatar
sof committed
155
156
      = hcat [upp_module m, space, int mv, ptext SLIT(" :: "),
		    upp_import_versions (sort_versions versions), semi]
157

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

162

163
164
165
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
  = hPutStr if_hdl "_instance_modules_\n" >>
sof's avatar
sof committed
166
    printDoc OneLineMode if_hdl (hsep (map ptext (sortLt (<) imods))) >>
167
    hPutStr if_hdl "\n"
168

169
170
171
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
  = hPutStr if_hdl "_exports_\n"			>>
172
173
174
175
176
    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
177

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

	-- Print one module's worth of stuff
    do_one_module (mod_name, avails)
sof's avatar
sof committed
185
186
187
	= hcat [upp_module mod_name, space, 
		      hsep (map upp_avail (sortLt lt_avail avails)),
		      semi]
188

189
190
191
192
193
194
195
196
197
198
199
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
  = hPutStr if_hdl "_fixities_\n"		>>
    hPutCol if_hdl upp_fixity fixities
\end{code}			 

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

201
202

\begin{code}			 
203
204
205
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
  | null togo_insts = return emptyIdSet		 
206
  | otherwise 	    = hPutStr if_hdl "_instances_\n" >>
207
208
		      hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
		      return needed_ids
209
210
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
211
    needed_ids  = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
    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)
	    renumbered_ty = renumber_ty forall_ty
	in			 
sof's avatar
sof committed
227
228
	hcat [ptext SLIT("instance "), ppr_ty renumbered_ty, 
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
229
230
\end{code}

231
232
233
234
235
236
237

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

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

250
251
252
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
253
254
  = Nothing 		-- Well, that was easy!

255
ifaceId get_idinfo needed_ids is_rec id rhs
sof's avatar
sof committed
256
  = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
257
  where
sof's avatar
sof committed
258
    pp_double_semi = ptext SLIT(";;")
259
    idinfo         = get_idinfo id
sof's avatar
sof committed
260
    inline_pragma  = getInlinePragma id 
261

262
    ty_pretty  = pprType PprInterface (initNmbr (nmbrType (idType id)))
sof's avatar
sof committed
263
    sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
264

265
    prag_pretty 
sof's avatar
sof committed
266
267
     | opt_OmitInterfacePragmas = empty
     | otherwise		= hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
268
269
270
271
272
273
274
275
276
277

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

    ------------  Strictness  --------------
    strict_info   = strictnessInfo idinfo
    maybe_worker  = getWorkerId_maybe strict_info
    strict_pretty = ppStrictnessInfo PprInterface strict_info

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

sof's avatar
sof committed
281
282
    show_unfold = not implicit_unfolding && 		-- Not unnecessary
		  not dodgy_unfolding			-- Not dangerous
283

284
285
286
    implicit_unfolding = maybeToBool maybe_worker ||
			 bottomIsGuaranteed strict_info

sof's avatar
sof committed
287
288
    dodgy_unfolding = case guidance of 			-- True <=> too big to show, or the Inline pragma
			UnfoldNever -> True		-- says it shouldn't be inlined
289
290
291
			other       -> False

    guidance    = calcUnfoldingGuidance inline_pragma
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
					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

    worker_ids = case maybe_worker of
			Just wkr -> unitIdSet wkr
			Nothing  -> emptyIdSet

    unfold_ids | show_unfold = free_vars
	       | otherwise   = emptyIdSet
			     where
			       (_,free_vars) = addExprFVs interesting emptyIdSet rhs
312
313
314
			       interesting bound id = isLocallyDefined id &&
						      not (id `elementOfIdSet` bound) &&
						      not (omitIfaceSigForId id)
315
316
317
\end{code}

\begin{code}
318
ifaceBinds :: Handle
319
	   -> IdSet		-- These Ids are needed already
320
321
322
323
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBinding]	-- In dependency order, later depend on earlier
	   -> IO ()

324
ifaceBinds hdl needed_ids final_ids binds
sof's avatar
sof committed
325
  = mapIO (printDoc OneLineMode hdl) pretties >>
326
    hPutStr hdl "\n"
327
  where
328
329
330
331
332
333
    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

334
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
335
336
337
						-- provoke earlier ones to be emitted
    go needed [] = if not (isEmptyIdSet needed) then
			pprTrace "ifaceBinds: free vars:" 
sof's avatar
sof committed
338
				  (sep (map (ppr PprDebug) (idSetToList needed))) $
339
340
341
342
343
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
344
	= case ifaceId get_idinfo needed False id rhs of
345
346
347
348
349
350
351
352
353
354
355
356
357
		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
358
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc])
359
360
361
362
363
364
365
366
367
    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

368
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
369
370
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
371
372
373
\end{code}


sof's avatar
sof committed
374
375
376
377
378
379
380
381
382
383
384
385
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
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
%************************************************************************
%*				 					*
\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
	   pprTyVarBndr sty tyvar,
	   pp_ops,
	   semi
	  ]
   where
     (tyvar, super_classes, ops) = classSig clas
     theta = super_classes `zip` repeat (mkTyVarTy tyvar)

     pp_ops | null ops  = empty
	    | otherwise = hsep [ptext SLIT("where"),
				 braces (hsep (punctuate semi (map ppr_classop ops)))
			  ]

     ppr_classop op = hsep [ppr sty (getOccName op),
			     ptext SLIT("::"),
			     ppr sty (classOpLocalType op)
			    ]

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}

481
482
483
484
485
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
486
487
488
489
490
491

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

492
\begin{code}
sof's avatar
sof committed
493
upp_avail NotAvailable      = empty
494
upp_avail (Avail name)      = upp_occname (getOccName name)
sof's avatar
sof committed
495
496
upp_avail (AvailTC name []) = empty
upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
497
			    where
sof's avatar
sof committed
498
499
			      bang | name `elem` ns = empty
				   | otherwise	    = char '!'
500
			      ns' = filter (/= name) ns
501

sof's avatar
sof committed
502
503
504
505
upp_export []    = empty
upp_export names = hcat [char '(', 
			       hsep (map (upp_occname . getOccName) names), 
			       char ')']
506

sof's avatar
sof committed
507
508
509
510
511
512
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")
513

sof's avatar
sof committed
514
ppr_unqual_name :: NamedThing a => a -> Doc		-- Just its occurrence name
515
516
ppr_unqual_name name = upp_occname (getOccName name)

sof's avatar
sof committed
517
518
ppr_name :: NamedThing a => a -> Doc		-- Its full name
ppr_name   n = ptext (nameString (getName n))
519

sof's avatar
sof committed
520
521
upp_occname :: OccName -> Doc
upp_occname occ = ptext (occNameString occ)
522

sof's avatar
sof committed
523
524
upp_module :: Module -> Doc
upp_module mod = ptext mod
525

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

sof's avatar
sof committed
528
529
530
ppr_ty	  ty = pprType PprInterface ty
ppr_tyvar tv = ppr PprInterface tv
ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv
531

sof's avatar
sof committed
532
ppr_decl decl = ppr PprInterface decl <> semi
533
534

renumber_ty ty = initNmbr (nmbrType ty)
535
536
\end{code}

537

538
%************************************************************************
539
540
541
%*				 					*
\subsection{Comparisons
%*				 					*
542
%************************************************************************
543
				 
544

545
546
547
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
548

549
550
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
551

552
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
553

554
555
lt_name :: Name -> Name -> Bool
n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
556

557
558
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
559

560
561
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
562

563
sort_versions vs = sortLt lt_vers vs
564

565
566
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
567
568
\end{code}

569

570
\begin{code}
571
hPutCol :: Handle 
sof's avatar
sof committed
572
	-> (a -> Doc)
573
574
	-> [a]
	-> IO ()
sof's avatar
sof committed
575
576
577
578
579
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
580
\end{code}