MkIface.lhs 23.3 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
18
19
import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), 
			  OccInfo, isLoopBreaker
			)
20
import RnMonad
21
import RnEnv		( availName )
22
23
24
25

import TcInstUtil	( InstInfo(..) )

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

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

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

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

81
82
83
84
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

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

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

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

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

      Just fn -> do 
sof's avatar
sof committed
107
	if_hdl <- openFile fn WriteMode
108
109
	hPutStr		if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod)
	hPutStr		if_hdl (' ' : orphan_indicator)
110
111
112
113
	hPutStrLn	if_hdl " where"
	ifaceExports	if_hdl avails
	ifaceImports	if_hdl import_usages
	ifaceFixities	if_hdl fixities
114
	return (Just if_hdl)
115
116
117
  where
    orphan_indicator | has_orphans = " !"
		     | otherwise   = ""
118
119
120

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

123

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

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

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

171
172
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
173

174
175
	-- For imported versions we do print the version number
    upp_import_versions (Specifically nvs)
176
177
      = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]

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

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

    insert avail efm = addToFM_C (++) efm mod [avail] 
		     where
sof's avatar
sof committed
202
		       mod = nameModule (availName avail)
203
204

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

212
ifaceFixities :: Handle -> Fixities -> IO ()
213
214
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities 
215
  = hPutCol if_hdl upp_fixity fixities
216

217
ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO ()
218
ifaceRules if_hdl rules emitted
219
220
221
  |  opt_OmitInterfacePragmas 	-- Don't emit rules if we are suppressing
				-- interface pragmas
  || (null orphan_rule_pretties && null local_id_pretties)
222
223
  = return ()
  | otherwise
224
  = printForIface if_hdl (vcat [
225
226
227
228
		ptext SLIT("{-## __R"),
		vcat orphan_rule_pretties,
		vcat local_id_pretties,
		ptext SLIT("##-}")
229
       ])
230
  where
231
    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule
232
233
			    | ProtoCoreRule _ fn rule <- rules
			    ]
234
    local_id_pretties = [ pprCoreRule (Just fn) rule
235
 		        | fn <- varSetElems emitted, 
236
			  rule <- rulesRules (idSpecialisation fn),
237
			  all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
238
				-- Spit out a rule only if all its lhs free vars are emitted
239
				-- This is a good reason not to do it when we emit the Id itself
240
		        ]
241
242
243
244
245
246

ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
ifaceDeprecations if_hdl [] = return ()
ifaceDeprecations if_hdl deprecations
  = printForIface if_hdl (vcat [
		ptext SLIT("{-## __D"),
247
		vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ],
248
249
250
		ptext SLIT("##-}")
       ])
  where
251
252
253
254
255
    pprIE (IEVar            n   ) = ppr n
    pprIE (IEThingAbs       n   ) = ppr n
    pprIE (IEThingAll       n   ) = hcat [ppr n, text "(..)"]
    pprIE (IEThingWith      n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns)))
    pprIE (IEModuleContents _   ) = empty
256
\end{code}
257
258
259
260
261
262

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

264
265

\begin{code}			 
266
267
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet		-- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
268
269
  | null togo_insts = return emptyVarSet		 
  | otherwise 	    = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
270
		      return needed_ids
271
272
  where				 
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
273
274
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
275
276
				 
    -------			 
277
278
    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
	    (InstInfo _ _ _ _ dfun_id2 _ _ _)
279
280
281
282
283
      = 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

    -------			 
284
    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
285
      = let			 
286
287
288
289
290
291
292
293
294
		-- 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.
295
296
	    forall_ty     = mkSigmaTy tvs (classesToPreds theta)
				      (deNoteType (mkDictTy clas tys))
297
	    renumbered_ty = tidyTopType forall_ty
298
	in			 
