MkIface.lhs 19.9 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
40
			  cprInfo, ppCprInfo,
			  workerExists, workerInfo, isBottomingStrictness
41
			)
42
43
44
45
import CoreSyn		( CoreExpr, CoreBind, Bind(..) )
import CoreUtils	( exprSomeFreeVars )
import CoreUnfold	( calcUnfoldingGuidance, UnfoldingGuidance(..), 
			  Unfolding, okToUnfoldInHiFile )
sof's avatar
sof committed
46
import Module		( moduleString, pprModule, pprModuleBoot )
47
48
import Name		( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
			  isExported,
49
			  Name, NamedThing(..)
50
			)
sof's avatar
sof committed
51
import OccName		( OccName, pprOccName )
52
53
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
54
			)
55
import Class		( Class, classBigSig )
56
import SpecEnv		( specEnvToList )
57
import FieldLabel	( fieldLabelName, fieldLabelType )
58
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
59
			  Type, ThetaType
sof's avatar
sof committed
60
		        )
61
62
63
64

import PprType
import PprCore		( pprIfaceUnfolding )

sof's avatar
sof committed
65
import Bag		( bagToList, isEmptyBag )
66
import Maybes		( catMaybes, maybeToBool )
67
68
69
70
import FiniteMap	( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
import UniqFM		( lookupUFM, listToUFM )
import UniqSet		( uniqSetToList )
import Util		( sortLt, mapAccumL )
71
import Outputable
72
73
74
\end{code}

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

ifaceMain   :: Maybe Handle
	    -> InterfaceDetails
88
	    -> IO ()
89
90
91


ifaceDecls :: Maybe Handle
sof's avatar
sof committed
92
	   -> [TyCon] -> [Class]
93
	   -> Bag InstInfo 
94
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
95
	   -> [CoreBind]	-- In dependency order, later depend on earlier
96
97
98
	   -> IO ()

endIface    :: Maybe Handle -> IO ()
99
100
101
102
103
104
\end{code}

\begin{code}
startIface mod
  = case opt_ProduceHi of
      Nothing -> return Nothing -- not producing any .hi file
sof's avatar
sof committed
105
106
      Just fn -> do
	if_hdl <- openFile fn WriteMode
107
	hPutStr if_hdl ("__interface " ++ moduleString mod ++ ' ':show (opt_HiVersion :: Int))
108
	hPutStrLn if_hdl " where"
109
110
111
112
	return (Just if_hdl)

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

115

116
117
118
119
\begin{code}
ifaceMain Nothing iface_stuff = return ()
ifaceMain (Just if_hdl)
	  (import_usages, ExportEnv avails fixities, instance_modules)
120
121
122
123
124
  = do
    ifaceImports		if_hdl import_usages
    ifaceInstanceModules	if_hdl instance_modules
    ifaceExports		if_hdl avails
    ifaceFixities		if_hdl fixities
125
126
    return ()

sof's avatar
sof committed
127
ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
128
ifaceDecls (Just hdl)
sof's avatar
sof committed
129
	   tycons classes
130
	   inst_infos
131
	   final_ids binds
sof's avatar
sof committed
132
  | null_decls = return ()		 
133
	--  You could have a module with just (re-)exports/instances in it
134
  | otherwise
135
136
  = ifaceClasses hdl classes			>>
    ifaceInstances hdl inst_infos		>>= \ needed_ids ->
sof's avatar
sof committed
137
    ifaceTyCons hdl tycons			>>
138
    ifaceBinds hdl needed_ids final_ids binds	>>
139
    return ()
sof's avatar
sof committed
140
  where
sof's avatar
sof committed
141
142
143
144
     null_decls = null binds      && 
		  null tycons     &&
	          null classes    && 
	          isEmptyBag inst_infos
145
146
147
\end{code}

\begin{code}
148
149
ifaceImports if_hdl import_usages
  = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
150
  where
151
    upp_uses (m, mv, whats_imported)
152
      = ptext SLIT("import ") <>
153
	hsep [pprModule m, pprModuleBoot m, int mv, dcolon,
154
	      upp_import_versions whats_imported
sof's avatar
sof committed
155
	] <> semi
156

157
158
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
159

160
161
162
	-- 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 ]
163

164
165
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
166
  = let sorted = sortLt (<) imods
167
	lines = map (\m -> ptext SLIT("__instimport ") <> pprModule m <>
168
169
170
			   ptext SLIT(" ;")) sorted
    in 
    printForIface if_hdl (vcat lines) >>
171
    hPutStr if_hdl "\n"
