MkIface.lhs 18.1 KB
Newer Older
1
2
3
4
5
6
7
8
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
%
\section[MkIface]{Print an interface for a module}

\begin{code}
#include "HsVersions.h"

9
module MkIface ( mkInterface ) where
10

11
import PrelInfo		( mkLiftTy, pRELUDE_BUILTIN )
12
import HsSyn		( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
13
14
			  RenamedMonoBinds(..), Name, RenamedPat(..), Sig
			)
15
import Type
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
import Bag
import FiniteMap
import Id
import IdInfo		-- plenty from here
import Maybes		( catMaybes, Maybe(..) )
import Outputable
import Pretty
import StgSyn
import TcInstDcls	( InstInfo(..) )
import Util
\end{code}

%************************************************************************
%*									*
\subsection[main-MkIface]{Main routine for making interfaces}
%*									*
%************************************************************************

Misc points:
\begin{enumerate}
\item
We get the general what-to-export information from the ``environments''
produced by the typechecker (the \tr{[RenamedFixityDecl]} through
\tr{Bag InstInfo} arguments).

\item
{\em However:} Whereas (for example) an \tr{InstInfo} will have
\tr{Ids} in it that identify the constant methods for that instance,
those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
Those @IdInfos@ were figured out long after the \tr{InstInfo} was
created.

48
That's why we actually look at the final \tr{StgBindings} that go
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
into the code-generator: they have the best @IdInfos@ on them.
Whenever, we are about to print info about an @Id@, we look in the
Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
with presumably-better @IdInfo@.

\item
We play this same game whether for values, classes (for their
method-selectors and default-methods), or instances (for their
@DictFunIds@ or constant-methods).

Of course, for imported things, what we got from the typechecker is
all we're gonna get.

\item
We {\em sort} things in the interface into some ``canonical'' order;
otherwise, with heavily-recursive modules, you can have (unchanged)
information ``move around'' in the interface file---deeply unfriendly
to \tr{make}.
\end{enumerate}

\begin{code}
70
mkInterface :: FAST_STRING
71
72
73
	    -> (FAST_STRING -> Bool,  -- is something in export list, explicitly?
		FAST_STRING -> Bool)  -- is a module among the "dotdot" exported modules?
	    -> IdEnv UnfoldingDetails
74
	    -> FiniteMap TyCon [(Bool, [Maybe Type])]
75
	    -> ([RenamedFixityDecl],  -- interface info from the typecheck
76
77
78
79
80
		[Id],
		CE,
		TCE,
		Bag InstInfo)
	    -> [StgBinding]
81
82
	    -> Pretty

83
mkInterface modname export_list_fns inline_env tycon_specs
84
85
86
87
88
89
90
	    (fixity_decls, global_ids, ce, tce, inst_infos)
	    stg_binds
  = let
	-- first, gather up the things we want to export:

	exported_tycons  = [ tc | tc <- rngTCE tce,
			   isExported tc,
91
			   is_exportable_tycon_or_class export_list_fns tc ]
92
93
	exported_classes = [  c |  c <- rngCE  ce,
			   isExported  c,
94
			   is_exportable_tycon_or_class export_list_fns  c ]
95
	exported_inst_infos = [ i | i <- bagToList inst_infos,
96
			   is_exported_inst_info export_list_fns i ]
