MkIface.lhs 24.4 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
10
11
12
13
14
15
16
17
module MkIface {-( mkInterface )-} where

import Ubiq{-uitous-}

import Bag		( emptyBag, snocBag, bagToList )
import Class		( GenClass{-instance NamedThing-} )
import CmdLineOpts	( opt_ProduceHi )
import HsSyn
import Id		( GenId{-instance NamedThing/Outputable-} )
18
19
import Name		( nameOrigName, origName,
			  exportFlagOn, nameExportFlag, ExportFlag(..),
20
21
			  ltLexical, isExported,
			  RdrName{-instance Outputable-}
22
			)
23
import PprStyle		( PprStyle(..) )
24
import PprType		( pprType, TyCon{-instance Outputable-}, GenClass{-ditto-} )
25
26
27
28
import Pretty		-- quite a bit
import RnHsSyn		( RenamedHsModule(..), RnName{-instance NamedThing-} )
import RnIfaces		( VersionInfo(..) )
import TcModule		( TcIfaceInfo(..) )
29
import TcInstUtil	( InstInfo(..) )
30
import TyCon		( TyCon{-instance NamedThing-} )
31
import Type		( mkSigmaTy, mkDictTy, getAppTyCon )
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
import Util		( sortLt, assertPanic )

ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
\end{code}

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

\begin{code}
startIface  :: Module
	    -> IO (Maybe Handle) -- Nothing <=> don't do an interface
endIface    :: Maybe Handle -> IO ()
ifaceVersions
	    :: Maybe Handle
	    -> VersionInfo
	    -> IO ()
ifaceExportList
	    :: Maybe Handle
	    -> RenamedHsModule
	    -> IO ()
ifaceFixities
	    :: Maybe Handle
	    -> RenamedHsModule
	    -> IO ()
ifaceInstanceModules
	    :: Maybe Handle
	    -> [Module]
	    -> IO ()
ifaceDecls  :: Maybe Handle
	    -> TcIfaceInfo  -- info produced by typechecker, for interfaces
	    -> IO ()
ifaceInstances
	    :: Maybe Handle
	    -> TcIfaceInfo  -- as above
	    -> IO ()
--ifacePragmas
\end{code}

\begin{code}
startIface mod
  = case opt_ProduceHi of
      Nothing -> return Nothing -- not producing any .hi file
      Just fn ->
	openFile fn WriteMode	>>= \ if_hdl ->
	hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
	return (Just if_hdl)

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

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
\begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return ()

ifaceVersions (Just if_hdl) version_info
  = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously
\end{code}

\begin{code}
ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
ifaceInstanceModules (Just _)		       [] = return ()

ifaceInstanceModules (Just if_hdl) imods
  = hPutStr if_hdl "\n__instance_modules__\n" >>
    hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
\end{code}

Export list: grab the Names of things that are marked Exported, sort
(so the interface file doesn't ``wobble'' from one compilation to the
next...), and print.  Note that the ``module'' now contains all the
imported things that we are dealing with, thus including any entities
that we are re-exporting from somewhere else.
\begin{code}
ifaceExportList Nothing{-no iface handle-} _ = return ()

ifaceExportList (Just if_hdl)
		(HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
  = let
	name_flag_pairs :: Bag (Name, ExportFlag)
	name_flag_pairs
	  = foldr from_ty
	   (foldr from_cls
	   (foldr from_sig
	   (from_binds binds emptyBag{-init accum-})
	     sigs)
	     classdecls)
	     typedecls

	sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)

    in
    hPutStr if_hdl "\n__exports__\n" >>
    hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
  where
    from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
    from_ty (TyNew  _ n _ _ _ _ _) acc = maybe_add acc n
    from_ty (TySynonym n _ _ _)	   acc = maybe_add acc n

    from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n

    from_sig (Sig n _ _ _) acc = maybe_add acc n

    from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)

    --------------
    maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)

    maybe_add acc rn
      | exportFlagOn ef = acc `snocBag` (n, ef)
      | otherwise       = acc
      where
	n  = getName rn
	ef = nameExportFlag n

    --------------
    maybe_add_list acc []     = acc
    maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n

    --------------
    lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2

    --------------
    pp_pair (n, ef)
      = ppBeside (ppr PprInterface (nameOrigName n)) (pp_export ef)
      where
	pp_export ExportAll = ppPStr SLIT("(..)")
	pp_export ExportAbs = ppNil