172

173
174
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
175
  = hPutCol if_hdl do_one_module (fmToList export_fm)
176
177
178
179
  where
	-- Sort them into groups by module
    export_fm :: FiniteMap Module [AvailInfo]
    export_fm = foldr insert emptyFM avails
180
181
182

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

	-- Print one module's worth of stuff
sof's avatar
sof committed
186
    do_one_module :: (Module, [AvailInfo]) -> SDoc
sof's avatar
sof committed
187
    do_one_module (mod_name, avails@(avail1:_))
188
	= ptext SLIT("__export ") <>
189
	  hsep [pprModuleBoot (nameModule (availName avail1)), 
190
		pprModule mod_name,
sof's avatar
sof committed
191
192
193
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

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

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

205
206

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

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

243
244
245
246
247
248
249

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

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

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

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

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

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

    ------------  Arity  --------------
288
    arity_pretty  = ppArityInfo (arityInfo idinfo)
289

290
291
292
    ------------ Caf Info --------------
    caf_pretty = ppCafInfo (cafInfo idinfo)

293
294
295
296
    ------------ CPR Info --------------
    cpr_pretty = ppCprInfo (cprInfo idinfo)

    ------------  Strictness and Worker  --------------
297
    strict_info   = strictnessInfo idinfo
298
299
    work_info     = workerInfo idinfo
    has_worker    = workerExists work_info
300
    bottoming_fn  = isBottomingStrictness strict_info
301
    strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
sof's avatar
sof committed
302
303

    wrkr_pretty | not has_worker = empty
304
305
306
		| null con_list  = ppr work_id
		| otherwise      = ppr work_id <+> 
				   braces (hsep (map ppr con_list))
sof's avatar
sof committed
307

308
309
310
311
312
--    (Just work_id) = work_info
-- Temporary fix.  We can't use the worker id saved by the w/w
-- pass because later optimisations may have changed it.  So try
-- to snaffle from the wrapper code again ...
    (work_id, wrapper_cons)   = getWorkerIdAndCons id rhs
313
    con_list       = uniqSetToList wrapper_cons
314
315

    ------------  Unfolding  --------------
316
    unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
sof's avatar
sof committed
317
		  | otherwise   = empty
318

319
320
    show_unfold = not has_worker	&&	-- Not unnecessary
		  not bottoming_fn	&&	-- Not necessary
321
322
323
324
325
326
327
		  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
328

329

330
331
332
333
334
335
336
    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
337

sof's avatar
sof committed
338
    definitely_ok_to_unfold =  okToUnfoldInHiFile rhs
339
340

    ------------  Specialisations --------------
341
342
    spec_list = specEnvToList (getIdSpecialisation id)
    spec_pretty = hsep (map pp_spec spec_list)
343
    pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
344
				       if null tyvars then ptext SLIT("[ ]")
345
						      else brackets (interppSP tyvars),
346
					-- The lexer interprets "[]" as a CONID.  Sigh.
347
348
				       hsep (map pprParendType tys),
				       ptext SLIT("="),
349
				       pprIfaceUnfolding rhs
350
				 ]
351
352
    
    ------------  Extra free Ids  --------------
353
    new_needed_ids = (needed_ids `minusVarSet` unitVarSet id)	`unionVarSet` 
354
355
		     extra_ids

356
357
358
    extra_ids | opt_OmitInterfacePragmas = emptyVarSet
	      | otherwise		 = worker_ids	`unionVarSet`
					   unfold_ids	`unionVarSet`
359
					   spec_ids
360

361
362
363
364
    worker_ids | has_worker && interesting work_id = unitVarSet work_id
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
365

366
    spec_ids = foldr add emptyVarSet spec_list
367
	     where
368
	       add (_, _, rhs) = unionVarSet (find_fvs rhs)
369
370

    unfold_ids | show_unfold = find_fvs rhs
371
	       | otherwise   = emptyVarSet
372
373
374

    find_fvs expr = free_vars
		  where
375
		    free_vars = exprSomeFreeVars interesting expr
376
377
378

    interesting id = isId id && isLocallyDefined id &&
		     not (omitIfaceSigForId id)
379
380
381
\end{code}

\begin{code}
382
ifaceBinds :: Handle
383
	   -> IdSet		-- These Ids are needed already
384
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
385
	   -> [CoreBind]	-- In dependency order, later depend on earlier
386
387
	   -> IO ()

388
ifaceBinds hdl needed_ids final_ids binds
389
  = mapIO (printForIface hdl) pretties >>
