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
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
			  idSpecialisation
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, WorkerInfo(..)
37
			)
38
39
import CoreSyn		( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
40
import CoreUnfold	( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
41
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
    upp_uses (m, mv, has_orphans, is_boot, whats_imported)
159
      = hsep [ptext SLIT("import"), pprModuleName m, 
160
	      int mv, pp_orphan, pp_boot,
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
        pp_boot   | is_boot     = ptext SLIT("@")
                  | otherwise   = empty
168

169
170
	-- Importing the whole module is indicated by an empty list
    upp_import_versions Everything = empty
171

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

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

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

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

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

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

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

ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
ifaceDeprecations if_hdl [] = return ()
ifaceDeprecations if_hdl deprecations
  = printForIface if_hdl (vcat [
		ptext SLIT("{-## __D"),
245
		vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ],
246
247
248
		ptext SLIT("##-}")
       ])
  where
249
250
251
252
253
    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
254
\end{code}
255
256
257
258
259
260

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

262
263

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

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

301
302
303
304
305
306
307

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

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

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

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

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

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

    ------------  Arity  --------------
347
348
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
349

350
    ------------ Caf Info --------------
351
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
352

353
    ------------ CPR Info --------------
354
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
355

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

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

367

368
369
370
371
372
    ------------  Occ info  --------------
    loop_breaker  = case occInfo core_idinfo of
			IAmALoopBreaker -> True
			other		-> False

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, theta1, 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}