\end{code}

\begin{code}
ifaceFixities Nothing{-no iface handle-} _ = return ()

ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
  = if null fixities then
	return ()
    else 
	hPutStr if_hdl "\n__fixities__\n" >>
	hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid fixities)))
\end{code}

\begin{code}
ifaceDecls Nothing{-no iface handle-} _ = return ()

ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
181
  = let
182
183
184
185
186
187
188
189
	exported_classes = filter isExported classes
	exported_tycons  = filter isExported tycons
	exported_vals	 = filter isExported vals

	sorted_classes   = sortLt ltLexical exported_classes
	sorted_tycons	 = sortLt ltLexical exported_tycons
	sorted_vals	 = sortLt ltLexical exported_vals
    in
190
191
    ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))

192
193
194
195
196
197
198
199
200
201
202
    hPutStr if_hdl "\n__declarations__\n" >>
    hPutStr if_hdl (ppShow 100 (ppAboves [
	ppAboves (map ppSemid sorted_classes),
	ppAboves (map ppSemid sorted_tycons),
	ppAboves (map ppSemid sorted_vals)]))
\end{code}

\begin{code}
ifaceInstances Nothing{-no iface handle-} _ = return ()

ifaceInstances (Just if_hdl) (_, _, _, insts)
203
204
  = let
	exported_insts	= filter is_exported_inst (bagToList insts)
205

206
	sorted_insts	= sortLt lt_inst exported_insts
207
    in
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    if null exported_insts then
	return ()
    else
	hPutStr if_hdl "\n__instances__\n" >>
	hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts)))
  where
    is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
      = from_here -- && ...

    -------
    lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
	    (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
      = let
	    tycon1 = fst (getAppTyCon ty1)
	    tycon2 = fst (getAppTyCon ty2)
	in
	case (origName clas1 `cmp` origName clas2) of
	  LT_ -> True
	  GT_ -> False
	  EQ_ -> origName tycon1 < origName tycon2

    -------
    pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
      = ppBeside (ppPStr SLIT("instance "))
	    (pprType PprInterface (mkSigmaTy tvs theta (mkDictTy clas ty)))
233
234
235
236
\end{code}

=== ALL OLD BELOW HERE ==============

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
%************************************************************************
%*									*
\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.

257
That's why we actually look at the final \tr{StgBindings} that go
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
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}
279
{- OLD: to the end
280
mkInterface :: FAST_STRING
281
282
283
	    -> (FAST_STRING -> Bool,  -- is something in export list, explicitly?
		FAST_STRING -> Bool)  -- is a module among the "dotdot" exported modules?
	    -> IdEnv UnfoldingDetails
284
	    -> FiniteMap TyCon [(Bool, [Maybe Type])]
285
	    -> ([RenamedFixityDecl],  -- interface info from the typecheck
286
287
288
289
290
		[Id],
		CE,
		TCE,
		Bag InstInfo)
	    -> [StgBinding]
291
292
	    -> Pretty

293
mkInterface modname export_list_fns inline_env tycon_specs
294
295
296
297
298
299
300
	    (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,
301
			   is_exportable_tycon_or_class export_list_fns tc ]
302
303
	exported_classes = [  c |  c <- rngCE  ce,
			   isExported  c,
304
			   is_exportable_tycon_or_class export_list_fns  c ]
305
	exported_inst_infos = [ i | i <- bagToList inst_infos,
306
			   is_exported_inst_info export_list_fns i ]
307
308
309
310
311
312
313
314
315
316
317
318
319
	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)
