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

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

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

259
260

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

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

298
299
300
301
302
303
304

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

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

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

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

329
330
    ty_pretty  = pprType (idType id)
    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
331

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

    ------------  Arity  --------------
344
345
    arity_info    = arityInfo stg_idinfo
    arity_pretty  = ppArityInfo arity_info
346

347
    ------------ Caf Info --------------
348
    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
349

350
    ------------ CPR Info --------------
351
    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
352

353
    ------------  Strictness  --------------
354
    strict_info   = strictnessInfo core_idinfo
355
    bottoming_fn  = isBottomingStrictness strict_info
356
    strict_pretty = ppStrictnessInfo strict_info
sof's avatar
sof committed
357

358
    ------------  Worker  --------------
359
    work_info     = workerInfo core_idinfo
360
361
362
    has_worker    = workerExists work_info
    wrkr_pretty   = ppWorkerInfo work_info
    Just work_id  = work_info
sof's avatar
sof committed
363

364

365
366
367
368
369
    ------------  Occ info  --------------
    loop_breaker  = case occInfo core_idinfo of
			IAmALoopBreaker -> True
			other		-> False

370
    ------------  Unfolding  --------------
371
    inline_pragma  = inlinePragInfo core_idinfo
372
    dont_inline	   = case inline_pragma of
373
374
375
			IMustNotBeINLINEd False Nothing -> True	-- Unconditional NOINLINE
			other		  	        -> False

376

377
    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
378
		  | otherwise   = empty
379

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

387
    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
388
389

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

398
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
399
400
401
			-- Conceivably, the worker might come from
			-- another module
	       | otherwise			   = emptyVarSet
402

403
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
404
405

    unfold_ids | show_unfold = find_fvs rhs
406
	       | otherwise   = emptyVarSet
407

408
    find_fvs expr = exprSomeFreeVars interestingId expr
409

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

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

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

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

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

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

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


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

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

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

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


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

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

536
537
    tyvars = tyConTyVars tycon

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

659

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

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

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

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

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

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

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

685
sort_versions vs = sortLt lt_vers vs
686

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

691

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

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