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

\begin{code}
7
module MkIface (
8
	startIface, endIface, ifaceDecls
9
    ) where
10

11
12
#include "HsVersions.h"

sof's avatar
sof committed
13
14
import IO		( Handle, hPutStr, openFile, 
			  hClose, hPutStrLn, IOMode(..) )
15
16

import HsSyn
17
import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..) )
18
import RnMonad
19
import RnEnv		( availName )
20
21
22
23

import TcInstUtil	( InstInfo(..) )

import CmdLineOpts
24
import Id		( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
25
			  getIdSpecialisation
26
			)
27
28
import Var		( isId )
import VarSet
29
import DataCon		( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
30
import IdInfo		( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
31
			  arityInfo, ppArityInfo, 
32
			  strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
33
			  cafInfo, ppCafInfo, specInfo,
34
			  cprInfo, ppCprInfo,
35
			  workerExists, workerInfo, ppWorkerInfo
36
			)
37
38
39
40
import CoreSyn		( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold	( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline )
import Module		( moduleString, pprModule, pprModuleName )
41
import Name		( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
42
			  Name, NamedThing(..)
43
			)
sof's avatar
sof committed
44
import OccName		( OccName, pprOccName )
45
46
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
47
			)
48
49
import Class		( Class, classBigSig )
import FieldLabel	( fieldLabelName, fieldLabelType )
50
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
51
			  Type, ThetaType
sof's avatar
sof committed
52
		        )
53
54

import PprType
55
56
import PprCore		( pprIfaceUnfolding, pprCoreRule )
import Rules		( pprProtoCoreRule, ProtoCoreRule(..) )
57

sof's avatar
sof committed
58
import Bag		( bagToList, isEmptyBag )
59
import Maybes		( catMaybes, maybeToBool )
60
61
62
63
import FiniteMap	( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
import UniqFM		( lookupUFM, listToUFM )
import UniqSet		( uniqSetToList )
import Util		( sortLt, mapAccumL )
64
import Bag
65
import Outputable
66
67
68
\end{code}

We have a function @startIface@ to open the output file and put
69
(something like) ``interface Foo'' in it.  It gives back a handle
70
71
72
73
74
75
76
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}
77
startIface  :: Module -> InterfaceDetails
78
	    -> IO (Maybe Handle) -- Nothing <=> don't do an interface
79
80

ifaceDecls :: Maybe Handle
sof's avatar
sof committed
81
	   -> [TyCon] -> [Class]
82
	   -> Bag InstInfo 
83
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
84
	   -> [CoreBind]	-- In dependency order, later depend on earlier
85
	   -> [ProtoCoreRule]	-- Rules
86
87
88
	   -> IO ()

endIface    :: Maybe Handle -> IO ()
89
90
91
\end{code}

\begin{code}
92
startIface mod (has_orphans, import_usages, ExportEnv avails fixities)
93
  = case opt_ProduceHi of
94
95
96
      Nothing -> return Nothing ; -- not producing any .hi file

      Just fn -> do 
sof's avatar
sof committed
97
	if_hdl <- openFile fn WriteMode
98
99
100
101
102
103
	hPutStr		if_hdl ("__interface " ++ moduleString mod)
	hPutStr		if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator)
	hPutStrLn	if_hdl " where"
	ifaceExports	if_hdl avails
	ifaceImports	if_hdl import_usages
	ifaceFixities	if_hdl fixities
104
	return (Just if_hdl)
105
106
107
  where
    orphan_indicator | has_orphans = " !"
		     | otherwise   = ""
108
109
110

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

113

114
\begin{code}
115
ifaceDecls Nothing tycons classes inst_info final_ids simplified rules = return ()
116
ifaceDecls (Just hdl)
sof's avatar
sof committed
117
	   tycons classes
118
	   inst_infos
119
	   final_ids binds
120
	   orphan_rules		-- Rules defined locally for an Id that is *not* defined locally
sof's avatar
sof committed
121
  | null_decls = return ()		 
122
	--  You could have a module with just (re-)exports/instances in it
123
  | otherwise
124
  = ifaceClasses hdl classes			>>
125
    ifaceInstances hdl inst_infos		>>= \ inst_ids ->
sof's avatar
sof committed
126
    ifaceTyCons hdl tycons			>>
127
128
129
    ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids)
	       final_ids binds			>>= \ emitted_ids ->
    ifaceRules hdl orphan_rules emitted_ids	>>
130
    return ()
sof's avatar
sof committed
131
  where
