MkIface.lhs 23.1 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, PredType(..), ClassContext
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
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@.

79
80
81
82
NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file,
so you have to keep it in synch with the code below. Otherwise you'll
lose the happiest years of your life, believe me...  -- SUP

83
\begin{code}
84
startIface  :: Module -> InterfaceDetails
85
	    -> IO (Maybe Handle) -- Nothing <=> don't do an interface
86
87

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

endIface    :: Maybe Handle -> IO ()
97
98
99
\end{code}

\begin{code}
100
startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _)
101
  = case opt_ProduceHi of
102
103
104
      Nothing -> return Nothing ; -- not producing any .hi file

      Just fn -> do 
sof's avatar
sof committed
105
	if_hdl <- openFile fn WriteMode
106
107
108
109
110
111
	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
112
	return (Just if_hdl)
113
114
115
  where
    orphan_indicator | has_orphans = " !"
		     | otherwise   = ""
116
117
118

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

121

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

145
146
147
148
149
150
     null_decls = null binds		&& 
		  null tycons		&&
	          null classes		&& 
	          isEmptyBag inst_infos	&&
		  null orphan_rules	&&
		  null deprecations
151
152
153
\end{code}

\begin{code}
154
ifaceImports :: Handle -> VersionInfo Name -> IO ()
155
156
ifaceImports if_hdl import_usages
  = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
157
  where
158
159
160
    upp_uses (m, mv, has_orphans, whats_imported)
      = hsep [ptext SLIT("import"), pprModuleName m, 
	      int mv, pp_orphan,
161
	      upp_import_versions whats_imported
sof's avatar
sof committed
162
	] <> semi
163
164
165
      where
	pp_orphan | has_orphans = ptext SLIT("!")
		  | otherwise   = empty
166

167
168
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
169

170
171
	-- For imported versions we do print the version number
    upp_import_versions (Specifically nvs)
172
173
      = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]

174
{- SUP: What's this??
175
176
177
178
179
180
181
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
182
    in 
183
    printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
184
    hPutStr if_hdl "\n"
185
-}
186

187
ifaceExports :: Handle -> Avails -> IO ()
188
189
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
190
  = hPutCol if_hdl do_one_module (fmToList export_fm)
191
192
193
194
  where
	-- Sort them into groups by module
    export_fm :: FiniteMap Module [AvailInfo]
    export_fm = foldr insert emptyFM avails
195
196
197

    insert avail efm = addToFM_C (++) efm mod [avail] 
		     where
sof's avatar
sof committed
198
		       mod = nameModule (availName avail)
199
200

	-- Print one module's worth of stuff
sof's avatar
sof committed
201
    do_one_module :: (Module, [AvailInfo]) -> SDoc
sof's avatar
sof committed
202
    do_one_module (mod_name, avails@(avail1:_))
203
	= ptext SLIT("__export ") <>
204
	  hsep [pprModule mod_name,
sof's avatar
sof committed
205
206
207
		hsep (map upp_avail (sortLt lt_avail avails))
	  ] <> semi

208
ifaceFixities :: Handle -> Fixities -> IO ()
209
210
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
211
  = hPutCol if_hdl upp_fixity fixities
212

213
ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO ()
214
215
216
217
ifaceRules if_hdl rules emitted
  | null orphan_rule_pretties && null local_id_pretties
  = return ()
  | otherwise
218
  = printForIface if_hdl (vcat [
219
220
221
222
		ptext SLIT("{-## __R"),
		vcat orphan_rule_pretties,
		vcat local_id_pretties,
		ptext SLIT("##-}")
223
       ])
224
  where
225
    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule
226
227
			    | ProtoCoreRule _ fn rule <- rules
			    ]
228
    local_id_pretties = [ pprCoreRule (Just fn) rule
229
230
231
 		        | fn <- varSetElems emitted, 
			  rule <- rulesRules (getIdSpecialisation fn),
			  all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
232
				-- Spit out a rule only if all its lhs free vars are emitted
233
		        ]
234
235
236
237
238
239
240
241
242
243

ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
ifaceDeprecations if_hdl [] = return ()
ifaceDeprecations if_hdl deprecations
  = printForIface if_hdl (vcat [
		ptext SLIT("{-## __D"),
		vcat [ pprIfaceDeprec d <> semi | d <- deprecations ],
		ptext SLIT("##-}")
       ])
  where
244
245
246
    -- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
    pprIfaceDeprec (Deprecation (IEModuleContents _) txt) =           doubleQuotes (ppr txt)
    pprIfaceDeprec (Deprecation (IEVar            n) txt) = ppr n <+> doubleQuotes (ppr txt)
247
\end{code}
248
249
250
251
252
253

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

255
256

\begin{code}			 
257
258
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
259
260
  | null togo_insts = return emptyVarSet		 
  | otherwise 	    = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
261
		      return needed_ids
262
263
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
264
265
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
266
267
				 
    -------			 
268
269
    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ dfun_id2 _ _ _)
270
271
272
273
274
      = 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

    -------			 
275
    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
276
      = let			 
277
278
279
280
281
282
283
284
285
		-- 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.
