MkIface.lhs 21.8 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
35
			  cprInfo, ppCprInfo, pprInlinePragInfo,
			  occInfo, OccInfo(..),
36
			  workerExists, workerInfo, ppWorkerInfo
37
			)
38
39
40
41
import CoreSyn		( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold	( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline )
import Module		( moduleString, pprModule, pprModuleName )
42
import Name		( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
43
			  Name, NamedThing(..)
44
			)
sof's avatar
sof committed
45
import OccName		( OccName, pprOccName )
46
47
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
			  tyConTheta, tyConTyVars, tyConDataCons
48
			)
49
import Class		( Class, classExtraBigSig )
50
import FieldLabel	( fieldLabelName, fieldLabelType )
51
52
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
			  deNoteType, classesToPreds,
53
			  Type, ThetaType
sof's avatar
sof committed
54
		        )
55
56

import PprType
57
import PprCore		( pprIfaceUnfolding, pprCoreRule )
58
import FunDeps		( pprFundeps )
59
import Rules		( pprProtoCoreRule, ProtoCoreRule(..) )
60

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

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

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

endIface    :: Maybe Handle -> IO ()
92
93
94
\end{code}

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

      Just fn -> do 
sof's avatar
sof committed
100
	if_hdl <- openFile fn WriteMode
101
102
103
104
105
106
	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
107
	return (Just if_hdl)
108
109
110
  where
    orphan_indicator | has_orphans = " !"
		     | otherwise   = ""
111
112
113

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

116

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

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

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

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

161
162
	-- For imported versions we do print the version number
    upp_import_versions (Specifically nvs)
163
164
165
166
167
168
169
170
171
      = 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
172
    in 
173
    printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
174
    hPutStr if_hdl "\n"
175

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

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

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

196
197
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
198
  = hPutCol if_hdl upp_fixity fixities
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215

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
216
    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule
217
218
			    | ProtoCoreRule _ fn rule <- rules
			    ]
219
    local_id_pretties = [ pprCoreRule (Just fn) rule
220
221
222
223
224
225
 		        | 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}
226
227
228
229
230
231

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

233
234

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

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

272
273
274
275
276
277
278

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

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

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

296
ifaceId get_idinfo needed_ids is_rec id rhs
297
298
  = ASSERT2( arity_matches_strictness, ppr id )
    Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
299
  where
300
301
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
302

303
304
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
305

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

    ------------  Arity  --------------
318
319
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
320

321
    ------------ Caf Info --------------
322
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
323

324
    ------------ CPR Info --------------
325
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
326

327
    ------------  Strictness  --------------
328
    strict_info   = strictnessInfo core_idinfo
329
    bottoming_fn  = isBottomingStrictness strict_info
330
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
331

332
    ------------  Worker  --------------
333
    work_info     = workerInfo core_idinfo
334
335
336
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
    Just work_id  = work_info
sof's avatar
sof committed
337

338

339
340
341
342
343
    ------------  Occ info  --------------
    loop_breaker  = case occInfo core_idinfo of
			IAmALoopBreaker -> True
			other		-> False

344
    ------------  Unfolding  --------------
345
    inline_pragma  = inlinePragInfo core_idinfo
346
    dont_inline	   = case inline_pragma of
347
348
349
			IMustNotBeINLINEd False Nothing -> True	-- Unconditional NOINLINE
			other		  	        -> False

350

351
    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
352
		  | otherwise   = empty
353

354
355
356
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
357
		  not loop_breaker	 &&
358
359
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
360

361
    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
362
363

    ------------  Specialisations --------------
364
    spec_info   = specInfo core_idinfo
365
366
    
    ------------  Extra free Ids  --------------
367
368
369
370
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
371

372
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
373
374
375
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
376

377
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
378
379

    unfold_ids | show_unfold = find_fvs rhs
380
	       | otherwise   = emptyVarSet
381

382
    find_fvs expr = exprSomeFreeVars interestingId expr
383

384
385
386
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
387
	-- [later: actually all that is necessary is for strictness to exceed arity]
388
389
390
    arity_matches_strictness
	= not has_worker ||
	  case strict_info of
391
	    StrictnessInfo ds _ -> length ds >= arityLowerBound arity_info
392
393
	    other		-> True
    
394
395
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
396
397
398
\end{code}

\begin{code}
399
ifaceBinds :: Handle
400
	   -> IdSet		-- These Ids are needed already
401
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
402
	   -> [CoreBind]	-- In dependency order, later depend on earlier
403
	   -> IO IdSet		-- Set of Ids actually spat out
404

405
ifaceBinds hdl needed_ids final_ids binds
406
407
408
  = mapIO (printForIface hdl) (bagToList pretties)	>>
    hPutStr hdl "\n"					>>
    return emitted
409
  where
410
411
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
412
			Just id' -> idInfo id'
413
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
414
				    idInfo id
415

416
417
418
419
420
421
422
423
    (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)
424

425
    go needed (NonRec id rhs : binds) pretties emitted
426
	= case ifaceId get_idinfo needed False id rhs of
427
428
		Nothing		      -> go needed binds pretties emitted
		Just (pretty, extras) -> let
429
430
431
432
433
			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'