132
133
134
     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
				    | ProtoCoreRule _ _ rule <- orphan_rules]

sof's avatar
sof committed
135
136
137
     null_decls = null binds      && 
		  null tycons     &&
	          null classes    && 
138
139
	          isEmptyBag inst_infos &&
		  null orphan_rules
140
141
142
\end{code}

\begin{code}
143
144
ifaceImports if_hdl import_usages
  = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
145
  where
146
147
148
    upp_uses (m, mv, has_orphans, whats_imported)
      = hsep [ptext SLIT("import"), pprModuleName m, 
	      int mv, pp_orphan,
149
	      upp_import_versions whats_imported
sof's avatar
sof committed
150
	] <> semi
151
152
153
      where
	pp_orphan | has_orphans = ptext SLIT("!")
		  | otherwise   = empty
154

155
156
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
157

158
159
	-- For imported versions we do print the version number
    upp_import_versions (Specifically nvs)
160
161
162
163
164
165
166
167
168
      = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]

ifaceModuleDeps if_hdl [] = return ()
ifaceModuleDeps if_hdl mod_deps
  = let 
	lines = map ppr_mod_dep mod_deps
	ppr_mod_dep (mod, contains_orphans) 
	   | contains_orphans = pprModuleName mod <+> ptext SLIT("!")
	   | otherwise	      = pprModuleName mod
169
    in 
170
    printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
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 [pprModule mod_name,
sof's avatar
sof committed
190
191
192
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

193
194
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
195
  = hPutCol if_hdl upp_fixity fixities
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222

ifaceRules if_hdl rules emitted
  | null orphan_rule_pretties && null local_id_pretties
  = return ()
  | otherwise
  = do	printForIface if_hdl (vcat [
		ptext SLIT("{-## __R"),

		vcat orphan_rule_pretties,

		vcat local_id_pretties,

		ptext SLIT("##-}")
          ])
	
	return ()
  where
    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule <+> semi
			    | ProtoCoreRule _ fn rule <- rules
			    ]
    local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi
 		        | fn <- varSetElems emitted, 
			  rule <- rulesRules (getIdSpecialisation fn),
			  all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
				-- Spit out a rule only if all its lhs free vars are eemitted
		        ]
\end{code}
223
224
225
226
227
228

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

230
231

\begin{code}			 
232
233
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
234
235
  | null togo_insts = return emptyVarSet		 
  | otherwise 	    = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
236
		      return needed_ids
237
238
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
239
240
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
241
242
				 
    -------			 
243
244
    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ dfun_id2 _ _ _)
245
246
247
248
249
      = 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

    -------			 
250
    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
251
      = let			 
252
253
254
255
256
257
258
259
260
261
		-- 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))
262
	    renumbered_ty = tidyTopType forall_ty
263
	in			 
264
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
265
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
266
267
\end{code}

268
269
270
271
272
273
274

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

275
\begin{code}
276
277
278
279
280
281
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
282
	    -> Bool			-- True <=> recursive, so don't print unfolding
283
284
	    -> Id
	    -> CoreExpr			-- The Id's right hand side