390
    hPutStr hdl "\n"
391
  where
392
393
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
394
			Just id' -> idInfo id'
395
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
396
				    idInfo id
397

398
    pretties = go needed_ids (reverse binds)	-- Reverse so that later things will 
399
						-- provoke earlier ones to be emitted
400
    go needed [] = if not (isEmptyVarSet needed) then
401
			pprTrace "ifaceBinds: free vars:" 
402
				  (sep (map ppr (varSetElems needed))) $
403
404
405
406
407
			[]
		   else
			[]

    go needed (NonRec id rhs : binds)
408
	= case ifaceId get_idinfo needed False id rhs of
409
410
411
412
413
414
415
416
417
418
		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
419
	  needed'' = needed' `minusVarSet` mkVarSet (map fst pairs)
420
421
		-- Later ones may spuriously cause earlier ones to be "needed" again

422
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
423
424
425
426
427
428
429
430
431
    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

432
	  do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
433
434
					Nothing		       -> (needed,  Nothing)
					Just (pretty, needed') -> (needed', Just pretty)
435
436
437
\end{code}


sof's avatar
sof committed
438
439
440
441
442
443
444
445
446
447
448
449
450
%************************************************************************
%*				 					*
\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)

451
452
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
453
454
455
456
\end{code}


\begin{code}
457
458
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
459
460
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
461
462
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
463
	   ptext SLIT("="),
464
	   ppr ty,
465
466
	   semi
    ]
sof's avatar
sof committed
467
  where
468
469
    (tyvars, ty) = getSynTyConDefn tycon

470
ifaceTyCon tycon
471
472
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
473
474
475
	   ppr_decl_context (tyConTheta tycon),
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
476
477
478
479
480
481
482
	   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
483

484
485
    tyvars = tyConTyVars tycon

sof's avatar
sof committed
486
487
    ppr_con data_con 
	| null field_labels
488
489
490
	= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	  hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
491
492
493
494
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
495
496
	= hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
497
498
499
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
500
	   (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
sof's avatar
sof committed
501
502
503
504
           field_labels   = dataConFieldLabels data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

505
506
507
508
    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("=>")

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

511
512
513
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
514
515

    ppr_field (strict_mark, field_label)
516
	= hsep [ ppr (fieldLabelName field_label),
517
		  dcolon,
518
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
519
520
		]

521
522
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
523

524
ifaceClass clas
sof's avatar
sof committed
525
  = hsep [ptext SLIT("class"),
526
527
528
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
529
530
531
532
	   pp_ops,
	   semi
	  ]
   where
533
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
534

sof's avatar
sof committed
535
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
536
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
537
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
538
539
			  ]

sof's avatar
sof committed
540
     ppr_classop sel_id maybe_defm
541
542
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
543
		if maybeToBool maybe_defm then equals else empty,
544
	        dcolon,
545
		ppr op_ty
sof's avatar
sof committed
546
547
548
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
549

550
ppr_decl_context :: ThetaType -> SDoc
551
552
553
554
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
555
556
pprIfaceTheta []    = empty
pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
557
558
\end{code}

559
560
561
562
563
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
564
565
566
567
568
569

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

570
\begin{code}
571
572
upp_avail :: AvailInfo -> SDoc
upp_avail (Avail name)      = pprOccName (getOccName name)
sof's avatar
sof committed
573
upp_avail (AvailTC name []) = empty
574
upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
575
			    where
sof's avatar
sof committed
576
			      bang | name `elem` ns = empty
sof's avatar
sof committed
577
				   | otherwise	    = char '|'
578
			      ns' = filter (/= name) ns
579

580
upp_export :: [Name] -> SDoc
sof's avatar
sof committed
581
upp_export []    = empty
582
upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
583

584
585
586
upp_fixity :: (Name, Fixity) -> SDoc
upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
	-- Dummy version number!
587

588
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
589
ppr_unqual_name name = pprOccName (getOccName name)
590
591
\end{code}

592

593
%************************************************************************
594
595
596
%*				 					*
\subsection{Comparisons
%*				 					*
597
%************************************************************************
598
				 
599

600
601
602
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
603

604
605
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
606

607
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
608

609
lt_name :: Name -> Name -> Bool
610
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
611

612
613
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
614

615
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
616
lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
617

618
sort_versions vs = sortLt lt_vers vs
619

620
621
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
622
623
\end{code}

624

625
\begin{code}
626
hPutCol :: Handle 
627
	-> (a -> SDoc)
628
629
	-> [a]
	-> IO ()
630
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
631
632
633
634

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