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

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

9
10
module MkIface (
	startIface, endIface,
11
	ifaceUsages,
12
13
14
15
16
17
18
19
	ifaceVersions,
	ifaceExportList,
	ifaceFixities,
	ifaceInstanceModules,
	ifaceDecls,
	ifaceInstances,
	ifacePragmas
    ) where
20

21
IMP_Ubiq(){-uitous-}
22
IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
23

24
import Bag		( bagToList )
25
import Class		( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
26
import CmdLineOpts	( opt_ProduceHi )
27
import FieldLabel	( FieldLabel{-instance NamedThing-} )
28
import FiniteMap	( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
29
import HsSyn
30
import Id		( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
31
32
33
			  dataConStrictMarks, StrictnessMark(..),
			  GenId{-instance NamedThing/Outputable-}
			)
34
import Maybes		( maybeToBool )
35
import Name		( origName, nameOf, moduleOf,
36
			  exportFlagOn, nameExportFlag, ExportFlag(..),
37
			  isLexSym, isLexCon, isLocallyDefined, isWiredInName,
38
			  RdrName(..){-instance Outputable-},
39
			  OrigName(..){-instance Ord-},
40
			  Name{-instance NamedThing-}
41
			)
42
import ParseUtils	( UsagesMap(..), VersionsMap(..) )
43
import PprEnv		-- not sure how much...
44
import PprStyle		( PprStyle(..) )
45
import PprType		-- most of it (??)
46
--import PrelMods	( modulesWithBuiltins )
47
import PrelInfo		( builtinValNamesMap, builtinTcNamesMap )
48
49
import Pretty		( prettyToUn )
import Unpretty		-- ditto
50
import RnHsSyn		( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
51
import RnUtils		( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} )
52
import TcModule		( SYN_IE(TcIfaceInfo) )
53
import TcInstUtil	( InstInfo(..) )
54
import TyCon		( TyCon(..){-instance NamedThing-}, NewOrData(..) )
55
import Type		( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
56
import Util		( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} )
57

58
59
60
uppSemid   x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
ppr_ty	  ty = prettyToUn (pprType PprInterface ty)
ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
61
ppr_name   n
62
63
  = case (origName "ppr_name" n) of { OrigName m s ->
    uppBesides [uppPStr m, uppChar '.', uppPStr s] }
64
65
66
\end{code}

We have a function @startIface@ to open the output file and put
67
(something like) ``interface Foo'' in it.  It gives back a handle
68
69
70
71
72
73
74
75
76
77
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 ()
78
79
80
81
ifaceUsages
	    :: Maybe Handle
	    -> UsagesMap
	    -> IO ()
82
83
ifaceVersions
	    :: Maybe Handle
84
	    -> VersionsMap
85
86
87
	    -> IO ()
ifaceExportList
	    :: Maybe Handle
88
89
	    -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
	    -> RnEnv
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
	    -> 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 ()
106
107
108
109
ifacePragmas
	    :: Maybe Handle
	    -> IO ()
ifacePragmas = panic "ifacePragmas" -- stub
110
111
112
113
114
115
116
117
\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 ->
118
	hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >>
119
120
121
122
	return (Just if_hdl)

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

125
126
127
\begin{code}
ifaceUsages Nothing{-no iface handle-} _ = return ()

128
129
130
131
ifaceUsages (Just if_hdl) usages
  | null usages_list
  = return ()
  | otherwise
132
133
  = hPutStr if_hdl "\n__usages__\n"   >>
    hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
134
  where
135
    usages_list = fmToList usages -- NO: filter has_no_builtins (...)
136

137
138
139
140
--  has_no_builtins (m, _)
--    = m `notElem` modulesWithBuiltins
--    -- Don't *have* to do this; save gratuitous spillage in
--    -- every interface.  Could be flag-controlled...
141

142
    upp_uses (m, (mv, versions))
143
      = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
144
145
146
	       upp_versions (fmToList versions), uppSemi]

    upp_versions nvs
147
      = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
148
149
\end{code}

150
151
152
153
\begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return ()

ifaceVersions (Just if_hdl) version_info
154
155
156
157
  | null version_list
  = return ()
  | otherwise
  = hPutStr if_hdl "\n__versions__\n"	>>
158
    hPutStr if_hdl (uppShow 0 (upp_versions version_list))
159
160
161
162
    -- NB: when compiling Prelude.hs, this will spew out
    -- stuff for [], (), (,), etc. [i.e., builtins], which
    -- we'd rather it didn't.  The version-mangling in
    -- the driver will ignore them.
163
164
165
  where
    version_list = fmToList version_info

166
    upp_versions nvs
167
      = uppAboves [ uppPStr n | (n,v) <- nvs ]
168
169
170
171
172
173
174
175
\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" >>
176
    hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
177
178
179
180
\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
181
182
183
next...), and print.  We work from the renamer's final ``RnEnv'',
which has all the names we might possibly be interested in.
(Note that the ``module X'' export items can cause a lot of grief.)
184
\begin{code}
185
ifaceExportList Nothing{-no iface handle-} _ _ = return ()
186
187