285
	    -> Maybe (SDoc, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
286

287
ifaceId get_idinfo needed_ids is_rec id rhs
288
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
289
	 (isUserExportedId id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
290
291
  = Nothing 		-- Well, that was easy!

292
ifaceId get_idinfo needed_ids is_rec id rhs
293
  = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
294
  where
295
    idinfo         = get_idinfo id
296

297
298
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
299

300
    prag_pretty 
sof's avatar
sof committed
301
     | opt_OmitInterfacePragmas = empty
302
303
304
     | otherwise		= hsep [ptext SLIT("{-##"),
					arity_pretty, 
					caf_pretty,
305
					cpr_pretty,
306
307
					strict_pretty,
					wrkr_pretty,
308
309
					unfold_pretty, 
					ptext SLIT("##-}")]
310
311

    ------------  Arity  --------------
312
    arity_pretty  = ppArityInfo (arityInfo idinfo)
313

314
315
316
    ------------ Caf Info --------------
    caf_pretty = ppCafInfo (cafInfo idinfo)

317
318
319
    ------------ CPR Info --------------
    cpr_pretty = ppCprInfo (cprInfo idinfo)

320
    ------------  Strictness  --------------
321
    strict_info   = strictnessInfo idinfo
322
    bottoming_fn  = isBottomingStrictness strict_info
323
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
324

325
326
327
328
329
    ------------  Worker  --------------
    work_info     = workerInfo idinfo
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
    Just work_id  = work_info
sof's avatar
sof committed
330

331
332

    ------------  Unfolding  --------------
333
334
335
336
337
    inline_pragma  = inlinePragInfo idinfo
    dont_inline	   = case inline_pragma of
			IMustNotBeINLINEd -> True
			IAmALoopBreaker	  -> True
			other		  -> False
338

339
340
    unfold_pretty | show_unfold = ptext SLIT("__u") <+> pprIfaceUnfolding rhs
		  | otherwise   = empty
341

342
343
344
345
346
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
347

348
    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
349
350

    ------------  Specialisations --------------
351
    spec_info   = specInfo idinfo
352
353
    
    ------------  Extra free Ids  --------------
354
355
356
357
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
358

359
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
360
361
362
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
363

364
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
365
366

    unfold_ids | show_unfold = find_fvs rhs
367
	       | otherwise   = emptyVarSet
368

369
    find_fvs expr = exprSomeFreeVars interestingId expr
370

371
372
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
373
374
375
\end{code}

\begin{code}
376
ifaceBinds :: Handle
377
	   -> IdSet		-- These Ids are needed already
378
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
379
	   -> [CoreBind]	-- In dependency order, later depend on earlier
380
	   -> IO IdSet		-- Set of Ids actually spat out
381

382
ifaceBinds hdl needed_ids final_ids binds
383
384
385
  = mapIO (printForIface hdl) (bagToList pretties)	>>
    hPutStr hdl "\n"					>>
    return emitted
386
  where
387
388
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
389
			Just id' -> idInfo id'
390
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
391
				    idInfo id
392

393
394
395
396
397
398
399
400
    (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet 
			-- Reverse so that later things will 
			-- provoke earlier ones to be emitted
    go needed [] pretties emitted
	| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
					  (sep (map ppr (varSetElems needed)))
				       (pretties, emitted)
	| otherwise 		     = (pretties, emitted)
401

402
    go needed (NonRec id rhs : binds) pretties emitted
403
	= case ifaceId get_idinfo needed False id rhs of
404
405
		Nothing		      -> go needed binds pretties emitted
		Just (pretty, extras) -> let
406
407
408
409
410
			needed' = (needed `unionVarSet` extras) `delVarSet` id
			-- 'extras' can include the Id itself via a rule
			emitted' = emitted `extendVarSet` id
			in
			go needed' binds (pretty `consBag` pretties) emitted'
411
412
413
414

	-- 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.
415
416
    go needed (Rec pairs : binds) pretties emitted
	= go needed' binds pretties' emitted' 
417
	where
418
419
420
421
	  (new_pretties, new_emitted, extras) = go_rec needed pairs
	  pretties' = new_pretties `unionBags` pretties
	  needed'   = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
	  emitted'  = emitted `unionVarSet` new_emitted
422

423
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
424
    go_rec needed pairs
425
426
427
428
	| null pretties = (emptyBag, emptyVarSet, emptyVarSet)
	| otherwise	= (more_pretties `unionBags`   listToBag pretties, 
			   more_emitted  `unionVarSet` mkVarSet emitted,
			   more_extras   `unionVarSet` extras)
429
	where
430
431
432
433
434
435
436
437
	  maybes	       = map do_one pairs
	  emitted	       = [id   | ((id,_), Just _)  <- pairs `zip` maybes]
	  reduced_pairs	       = [pair | (pair,   Nothing) <- pairs `zip` maybes]
	  (pretties, extras_s) = unzip (catMaybes maybes)
	  extras	       = unionVarSets extras_s
	  (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs

	  do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
438
439
440
\end{code}


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

454
455
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
456
457
458
459
\end{code}


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

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

487
488
    tyvars = tyConTyVars tycon

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

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

508
509
510
511
    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("=>")

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

514
515
516
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
517
518

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

524
525
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
526

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

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

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

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

562
563
564
565
566
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
567
568
569
570
571
572

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

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

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

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

591
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
592
ppr_unqual_name name = pprOccName (getOccName name)
593
594
\end{code}

595

596
%************************************************************************
597
%*				 					*
598
\subsection{Comparisons}
599
%*				 					*
600
%************************************************************************
601
				 
602

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

607
608
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
609

610
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
611

612
lt_name :: Name -> Name -> Bool
613
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
614

615
616
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
617

618
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
619
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
620

621
sort_versions vs = sortLt lt_vers vs
622

623
624
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
625
626
\end{code}

627

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

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