97
98
99
100
101
102
103
104
105
106
107
108
109
	exported_vals
    	  = [ v | v <- global_ids,
	      isExported v && not (isDataCon v) && not (isClassOpId v) ]

	-- We also have to worry about TyCons/Classes that are
	-- *mentioned* in exported things (e.g., values' types or
	-- instances), so that we can be sure to do an import decl for
	-- them, for original-naming purposes:

	(mentioned_tycons, mentioned_classes)
	  = foldr ( \ (tcs1, cls1) (tcs2, cls2)
		      -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
		  (emptyBag, emptyBag)
110
		  (map getMentionedTyConsAndClassesFromClass exported_classes  ++
111
112
113
114
115
		   map getMentionedTyConsAndClassesFromTyCon exported_tycons   ++
		   map getMentionedTyConsAndClassesFromId    exported_vals     ++
		   map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)

	mentionable_classes
116
	  = filter is_mentionable (bagToList mentioned_classes)
117
118
	mentionable_tycons
	  = [ tc | tc <- bagToList mentioned_tycons,
119
		   is_mentionable tc,
120
121
		   not (isPrimTyCon tc) ]

122
123
	nondup_mentioned_tycons  = fst (removeDups cmp mentionable_tycons)
	nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

	-- Next: as discussed in the notes, we want the top-level
	-- Ids straight from the final STG code, so we can use
	-- their IdInfos to print pragmas; we slurp them out here,
	-- then pass them to the printing functions, which may
	-- use them.

	better_ids = collectExportedStgBinders stg_binds

	-- Make a lookup function for convenient access:

	better_id_fn i
	  = if not (isLocallyDefined i)
	    then i  -- can't be among our "better_ids"
	    else
	       let
		   eq_fn = if isTopLevId i -- can't trust uniqs
141
			   then (\ x y -> origName x == origName y)
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
			   else eqId
	       in
	       case [ x | x <- better_ids, x `eq_fn` i ] of
		 []  -> pprPanic "better_id_fn:" (ppr PprShowAll i)
			i
		 [x] -> x
		 _   -> panic "better_id_fn"

	-- Finally, we sort everything lexically, so that we always
	-- get the same interface from the same information:

	sorted_mentioned_tycons  = sortLt ltLexical nondup_mentioned_tycons
	sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes

	sorted_tycons     = sortLt ltLexical exported_tycons
	sorted_classes    = sortLt ltLexical exported_classes
	sorted_vals       = sortLt ltLexical exported_vals
	sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
    in
    if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
	-- this will be less of a HACK when we teach
	-- mkInterface to do I/O (WDP 94/10)
	error "Can't produce interface file because of errors!\n"
    else
    ppAboves
167
       [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
168
169
	ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],

170
	do_import_decls modname
171
172
173
174
		sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
		-- Mustn't give the data constructors to do_import_decls,
		-- because they aren't explicitly imported; their tycon is.

175
176
177
178
179
	ppAboves (map do_fixity					fixity_decls),
	ppAboves (map (pprIfaceClass better_id_fn inline_env)	sorted_classes),
	ppAboves (map (do_tycon      tycon_specs)		sorted_tycons),
	ppAboves (map (do_value      better_id_fn inline_env)   sorted_vals),
	ppAboves (map (do_instance   better_id_fn inline_env)   sorted_inst_infos),
180

181
	ppChar '\n'
182
183
184
185
186
187
188
189
190
191
192
       ]
  where
    any_purely_local tycons classes vals
      =  any bad_tc tycons || any bad_cl classes || any bad_id vals
      where
	bad_cl cl
	  = case (maybePurelyLocalClass cl) of
	      Nothing -> False
	      Just xs -> naughty_trace cl xs

	bad_id id