ifaceExportList (Just if_hdl)
188
189
		(export_fn, (dotdot_vals, dotdot_tcs))
		rn_env@((qual, unqual, tc_qual, tc_unqual), _)
190
  = let
191
	name_flag_pairs :: FiniteMap OrigName ExportFlag
192
	name_flag_pairs
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
	  = foldr (from_wired  True{-val-ish-})
	   (foldr (from_wired  False{-tycon-ish-})
	   (foldr (from_dotdot True{-val-ish-})
	   (foldr (from_dotdot False{-tycon-ish-})
	   (foldr from_val
	   (foldr from_val
	   (foldr from_tc
	   (foldr from_tc emptyFM{-init accum-}
		  (eltsFM tc_unqual))
		  (eltsFM tc_qual))
		  (eltsFM unqual))
		  (eltsFM qual))
		  dotdot_tcs)
		  dotdot_vals)
		  (eltsFM builtinTcNamesMap))
		  (eltsFM builtinValNamesMap)
209

210
	sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
211
212

    in
213
    --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
214
    hPutStr if_hdl "\n__exports__\n" >>
215
    hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
216
  where
217
218
219
220
221
222
223
    from_val rn acc
      | fun_looking rn && exportFlagOn ef = addToFM acc on ef
      | otherwise			  = acc
      where
	ef = export_fn n -- NB: using the export fn!
	n  = getName rn
	on = origName "from_val" n
224

225
226
227
228
229
    -- fun_looking: must avoid class ops and data constructors
    -- and record fieldnames
    fun_looking (RnName    _) = True
    fun_looking (WiredInId i) = not (isDataCon i)
    fun_looking _		  = False
230

231
232
233
234
235
236
237
    from_tc rn acc
      | exportFlagOn ef = addToFM acc on ef
      | otherwise	= acc
      where
	ef = export_fn n -- NB: using the export fn!
	n  = getName rn
	on = origName "from_tc" n
238

239
240
241
242
243
244
245
    from_dotdot is_valish (n,ef) acc
      | is_valish && isLexCon str = acc
      | exportFlagOn ef		  = addToFM acc on ef
      | otherwise		  = acc
      where
	on = origName "from_dotdot" n
	(OrigName _ str) = on
246

247
    from_wired is_val_ish rn acc
248
      | is_val_ish && not (fun_looking rn)
249
250
			= acc -- these things don't cause export-ery
      | exportFlagOn ef = addToFM acc on ef
251
252
      | otherwise       = acc
      where
253
	n  = getName rn
254
	ef = export_fn n
255
	on = origName "from_wired" n
256
257

    --------------
258
    lexical_lt (n1,_) (n2,_) = n1 < n2
259
260

    --------------
261
262
    upp_pair (OrigName m n, ef)
      = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
263
      where
264
265
	upp_export ExportAll = uppPStr SLIT("(..)")
	upp_export ExportAbs = uppNil
266
267
268
269
270
271
\end{code}

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

ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
272
  = let
273
	pp_fixities = foldr go [] fixities
274
    in
275
    if null pp_fixities then
276
277
278
	return ()
    else 
	hPutStr if_hdl "\n__fixities__\n" >>
279
	hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
280
  where
281
282
283
284
285
286
    go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
    go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
    go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix ""  i v) else id) acc

    print_fix suff prec var
      = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
287
288
289
\end{code}

\begin{code}
290
291
non_wired x = not (isWiredInName (getName x)) --ToDo:move?

292
293
294
ifaceDecls Nothing{-no iface handle-} _ = return ()

ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
295
296
297
298
  = ASSERT(all isLocallyDefined vals)
    ASSERT(all isLocallyDefined tycons)
    ASSERT(all isLocallyDefined classes)
    let
299
300
301
302
303
304
305
306
307
	nonwired_classes = filter non_wired classes
	nonwired_tycons  = filter non_wired tycons
	nonwired_vals    = filter non_wired vals

	lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b

	sorted_classes = sortLt lt_lexical nonwired_classes
	sorted_tycons  = sortLt lt_lexical nonwired_tycons
	sorted_vals    = sortLt lt_lexical nonwired_vals
308
    in
309
    if (null sorted_classes && null sorted_tycons && null sorted_vals) then
310
	--  You could have a module with just (re-)exports/instances in it
311
312
	return ()
    else
313
    hPutStr if_hdl "\n__declarations__\n" >>