434
435
436
437

	-- 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.
438
439
    go needed (Rec pairs : binds) pretties emitted
	= go needed' binds pretties' emitted' 
440
	where
441
442
443
444
	  (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
445

446
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
447
    go_rec needed pairs
448
449
450
451
	| null pretties = (emptyBag, emptyVarSet, emptyVarSet)
	| otherwise	= (more_pretties `unionBags`   listToBag pretties, 
			   more_emitted  `unionVarSet` mkVarSet emitted,
			   more_extras   `unionVarSet` extras)
452
	where
453
454
455
456
457
458
459
460
	  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
461
462
463
\end{code}


sof's avatar
sof committed
464
465
466
467
468
469
470
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************

\begin{code}
471
ifaceTyCons hdl tycons   = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons))
sof's avatar
sof committed
472
473
474
475
476
ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))

for_iface_name name = isLocallyDefined name && 
		      not (isWiredInName name)

477
478
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
479
480
481
482
\end{code}


\begin{code}
483
484
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
485
486
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
487
488
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
489
	   ptext SLIT("="),
490
	   ppr ty,
491
492
	   semi
    ]
sof's avatar
sof committed
493
  where
494
495
    (tyvars, ty) = getSynTyConDefn tycon

496
ifaceTyCon tycon
497
498
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
499
	   ppr_decl_class_context (tyConTheta tycon),
500
501
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
502
503
504
505
506
507
508
	   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
509

510
511
    tyvars = tyConTyVars tycon

sof's avatar
sof committed
512
513
    ppr_con data_con 
	| null field_labels
514
515
516
	= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	  hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
517
518
519
520
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
521
522
	= hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
523
524
525
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
526
	   (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
sof's avatar
sof committed
527
528
529
530
           field_labels   = dataConFieldLabels data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

531
532
    ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
    ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
533
			     <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
534

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

537
538
539
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
540
541

    ppr_field (strict_mark, field_label)
542
	= hsep [ ppr (fieldLabelName field_label),
543
		  dcolon,
544
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
545
546
		]

547
548
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
549

550
ifaceClass clas
sof's avatar
sof committed
551
  = hsep [ptext SLIT("class"),
552
	   ppr_decl_class_context sc_theta,
553
554
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
555
	   pprFundeps clas_fds,
sof's avatar
sof committed
556
557
558
559
	   pp_ops,
	   semi
	  ]
   where
560
     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
sof's avatar
sof committed
561

562
563
564
565
     pp_ops | null op_stuff  = empty
	    | otherwise      = hsep [ptext SLIT("where"),
				     braces (hsep (punctuate semi (map ppr_classop op_stuff)))
			       ]
sof's avatar
sof committed
566

567
     ppr_classop (sel_id, dm_id, explicit_dm)
568
569
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
570
		if explicit_dm then equals else empty,
571
	        dcolon,
572
		ppr op_ty
sof's avatar
sof committed
573
574
575
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
576

577
ppr_decl_context :: ThetaType -> SDoc
578
579
580
ppr_decl_context []    = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")

581
582
583
584
ppr_decl_class_context :: [(Class,[Type])] -> SDoc
ppr_decl_class_context []    = empty
ppr_decl_class_context ctxt  = pprIfaceClasses ctxt <+> ptext SLIT(" =>")

585
pprIfaceTheta :: ThetaType -> SDoc	-- Use braces rather than parens in interface files
sof's avatar
sof committed
586
pprIfaceTheta []    = empty
587
588
589
590
591
pprIfaceTheta theta = braces (hsep (punctuate comma [pprPred p | p <- theta]))

pprIfaceClasses :: [(Class,[Type])] -> SDoc
pprIfaceClasses []    = empty
pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
592
593
\end{code}

594
595
596
597
598
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
599
600
601
602
603
604

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

605
\begin{code}
606
607
upp_avail :: AvailInfo -> SDoc
upp_avail (Avail name)      = pprOccName (getOccName name)
sof's avatar
sof committed
608
upp_avail (AvailTC name []) = empty
609
upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
610
			    where
sof's avatar
sof committed
611
			      bang | name `elem` ns = empty
sof's avatar
sof committed
612
				   | otherwise	    = char '|'
613
			      ns' = filter (/= name) ns
614

615
upp_export :: [Name] -> SDoc
sof's avatar
sof committed
616
upp_export []    = empty
617
upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
618

619
620
621
upp_fixity :: (Name, Fixity) -> SDoc
upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
	-- Dummy version number!
622

623
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
624
ppr_unqual_name name = pprOccName (getOccName name)
625
626
\end{code}

627

628
%************************************************************************
629
%*				 					*
630
\subsection{Comparisons}
631
%*				 					*
632
%************************************************************************
633
				 
634

635
636
637
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
638

639
640
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
641

642
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
643

644
lt_name :: Name -> Name -> Bool
645
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
646

647
648
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
649

650
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
651
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
652

653
sort_versions vs = sortLt lt_vers vs
654

655
656
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
657
658
\end{code}

659

660
\begin{code}
661
hPutCol :: Handle 
662
	-> (a -> SDoc)
663
664
	-> [a]
	-> IO ()
665
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
666
667
668
669

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