193
	  = case (maybePurelyLocalType (idType id)) of
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
	      Nothing -> False
	      Just xs -> naughty_trace id xs

	bad_tc tc
	  = case (maybePurelyLocalTyCon tc) of
	      Nothing -> False
	      Just xs -> if exported_abs then False else naughty_trace tc xs
	  where
	    exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }

	naughty_trace x things
	  = pprTrace "Can't export -- `"
		(ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
			ppInterleave pp'SP things])
		True
\end{code}

%************************************************************************
%*									*
\subsection[imports-MkIface]{Generating `import' declarations in an interface}
%*									*
%************************************************************************

We gather up lots of (module, name) pairs for which we might print an
import declaration.  We sort them, for the usual canonicalisation
reasons.  NB: We {\em assume} the lists passed in don't have duplicates in
them!  expect).

All rather horribly turgid (WDP).

\begin{code}
do_import_decls
226
	:: FAST_STRING
227
228
229
	-> [Id] -> [Class] -> [TyCon]
	-> Pretty

230
do_import_decls mod_name vals classes tycons
231
  = let
232
	-- Conjure up (module, name) pairs for all
233
234
235
	-- the potentially import-decls things:

	vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
236
237
238
	vals_names	= map get_val_pair   vals
	classes_names	= map get_class_pair classes
	tycons_names	= map get_tycon_pair tycons
239

240
	-- sort the (module, name) pairs and chop
241
242
243
244
245
246
247
248
	-- them into per-module groups:

	ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)

	per_module_groups = runs same_module ie_list
    in
    ppAboves (map print_a_decl per_module_groups)
  where
249
250
    lt, same_module :: (FAST_STRING, FAST_STRING)
		    -> (FAST_STRING, FAST_STRING) -> Bool
251

252
253
    lt (m1, ie1, ie2)
      = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
254
255

    same_module (m1, _, _) (m2, _, _) = m1 == m2
256
257

    compiling_the_prelude = opt_CompilingPrelude
258
259
260
261
262
263
264
265
266
267
268
269
270
271

    print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
    {-
	Obviously, if the module in question is this one,
	don't print an import declaration.

	If it's a Prelude* module, we don't print the TyCons/
	Classes, because the compiler supposedly knows about
	them already (and they are PreludeCore things anyway).

	But if we are compiling a Prelude module, then we
	try to do it as "normally" as possible.
    -}
    print_a_decl (ielist@((m,_,_) : _))
272
      |  m == mod_name
273
      || (not compiling_the_prelude &&
274
	  ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN))
275
276
277
      = ppNil

      | otherwise
278
      = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
279
		   ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
280
		   ppRparen
281
282
283
		  ]
      where
	isnt_tycon_ish :: FAST_STRING -> Bool
284
	isnt_tycon_ish str = not (isLexCon str)
285
286
287
288
289
290
291

	grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]

	grab_non_Nothings rns = catMaybes (concat rns)

	pp_str :: FAST_STRING -> Pretty
	pp_str pstr
292
	  = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr
293
294
295
296
297
	  where
	    str = _UNPK_ pstr
\end{code}

\begin{code}
298
299
300
get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
301

302
303
get_val_pair id
  = generic_pair id
304

305
306
get_class_pair clas
  = case (generic_pair clas) of { (orig_mod, orig_nm) ->
307
308
309
310
311
312
    let
	nm_to_print = case (getExportFlag clas) of
			ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
			ExportAbs   -> orig_nm
			NotExported -> orig_nm
    in
313
    (orig_mod, nm_to_print) }
314

315
316
get_tycon_pair tycon
  = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
317
318
319
320
321
322
    let
	nm_to_print = case (getExportFlag tycon) of
			ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
			ExportAbs   -> orig_nm
			NotExported -> orig_nm

323
	cons	    = tyConDataCons tycon
324
    in
325
    (orig_mod, nm_to_print) }
326

327
generic_pair thing
328
  = case (moduleNamePair       thing) of { (orig_mod, orig_nm) ->
329
    case (getOccName thing) of { occur_name ->
330
    (orig_mod, orig_nm) }}
331
332
333
334
335
336
337
338
339
340
\end{code}

%************************************************************************
%*									*
\subsection[fixities-MkIface]{Generating fixity declarations in an interface}
%*									*
%************************************************************************


\begin{code}
341
do_fixity :: -> RenamedFixityDecl -> Pretty
342

343
do_fixity fixity_decl
344
345
346
  = case (isLocallyDefined name, getExportFlag name) of
      (True, ExportAll) -> ppr PprInterface fixity_decl
      _	    	        -> ppNil
347
  where
348
     name = get_name fixity_decl
349
350
351
352
353
354
355
356
357
358
359
360
     get_name (InfixL n _) = n
     get_name (InfixR n _) = n
     get_name (InfixN n _) = n
\end{code}

%************************************************************************
%*									*
\subsection[tycons-MkIface]{Generating tycon declarations in an interface}
%*									*
%************************************************************************

\begin{code}
361
do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
362

363
364
do_tycon tycon_specs_map tycon
  = pprTyCon PprInterface tycon tycon_specs
365
  where
366
    tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
367
368
369
370
371
372
373
374
375
\end{code}

%************************************************************************
%*									*
\subsection[values-MkIface]{Generating a value's signature in an interface}
%*									*
%************************************************************************

\begin{code}
376
do_value :: (Id -> Id)
377
378
379
380
	 -> IdEnv UnfoldingDetails
	 -> Id
	 -> Pretty

381
do_value better_id_fn inline_env val
382
  = let
383
	sty 	    = PprInterface
384
	better_val  = better_id_fn val
385
	name_str    = getOccName better_val -- NB: not orig name!
386
387
388

	id_info	    = getIdInfo better_val

389
390
391
	val_ty	    = let
			 orig_ty  = idType val
			 final_ty = idType better_val
392
393
394
395
396
397
398
399
400
401
402
403
		      in
--		      ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
		      ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
		      orig_ty

	-- Note: We export the type of the original val
	-- The type of an unboxed val will have been *lifted* by the desugarer
	-- In this case we export an unlifted type, but id_info which assumes
	--   a lifted Id i.e. extracted from better_val (above)
	-- The importing module must lift the Id before using the imported id_info

	pp_id_info
404
	  = if opt_OmitInterfacePragmas
405
406
407
	    || boringIdInfo id_info
	    then ppNil
	    else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
408
			ppIdInfo sty better_val True{-yes specs-}
409
410
411
412
			    better_id_fn inline_env id_info,
			ppPStr SLIT("#-}")]
    in
    ppAbove (ppCat [ppr_non_op name_str,
413
		    ppPStr SLIT("::"), pprGenType sty val_ty])
414
415
	    pp_id_info

416
-- sadly duplicates Name.pprNonSym (ToDo)
417
418

ppr_non_op str
419
  = if isLexVarSym str -- NOT NEEDED: || isAconop
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
    then ppBesides [ppLparen, ppPStr str, ppRparen]
    else ppPStr str
\end{code}

%************************************************************************
%*									*
\subsection[instances-MkIface]{Generating instance declarations in an interface}
%*									*
%************************************************************************

The types of ``dictionary functions'' (dfuns) have just the required
info for instance declarations in interfaces.  However, the dfuns that
GHC really uses have {\em extra} dictionaries passed to them (for
efficiency).  When we print interfaces, we want to omit that
dictionary information.  (It can be reconsituted on the other end,
from instance and class decls).

\begin{code}
438
do_instance :: (Id -> Id)
439
440
441
442
	    -> IdEnv UnfoldingDetails
	    -> InstInfo
	    -> Pretty

443
do_instance better_id_fn inline_env
444
445
    (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
  = let
446
	sty = PprInterface
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466

	better_dfun 	 = better_id_fn dfun_id
	better_dfun_info = getIdInfo better_dfun
	better_constms	 = map better_id_fn constm_ids

	class_op_strs = map getClassOpString (getClassOps clas)

	pragma_begin
	  = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
		   ppIdInfo sty better_dfun False{-NO specs-}
		    better_id_fn inline_env better_dfun_info]

    	pragma_end = ppPStr SLIT("#-}")

	pp_modname = if _NULL_ modname
		     then ppNil
		     else ppCat [ppStr "_M_", ppPStr modname]

	name_pragma_pairs
	  = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
467
468
				 ppChar '{' ,
				 ppIdInfo sty constm True{-YES, specs-}
469
				  better_id_fn inline_env
470
471
				  (getIdInfo constm),
				 ppChar '}' ]
472
473
474
475
476
477
478
479
			| (op, constm) <- class_op_strs `zip` better_constms ]

#ifdef DEBUG
	pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
#endif
	pp_the_list [p]    = p
	pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)

480
	real_stuff
481
482
483
	  = ppCat [ppPStr SLIT("instance"),
		   ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
    in
484
    if opt_OmitInterfacePragmas
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
    || boringIdInfo better_dfun_info
    then real_stuff
    else ppAbove real_stuff
	  ({-ppNest 8 -} -- ppNest does nothing
	     if null better_constms
	     then ppCat [pragma_begin, pragma_end]
	     else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
	  )
\end{code}

%************************************************************************
%*									*
\subsection[utils-InstInfos]{Utility functions for @InstInfos@}
%*									*
%************************************************************************

ToDo: perhaps move.

Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
``completely'' known---they don't need to be mentioned in interfaces.
Classes usually don't need to be mentioned in interfaces, but if we're
compiling the prelude, then we treat them without special favours.
\begin{code}
508
is_exportable_tycon_or_class export_list_fns tc
509
510
511
512
  = if not (fromPreludeCore tc) then
	True
    else
	in_export_list_or_among_dotdot_modules
513
	    opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
514
515
516
	    export_list_fns tc

in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
517
  = if in_export_list (getOccName tc) then
518
519
	True
    else
520
--	pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName  tc))) (
521
522
523
524
525
526
    if ignore_Mdotdots then
	False
    else
	any among_dotdot_modules (getInformingModules tc)
--  )

527
528
is_mentionable tc
  = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
529
530
531
  where
    from_PreludeCore_or_Builtin thing
      = let
532
	    mod_name = fst (moduleNamePair thing)
533
534
535
	in
	mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN

536
is_exported_inst_info export_list_fns
537
538
539
	(InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
  = let
    	seems_exported = instanceIsExported clas ty from_here
540
	(tycon, _, _) = getAppTyCon ty
541
    in
542
    if (opt_OmitReexportedInstances && not from_here) then
543
544
	False -- Flag says to violate Haskell rules, blatantly

545
546
547
    else if not opt_CompilingPrelude
	 || not (isFunTyCon tycon || fromPreludeCore tycon)
	 || not (fromPreludeCore clas) then
548
549
550
551
552
	seems_exported -- take what we got

    else -- compiling Prelude & tycon/class are Prelude things...
	from_here
	|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
553
	|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
554
555
556
557
558
559
560
561
562
\end{code}

\begin{code}
lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
  = ltLexical dfun1 dfun2
\end{code}

\begin{code}
getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
563
  = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
564
565
566
567
    case [ c | (c, _) <- dfun_theta ]  	    	      of { theta_classes ->
    (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
    }}
\end{code}