MkIface.lhs 21 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
31
import IdInfo		( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo,
			  arityInfo, ppArityInfo, arityLowerBound,
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
294
  = ASSERT2( arity_matches_strictness, ppr id )
    Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
295
  where
296
297
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
298

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

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

    ------------  Arity  --------------
314
315
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
316

317
    ------------ Caf Info --------------
318
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
319

320
    ------------ CPR Info --------------
321
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
322

323
    ------------  Strictness  --------------
324
    strict_info   = strictnessInfo core_idinfo
325
    bottoming_fn  = isBottomingStrictness strict_info
326
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
327

328
    ------------  Worker  --------------
329
    work_info     = workerInfo core_idinfo
330
331
332
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
    Just work_id  = work_info
sof's avatar
sof committed
333

334
335

    ------------  Unfolding  --------------
336
    inline_pragma  = inlinePragInfo core_idinfo
337
338
339
340
    dont_inline	   = case inline_pragma of
			IMustNotBeINLINEd -> True
			IAmALoopBreaker	  -> True
			other		  -> False
341

342
    unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs
343
		  | otherwise   = empty
344

345
346
347
348
349
    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
350

351
    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
352
353

    ------------  Specialisations --------------
354
    spec_info   = specInfo core_idinfo
355
356
    
    ------------  Extra free Ids  --------------
357
358
359
360
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
361

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

367
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
368
369

    unfold_ids | show_unfold = find_fvs rhs
370
	       | otherwise   = emptyVarSet
371

372
    find_fvs expr = exprSomeFreeVars interestingId expr
373

374
375
376
377
378
379
380
381
382
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
    arity_matches_strictness
	= not has_worker ||
	  case strict_info of
	    StrictnessInfo ds _ -> length ds == arityLowerBound arity_info
	    other		-> True
    
383
384
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
385
386
387
\end{code}

\begin{code}
388
ifaceBinds :: Handle
389
	   -> IdSet		-- These Ids are needed already
390
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
391
	   -> [CoreBind]	-- In dependency order, later depend on earlier
392
	   -> IO IdSet		-- Set of Ids actually spat out
393

394
ifaceBinds hdl needed_ids final_ids binds
395
396
397
  = mapIO (printForIface hdl) (bagToList pretties)	>>
    hPutStr hdl "\n"					>>
    return emitted
398
  where
399
400
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
401
			Just id' -> idInfo id'
402
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
403
				    idInfo id
404

405
406
407
408
409
410
411
412
    (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)
413

414
    go needed (NonRec id rhs : binds) pretties emitted
415
	= case ifaceId get_idinfo needed False id rhs of
416
417
		Nothing		      -> go needed binds pretties emitted
		Just (pretty, extras) -> let
418
419
420
421
422
			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'
423
424
425
426

	-- 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.
427
428
    go needed (Rec pairs : binds) pretties emitted
	= go needed' binds pretties' emitted' 
429
	where
430
431
432
433
	  (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
434

435
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
436
    go_rec needed pairs
437
438
439
440
	| null pretties = (emptyBag, emptyVarSet, emptyVarSet)
	| otherwise	= (more_pretties `unionBags`   listToBag pretties, 
			   more_emitted  `unionVarSet` mkVarSet emitted,
			   more_extras   `unionVarSet` extras)
441
	where
442
443
444
445
446
447
448
449
	  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
450
451
452
\end{code}


sof's avatar
sof committed
453
454
455
456
457
458
459
460
461
462
463
464
465
%************************************************************************
%*				 					*
\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)

466
467
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
468
469
470
471
\end{code}


\begin{code}
472
473
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
474
475
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
476
477
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
478
	   ptext SLIT("="),
479
	   ppr ty,
480
481
	   semi
    ]
sof's avatar
sof committed
482
  where
483
484
    (tyvars, ty) = getSynTyConDefn tycon

485
ifaceTyCon tycon
486
487
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
488
489
490
	   ppr_decl_context (tyConTheta tycon),
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
491
492
493
494
495
496
497
	   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
498

499
500
    tyvars = tyConTyVars tycon

sof's avatar
sof committed
501
502
    ppr_con data_con 
	| null field_labels
503
504
505
	= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	  hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
506
507
508
509
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
510
511
	= hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
512
513
514
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
515
	   (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
sof's avatar
sof committed
516
517
518
519
           field_labels   = dataConFieldLabels data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

520
521
522
523
    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("=>")

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

526
527
528
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
529
530

    ppr_field (strict_mark, field_label)
531
	= hsep [ ppr (fieldLabelName field_label),
532
		  dcolon,
533
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
534
535
		]

536
537
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
538

539
ifaceClass clas
sof's avatar
sof committed
540
  = hsep [ptext SLIT("class"),
541
542
543
	   ppr_decl_context sc_theta,
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
sof's avatar
sof committed
544
545
546
547
	   pp_ops,
	   semi
	  ]
   where
548
     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
sof's avatar
sof committed
549

sof's avatar
sof committed
550
     pp_ops | null sel_ids  = empty
sof's avatar
sof committed
551
	    | otherwise = hsep [ptext SLIT("where"),
sof's avatar
sof committed
552
				 braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
sof's avatar
sof committed
553
554
			  ]

sof's avatar
sof committed
555
     ppr_classop sel_id maybe_defm
556
557
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
sof's avatar
sof committed
558
		if maybeToBool maybe_defm then equals else empty,
559
	        dcolon,
560
		ppr op_ty
sof's avatar
sof committed
561
562
563
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
564

565
ppr_decl_context :: ThetaType -> SDoc
566
567
568
569
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
570
571
pprIfaceTheta []    = empty
pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
572
573
\end{code}

574
575
576
577
578
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
579
580
581
582
583
584

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

585
\begin{code}
586
587
upp_avail :: AvailInfo -> SDoc
upp_avail (Avail name)      = pprOccName (getOccName name)
sof's avatar
sof committed
588
upp_avail (AvailTC name []) = empty
589
upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
590
			    where
sof's avatar
sof committed
591
			      bang | name `elem` ns = empty
sof's avatar
sof committed
592
				   | otherwise	    = char '|'
593
			      ns' = filter (/= name) ns
594

595
upp_export :: [Name] -> SDoc
sof's avatar
sof committed
596
upp_export []    = empty
597
upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
598

599
600
601
upp_fixity :: (Name, Fixity) -> SDoc
upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
	-- Dummy version number!
602

603
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
604
ppr_unqual_name name = pprOccName (getOccName name)
605
606
\end{code}

607

608
%************************************************************************
609
%*				 					*
610
\subsection{Comparisons}
611
%*				 					*
612
%************************************************************************
613
				 
614

615
616
617
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
618

619
620
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
621

622
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
623

624
lt_name :: Name -> Name -> Bool
625
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
626

627
628
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
629

630
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
631
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
632

633
sort_versions vs = sortLt lt_vers vs
634

635
636
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
637
638
\end{code}

639

640
\begin{code}
641
hPutCol :: Handle 
642
	-> (a -> SDoc)
643
644
	-> [a]
	-> IO ()
645
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
646
647
648
649

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