286
287
	    forall_ty     = mkSigmaTy tvs (classesToPreds theta)
				      (deNoteType (mkDictTy clas tys))
288
	    renumbered_ty = tidyTopType forall_ty
289
	in			 
290
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
291
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
292
293
\end{code}

294
295
296
297
298
299
300

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

301
\begin{code}
302
303
304
305
306
307
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
308
	    -> Bool			-- True <=> recursive, so don't print unfolding
309
310
	    -> Id
	    -> CoreExpr			-- The Id's right hand side
311
	    -> Maybe (SDoc, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
312

313
ifaceId get_idinfo needed_ids is_rec id rhs
314
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
315
	 (isUserExportedId id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
316
317
  = Nothing 		-- Well, that was easy!

318
ifaceId get_idinfo needed_ids is_rec id rhs
319
320
  = ASSERT2( arity_matches_strictness, ppr id )
    Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
321
  where
322
323
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
324

325
326
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
327

328
    prag_pretty 
sof's avatar
sof committed
329
     | opt_OmitInterfacePragmas = empty
330
331
332
     | otherwise		= hsep [ptext SLIT("{-##"),
					arity_pretty, 
					caf_pretty,
333
					cpr_pretty,
334
335
					strict_pretty,
					wrkr_pretty,
336
337
					unfold_pretty, 
					ptext SLIT("##-}")]
338
339

    ------------  Arity  --------------
340
341
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
342

343
    ------------ Caf Info --------------
344
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
345

346
    ------------ CPR Info --------------
347
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
348

349
    ------------  Strictness  --------------
350
    strict_info   = strictnessInfo core_idinfo
351
    bottoming_fn  = isBottomingStrictness strict_info
352
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
353

354
    ------------  Worker  --------------
355
    work_info     = workerInfo core_idinfo
356
357
358
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
    Just work_id  = work_info
sof's avatar
sof committed
359

360

361
362
363
364
365
    ------------  Occ info  --------------
    loop_breaker  = case occInfo core_idinfo of
			IAmALoopBreaker -> True
			other		-> False

366
    ------------  Unfolding  --------------
367
    inline_pragma  = inlinePragInfo core_idinfo
368
    dont_inline	   = case inline_pragma of
369
370
371
			IMustNotBeINLINEd False Nothing -> True	-- Unconditional NOINLINE
			other		  	        -> False

372

373
    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
374
		  | otherwise   = empty
375

376
377
378
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
379
		  not loop_breaker	 &&
380
381
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
382

383
    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
384
385

    ------------  Specialisations --------------
386
    spec_info   = specInfo core_idinfo
387
388
    
    ------------  Extra free Ids  --------------
389
390
391
392
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
393

394
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
395
396
397
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
398

399
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
400
401

    unfold_ids | show_unfold = find_fvs rhs
402
	       | otherwise   = emptyVarSet
403

404
    find_fvs expr = exprSomeFreeVars interestingId expr
405

406
407
408
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
409
	-- [later: actually all that is necessary is for strictness to exceed arity]
410
411
412
    arity_matches_strictness
	= not has_worker ||
	  case strict_info of
413
	    StrictnessInfo ds _ -> length ds >= arityLowerBound arity_info
414
415
	    other		-> True
    
416
417
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
418
419
420
\end{code}

\begin{code}
421
ifaceBinds :: Handle
422
	   -> IdSet		-- These Ids are needed already
423
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
424
	   -> [CoreBind]	-- In dependency order, later depend on earlier
425
	   -> IO IdSet		-- Set of Ids actually spat out
426

427
ifaceBinds hdl needed_ids final_ids binds
428
429
430
  = mapIO (printForIface hdl) (bagToList pretties)	>>
    hPutStr hdl "\n"					>>
    return emitted
431
  where
432
433
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
434
			Just id' -> idInfo id'
435
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
436
				    idInfo id
437

438
439
440
441
442
443
444
445
    (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)
446

447
    go needed (NonRec id rhs : binds) pretties emitted
448
	= case ifaceId get_idinfo needed False id rhs of
449
450
		Nothing		      -> go needed binds pretties emitted
		Just (pretty, extras) -> let
451
452
453
454
455
			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'
456
457
458
459

	-- 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.
460
461
    go needed (Rec pairs : binds) pretties emitted
	= go needed' binds pretties' emitted' 
462
	where
463
464
465
466
	  (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
467

468
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
469
    go_rec needed pairs
470
471
472
473
	| null pretties = (emptyBag, emptyVarSet, emptyVarSet)
	| otherwise	= (more_pretties `unionBags`   listToBag pretties, 
			   more_emitted  `unionVarSet` mkVarSet emitted,
			   more_extras   `unionVarSet` extras)
474
	where
475
476
477
478
479
480
481
482
	  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
483
484
485
\end{code}


sof's avatar
sof committed
486
487
488
489
490
491
492
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************

\begin{code}
493
ifaceTyCons hdl tycons   = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons))
sof's avatar
sof committed
494
495
496
497
498
ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))

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

499
500
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
501
502
503
504
\end{code}