299
	hcat [ptext SLIT("instance "), pprType renumbered_ty, 
sof's avatar
sof committed
300
		    ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
301
302
\end{code}

303
304
305
306
307
308
309

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

310
\begin{code}
311
312
313
314
315
316
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
317
	    -> Bool			-- True <=> recursive, so don't print unfolding
318
319
	    -> Id
	    -> CoreExpr			-- The Id's right hand side
320
	    -> Maybe (SDoc, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
321

322
ifaceId get_idinfo needed_ids is_rec id rhs
323
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
324
	 (isUserExportedId id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
325
326
  = Nothing 		-- Well, that was easy!

327
ifaceId get_idinfo needed_ids is_rec id rhs
328
329
  = ASSERT2( arity_matches_strictness, ppr id )
    Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
330
  where
331
332
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
333

334
335
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
336

337
    prag_pretty 
sof's avatar
sof committed
338
     | opt_OmitInterfacePragmas = empty
339
340
341
     | otherwise		= hsep [ptext SLIT("{-##"),
					arity_pretty, 
					caf_pretty,
342
					cpr_pretty,
343
344
					strict_pretty,
					wrkr_pretty,
345
346
					unfold_pretty, 
					ptext SLIT("##-}")]
347
348

    ------------  Arity  --------------
349
350
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
351

352
    ------------ Caf Info --------------
353
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
354

355
    ------------ CPR Info --------------
356
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
357

358
    ------------  Strictness  --------------
359
    strict_info   = strictnessInfo core_idinfo
360
    bottoming_fn  = isBottomingStrictness strict_info
361
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
362

363
    ------------  Worker  --------------
364
    work_info     = workerInfo core_idinfo
365
366
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
367
    HasWorker work_id wrap_arity = work_info
sof's avatar
sof committed
368

369

370
    ------------  Occ info  --------------
371
    loop_breaker  = isLoopBreaker (occInfo core_idinfo)
372

373
    ------------  Unfolding  --------------
374
    inline_pragma  = inlinePragInfo core_idinfo
375
    dont_inline	   = case inline_pragma of
376
377
378
			IMustNotBeINLINEd False Nothing -> True	-- Unconditional NOINLINE
			other		  	        -> False

379

380
    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
381
		  | otherwise   = empty
382

383
384
385
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
386
		  not loop_breaker	 &&
387
388
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
389

390
    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
391
392

    ------------  Specialisations --------------
393
    spec_info   = specInfo core_idinfo
394
395
    
    ------------  Extra free Ids  --------------
396
397
398
399
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
400

401
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
402
403
404
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
405

406
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
407
408

    unfold_ids | show_unfold = find_fvs rhs
409
	       | otherwise   = emptyVarSet
410

411
    find_fvs expr = exprSomeFreeVars interestingId expr
412

413
414
415
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
416
417
    arity_matches_strictness = not has_worker || 
			       wrap_arity == arityLowerBound arity_info
418
    
419
420
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
421
422
423
\end{code}

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

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

441
442
443
444
445
446
447
448
    (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)
449

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

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

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


sof's avatar
sof committed
489
490
491
492
493
494
495
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************

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

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

502
503
upp_tycon tycon = ifaceTyCon tycon
upp_class clas  = ifaceClass clas
sof's avatar
sof committed
504
505
506
507
\end{code}


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

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

535
536
    tyvars = tyConTyVars tycon

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

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

556
557
    ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
    ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
558
			     <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
559

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

562
563
564
    ppr_strict_mark NotMarkedStrict        = empty
    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
sof's avatar
sof committed
565
566

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

572
573
ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)
574

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

587
588
589
590
     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
591

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

602
ppr_decl_context :: ThetaType -> SDoc
603
604
605
ppr_decl_context []    = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")

606
ppr_decl_class_context :: ClassContext -> SDoc
607
608
609
ppr_decl_class_context []    = empty
ppr_decl_class_context ctxt  = pprIfaceClasses ctxt <+> ptext SLIT(" =>")

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

614
615
616
617
618
619
620
-- 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
621
622
pprIfaceClasses []    = empty
pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
sof's avatar
sof committed
623
624
\end{code}

625
626
627
628
629
%************************************************************************
%*				 					*
\subsection{Random small things}
%*				 					*
%************************************************************************
630
631
632
633
634
635

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

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

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

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

654
ppr_unqual_name :: NamedThing a => a -> SDoc		-- Just its occurrence name
655
ppr_unqual_name name = pprOccName (getOccName name)
656
657
\end{code}

658

659
%************************************************************************
660
%*				 					*
661
\subsection{Comparisons}
662
%*				 					*
663
%************************************************************************
664
				 
665

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

670
671
\begin{code}
lt_avail :: AvailInfo -> AvailInfo -> Bool
672

673
a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
674

675
lt_name :: Name -> Name -> Bool
676
n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
677

678
679
lt_lexical :: NamedThing a => a -> a -> Bool
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
680

681
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
682
lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2
683

684
sort_versions vs = sortLt lt_vers vs
685

686
687
lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
688
689
\end{code}

690

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

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