314
315
316
317
    hPutStr if_hdl (uppShow 0 (uppAboves [
	uppAboves (map ppr_class sorted_classes),
	uppAboves (map ppr_tycon sorted_tycons),
	uppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
318
319
320
321
322
323
\end{code}

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

ifaceInstances (Just if_hdl) (_, _, _, insts)
324
  = let
325
	togo_insts	= filter is_togo_inst (bagToList insts)
326

327
	sorted_insts	= sortLt lt_inst togo_insts
328
    in
329
    if null togo_insts then
330
331
332
	return ()
    else
	hPutStr if_hdl "\n__instances__\n" >>
333
	hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
334
  where
335
    is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
336
337
338
339
340
341
342
343
344
      = from_here -- && ...

    -------
    lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
	    (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
      = let
	    tycon1 = fst (getAppTyCon ty1)
	    tycon2 = fst (getAppTyCon ty2)
	in
345
	case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
346
347
	  LT_ -> True
	  GT_ -> False
348
	  EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
349
350
351

    -------
    pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
352
353
354
355
      = let
	    forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
	    renumbered_ty = initNmbr (nmbrType forall_ty)
	in
356
357
	case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
	uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
358
359
360
361
\end{code}

%************************************************************************
%*									*
362
\subsection{Printing tycons, classes, ...}
363
364
365
366
%*									*
%************************************************************************

\begin{code}
367
ppr_class :: Class -> Unpretty
368
369
370
371
372
373

ppr_class c
  = --pprTrace "ppr_class:" (ppr PprDebug c) $
    case (initNmbr (nmbrClass c)) of { -- renumber it!
      Class _ n tyvar super_classes sdsels ops sels defms insts links ->

374
	uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
375
376
377
378
		ppr_name n, ppr_tyvar tyvar,
		if null ops
		then uppSemi
		else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
379
    }
380
  where
381
    ppr_context :: TyVar -> [Class] -> Unpretty
382

383
384
385
386
    ppr_context tv []   = uppNil
--  ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
    ppr_context tv super_classes
      = uppBesides [uppStr "{{",
387
		    uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
388
		    uppStr "}} =>"]
389

390
    ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
391

392
393
394
    clas_mod = moduleOf (origName "ppr_class" c)

    ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
395
396
397
\end{code}

\begin{code}
398
399
400
ppr_val v ty -- renumber the type first!
  = --pprTrace "ppr_val:" (ppr PprDebug v) $
    pp_sig v (initNmbr (nmbrType ty))
401

402
pp_sig op ty
403
404
405
406
407
  = case (splitForAllTy ty) of { (tvs, rho_ty) ->
    uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }

ppr_forall []  = uppNil
ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
408
409
410
\end{code}

\begin{code}
411
412
413
ppr_tycon tycon
  = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
    ppr_tc (initNmbr (nmbrTyCon tycon))
414

415
------------------------
416
ppr_tc (PrimTyCon _ n _ _)
417
  = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
418

419
ppr_tc FunTyCon
420
  = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
421

422
ppr_tc (TupleTyCon _ n _)
423
  = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
424

425
ppr_tc (SynTyCon _ n _ _ tvs expand)
426
  = let
427
	pp_tyvars   = map ppr_tyvar tvs
428
    in
429
430
    uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
	   uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
431
432

ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
433
434
435
436
  = uppCat [pp_data_or_new,
	   ppr_context ctxt,
	   ppr_name n,
	   uppIntersperse uppSP (map ppr_tyvar tvs),
437
	   uppEquals, pp_condecls,
438
	   uppSemi]
439
	   -- NB: we do not print deriving info in interfaces
440
  where
441
    pp_data_or_new = case data_or_new of
442
443
		      DataType -> uppPStr SLIT("data")
		      NewType  -> uppPStr SLIT("newtype")
444

445
    ppr_context []      = uppNil
446
--  ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
447
    ppr_context cs
448
      = uppBesides[uppStr "{{",
449
		   uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
450
		   uppStr "}}", uppPStr SLIT(" =>")]
451
452

    pp_condecls
453
      = let
454
	    (c:cs) = cons
455
	in
456
	uppCat ((ppr_con c) : (map ppr_next_con cs))
457

458
    ppr_next_con con = uppCat [uppChar '|', ppr_con con]
459

460
461
    ppr_con con
      = let
462
	    con_arg_tys  = dataConRawArgTys   con
463
464
465
	    labels       = dataConFieldLabels con -- none if not a record
	    strict_marks = dataConStrictMarks con
	in
466
	uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
467
468
469

    ppr_fields labels strict_marks con_arg_tys
      = if null labels then -- not a record thingy
470
	    uppIntersperse uppSP (zipWithEqual  "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
471
	else
472
473
474
	    uppCat [ uppChar '{',
	    uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
	    uppChar '}' ]
475
476

    ppr_bang_ty b t
477
478
      = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
		  (prettyToUn (pprParendType PprInterface t))
479
480

    ppr_field l b t
481
      = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
482
		   case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
483
		   ppr_ty t]
484
\end{code}