\begin{code}
505
506
ifaceTyCon :: TyCon -> SDoc
ifaceTyCon tycon
507
508
  | isSynTyCon tycon
  = hsep [ ptext SLIT("type"),
509
510
	   ppr (getName tycon),
	   pprTyVarBndrs tyvars,
511
	   ptext SLIT("="),
512
	   ppr ty,
513
514
	   semi
    ]
sof's avatar
sof committed
515
  where
516
517
    (tyvars, ty) = getSynTyConDefn tycon

518
ifaceTyCon tycon
519
520
  | isAlgTyCon tycon
  = hsep [ ptext keyword,
521
	   ppr_decl_class_context (tyConTheta tycon),
522
523
	   ppr (getName tycon),
	   pprTyVarBndrs (tyConTyVars tycon),
524
525
526
527
528
529
530
	   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
531

532
533
    tyvars = tyConTyVars tycon

sof's avatar
sof committed
534
535
    ppr_con data_con 
	| null field_labels
536
537
538
	= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	  hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
539
540
541
542
		  hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
	        ]

	| otherwise
543
544
	= hsep [  ppr_ex ex_tyvars ex_theta,
		  ppr name,
sof's avatar
sof committed
545
546
547
		  braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
	 	]
          where
548
	   (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
sof's avatar
sof committed
549
550
551
552
           field_labels   = dataConFieldLabels data_con
           strict_marks   = dataConStrictMarks data_con
	   name           = getName            data_con

553
554
    ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
    ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
555
			     <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
556

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

559
560
561
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
562
563

    ppr_field (strict_mark, field_label)
564
	= hsep [ ppr (fieldLabelName field_label),
565
		  dcolon,
566
		  ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
sof's avatar
sof committed
567
568
		]

569
570
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
571

572
ifaceClass clas
sof's avatar
sof committed
573
  = hsep [ptext SLIT("class"),
574
	   ppr_decl_class_context sc_theta,
575
576
	   ppr clas,			-- Print the name
	   pprTyVarBndrs clas_tyvars,
577
	   pprFundeps clas_fds,
sof's avatar
sof committed
578
579
580
581
	   pp_ops,
	   semi
	  ]
   where
582
     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
sof's avatar
sof committed
583

584
585
586
587
     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
588

589
     ppr_classop (sel_id, dm_id, explicit_dm)
590
591
	= ASSERT( sel_tyvars == clas_tyvars)
	  hsep [ppr (getOccName sel_id),
592
		if explicit_dm then equals else empty,
593
	        dcolon,
594
		ppr op_ty
sof's avatar
sof committed
595
596
597
	  ]
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
sof's avatar
sof committed
598

599
ppr_decl_context :: ThetaType -> SDoc
600
601
602
ppr_decl_context []    = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")

603
ppr_decl_class_context :: ClassContext -> SDoc
604
605
606
ppr_decl_class_context []    = empty
ppr_decl_class_context ctxt  = pprIfaceClasses ctxt <+> ptext SLIT(" =>")

607
pprIfaceTheta :: ThetaType -> SDoc	-- Use braces rather than parens in interface files
sof's avatar
sof committed
608
pprIfaceTheta []    = empty
609
pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
610

611
612
613
614
615
616
617
-- ZZ - not sure who uses this - i.e. whether IParams really show up or not
-- (it's not used to print normal value signatures)
pprIfacePred :: PredType -> SDoc
pprIfacePred (Class clas tys) = pprConstraint clas tys
pprIfacePred (IParam n ty)    = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty

pprIfaceClasses :: ClassContext -> SDoc
618
619
pprIfaceClasses []    = empty
pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
620
621
\end{code}

622
623
624
625
626
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
627
628
629
630
631
632

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

633
\begin{code}
634
635
upp_avail :: AvailInfo -> SDoc
upp_avail (Avail name)      = pprOccName (getOccName name)
sof's avatar
sof committed
636
upp_avail (AvailTC name []) = empty
637
upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
638
			    where
sof's avatar
sof committed
639
			      bang | name `elem` ns = empty
sof's avatar
sof committed
640
				   | otherwise	    = char '|'
641
			      ns' = filter (/= name) ns
642

643
upp_export :: [Name] -> SDoc
sof's avatar
sof committed
644
upp_export []    = empty
645
upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
646

647
648
649
upp_fixity :: (Name, Fixity) -> SDoc
upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
	-- Dummy version number!
650

651
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
652
ppr_unqual_name name = pprOccName (getOccName name)
653
654
\end{code}

655

656
%************************************************************************
657
%*				 					*
658
\subsection{Comparisons}
659
%*				 					*
660
%************************************************************************
661
				 
662

663
664
665
The various sorts above simply prevent unnecessary "wobbling" when
things change that don't have to.  We therefore compare lexically, not
by unique
666

667
668
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
669

670
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
671

672
lt_name :: Name -> Name -> Bool
673
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
674

675
676
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
677

678
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
679
lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
680

681
sort_versions vs = sortLt lt_vers vs
682

683
684
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
685
686
\end{code}

687

688
\begin{code}
689
hPutCol :: Handle 
690
	-> (a -> SDoc)
691
692
	-> [a]
	-> IO ()
693
hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
sof's avatar
sof committed
694
695
696
697

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