320
		  (map getMentionedTyConsAndClassesFromClass exported_classes  ++
321
322
323
324
325
		   map getMentionedTyConsAndClassesFromTyCon exported_tycons   ++
		   map getMentionedTyConsAndClassesFromId    exported_vals     ++
		   map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)

	mentionable_classes
326
	  = filter is_mentionable (bagToList mentioned_classes)
327
328
	mentionable_tycons
	  = [ tc | tc <- bagToList mentioned_tycons,
329
		   is_mentionable tc,
330
331
		   not (isPrimTyCon tc) ]

332
333
	nondup_mentioned_tycons  = fst (removeDups cmp mentionable_tycons)
	nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

	-- 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
351
			   then (\ x y -> origName x == origName y)
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
			   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
377
       [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
378
379
	ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],

380
	do_import_decls modname
381
382
383
384
		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.

385
386
387
388
389
	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),
390

391
	ppChar '\n'
392
393
394
395
396
397
398
399
400
401
402
       ]
  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
403
	  = case (maybePurelyLocalType (idType id)) of
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
	      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
436
	:: FAST_STRING
437
438
439
	-> [Id] -> [Class] -> [TyCon]
	-> Pretty

440
do_import_decls mod_name vals classes tycons
441
  = let
442
	-- Conjure up (module, name) pairs for all
443
444
445
	-- the potentially import-decls things:

	vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
446
447
448
	vals_names	= map get_val_pair   vals
	classes_names	= map get_class_pair classes
	tycons_names	= map get_tycon_pair tycons
449

450
	-- sort the (module, name) pairs and chop
451
452
453
454
455
456
457
458
	-- 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
459
460
    lt, same_module :: (FAST_STRING, FAST_STRING)
		    -> (FAST_STRING, FAST_STRING) -> Bool
461

462
463
    lt (m1, ie1, ie2)
      = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
464
465

    same_module (m1, _, _) (m2, _, _) = m1 == m2
466
467

    compiling_the_prelude = opt_CompilingPrelude
468
469
470
471
472
473
474
475
476
477
478
479
480
481

    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,_,_) : _))
482
      |  m == mod_name
483
      || (not compiling_the_prelude &&
484
	  ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN))
485
486
487
      = ppNil

      | otherwise
488
      = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
489
		   ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
490
		   ppRparen
491
492
493
		  ]
      where
	isnt_tycon_ish :: FAST_STRING -> Bool
494
	isnt_tycon_ish str = not (isLexCon str)
495
496
497
498
499
500
501

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

	grab_non_Nothings rns = catMaybes (concat rns)

	pp_str :: FAST_STRING -> Pretty
	pp_str pstr
502
	  = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr
503
504
505
506
507
	  where
	    str = _UNPK_ pstr
\end{code}

\begin{code}
508
509
510
get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
511

512
513
get_val_pair id
  = generic_pair id
514

515
516
get_class_pair clas
  = case (generic_pair clas) of { (orig_mod, orig_nm) ->
517
518
519
520
521
522
    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
523
    (orig_mod, nm_to_print) }
524

525
526
get_tycon_pair tycon
  = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
527
528
529
530
531
532
    let
	nm_to_print = case (getExportFlag tycon) of
			ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
			ExportAbs   -> orig_nm
			NotExported -> orig_nm

533
	cons	    = tyConDataCons tycon
534
    in
535
    (orig_mod, nm_to_print) }
536

537
generic_pair thing
538
  = case (moduleNamePair       thing) of { (orig_mod, orig_nm) ->
539
    case (getOccName thing) of { occur_name ->
540
    (orig_mod, orig_nm) }}
541
542
543
544
545
546
547
548
549
550
\end{code}

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


\begin{code}
551
do_fixity :: -> RenamedFixityDecl -> Pretty
552

553
do_fixity fixity_decl
554
555
556
  = case (isLocallyDefined name, getExportFlag name) of
      (True, ExportAll) -> ppr PprInterface fixity_decl
      _	    	        -> ppNil
557
  where
558
     name = get_name fixity_decl
559
560
561
562
563
564
565
566
567
568
569
570
     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}
571
do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
572

573
574
do_tycon tycon_specs_map tycon
  = pprTyCon PprInterface tycon tycon_specs
575
  where
576
    tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
577
578
579
580
581
582
583
584
585
\end{code}

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

\begin{code}
586
do_value :: (Id -> Id)
587
588
589
590
	 -> IdEnv UnfoldingDetails
	 -> Id
	 -> Pretty

591
do_value better_id_fn inline_env val
592
  = let
593
	sty 	    = PprInterface
594
	better_val  = better_id_fn val
595
	name_str    = getOccName better_val -- NB: not orig name!
596
597
598

	id_info	    = getIdInfo better_val

599
600
601
	val_ty	    = let
			 orig_ty  = idType val
			 final_ty = idType better_val
602
603
604
605
606
607
608
609
610
611
612
613
		      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
614
	  = if opt_OmitInterfacePragmas
615
616
617
	    || boringIdInfo id_info
	    then ppNil
	    else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
618
			ppIdInfo sty better_val True{-yes specs-}
619
620
621
622
			    better_id_fn inline_env id_info,
			ppPStr SLIT("#-}")]
    in
    ppAbove (ppCat [ppr_non_op name_str,
623
		    ppPStr SLIT("::"), pprGenType sty val_ty])
624
625
	    pp_id_info

626
-- sadly duplicates Name.pprNonSym (ToDo)
627
628

ppr_non_op str
629
  = if isLexVarSym str -- NOT NEEDED: || isAconop
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
    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}
648
do_instance :: (Id -> Id)
649
650
651
652
	    -> IdEnv UnfoldingDetails
	    -> InstInfo
	    -> Pretty

653
do_instance better_id_fn inline_env
654
655
    (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
  = let
656
	sty = PprInterface
657
658
659
660
661

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

662
	class_op_strs = map classOpString (classOps clas)
663
664
665
666
667
668
669
670
671
672
673
674
675
676

	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,
677
678
				 ppChar '{' ,
				 ppIdInfo sty constm True{-YES, specs-}
679
				  better_id_fn inline_env
680
681
				  (getIdInfo constm),
				 ppChar '}' ]
682
683
684
685
686
687
688
689
			| (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)

690
	real_stuff
691
692
693
	  = ppCat [ppPStr SLIT("instance"),
		   ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
    in
694
    if opt_OmitInterfacePragmas
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
    || 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}
718
is_exportable_tycon_or_class export_list_fns tc
719
720
721
722
  = if not (fromPreludeCore tc) then
	True
    else
	in_export_list_or_among_dotdot_modules
723
	    opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
724
725
726
	    export_list_fns tc

in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
727
  = if in_export_list (getOccName tc) then
728
729
	True
    else
730
--	pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName  tc))) (
731
732
733
734
735
736
    if ignore_Mdotdots then
	False
    else
	any among_dotdot_modules (getInformingModules tc)
--  )

737
738
is_mentionable tc
  = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
739
740
741
  where
    from_PreludeCore_or_Builtin thing
      = let
742
	    mod_name = fst (moduleNamePair thing)
743
744
745
	in
	mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN

746
is_exported_inst_info export_list_fns
747
748
749
	(InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
  = let
    	seems_exported = instanceIsExported clas ty from_here
750
	(tycon, _, _) = getAppTyCon ty
751
    in
752
    if (opt_OmitReexportedInstances && not from_here) then
753
754
	False -- Flag says to violate Haskell rules, blatantly

755
756
757
    else if not opt_CompilingPrelude
	 || not (isFunTyCon tycon || fromPreludeCore tycon)
	 || not (fromPreludeCore clas) then
758
759
760
761
762
	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
763
	|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
764
765
766
767
768
769
770
771
772
\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 _ _ _ _ _ _ _)
773
  = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
774
775
776
    case [ c | (c, _) <- dfun_theta ]  	    	      of { theta_classes ->
    (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
    }}
777
OLD from the beginning -}
778
\end{code}