MkIface.lhs 12 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
module MkIface (
	startIface, endIface,
11
	ifaceUsages,
12
13
14
15
16
17
18
19
	ifaceVersions,
	ifaceExportList,
	ifaceFixities,
	ifaceInstanceModules,
	ifaceDecls,
	ifaceInstances,
	ifacePragmas
    ) where
20
21
22
23

import Ubiq{-uitous-}

import Bag		( emptyBag, snocBag, bagToList )
24
import Class		( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
25
import CmdLineOpts	( opt_ProduceHi )
26
import FieldLabel	( FieldLabel{-instance NamedThing-} )
27
import HsSyn
28
29
30
31
32
import Id		( idType, dataConSig, dataConFieldLabels,
			  dataConStrictMarks, StrictnessMark(..),
			  GenId{-instance NamedThing/Outputable-}
			)
import Name		( nameOrigName, origName, nameOf,
33
			  exportFlagOn, nameExportFlag, ExportFlag(..),
34
35
36
37
			  ltLexical, isExported, getExportFlag,
			  isLexSym, isLocallyDefined,
			  RdrName(..){-instance Outputable-},
			  Name{-instance NamedThing-}
38
			)
39
import ParseUtils	( UsagesMap(..), VersionsMap(..) )
40
import PprEnv		-- not sure how much...
41
import PprStyle		( PprStyle(..) )
42
import PprType		-- most of it (??)
43
44
45
import Pretty		-- quite a bit
import RnHsSyn		( RenamedHsModule(..), RnName{-instance NamedThing-} )
import TcModule		( TcIfaceInfo(..) )
46
import TcInstUtil	( InstInfo(..) )
47
import TyCon		( TyCon(..){-instance NamedThing-}, NewOrData(..) )
48
import Type		( mkSigmaTy, mkDictTy, getAppTyCon )
49
import Util		( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
50

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
ppSemid    x = ppBeside (ppr PprInterface x) ppSemi -- micro util
ppr_ty	  ty = pprType PprInterface ty
ppr_tyvar tv = ppr PprInterface tv
ppr_name   n
  = let
	on = origName n
	s  = nameOf  on
	pp = ppr PprInterface on
    in
    (if isLexSym s then ppParens else id) pp
ppr_unq_name n
  = let
	on = origName n
	s  = nameOf  on
	pp = ppPStr   s
    in
    (if isLexSym s then ppParens else id) pp
68
69
70
71
72
73
74
75
76
77
78
79
80
81
\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 ()
82
83
84
85
ifaceUsages
	    :: Maybe Handle
	    -> UsagesMap
	    -> IO ()
86
87
ifaceVersions
	    :: Maybe Handle
88
	    -> VersionsMap
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
	    -> 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 ()
109
110
111
112
ifacePragmas
	    :: Maybe Handle
	    -> IO ()
ifacePragmas = panic "ifacePragmas" -- stub
113
114
115
116
117
118
119
120
121
122
123
124
125
\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
126
127
\end{code}

128
129
130
131
132
133
134
\begin{code}
ifaceUsages Nothing{-no iface handle-} _ = return ()

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

135
136
137
138
\begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return ()

ifaceVersions (Just if_hdl) version_info
139
  = hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously
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
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
\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)
207
      = ppBeside (ppr_name n) (pp_export ef)
208
209
210
211
212
213
214
215
216
      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 _ _ _ _ _ _ _ _ _)
217
218
219
220
  = let
	local_fixities = filter from_here fixities
    in
    if null local_fixities then
221
222
223
	return ()
    else 
	hPutStr if_hdl "\n__fixities__\n" >>
224
225
226
227
228
	hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities)))
  where
    from_here (InfixL v _) = isLocallyDefined v
    from_here (InfixR v _) = isLocallyDefined v
    from_here (InfixN v _) = isLocallyDefined v
229
230
231
232
233
234
\end{code}

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

ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
235
  = let
236
237
238
239
240
241
242
243
	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
244
245
    ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))

246
247
    hPutStr if_hdl "\n__declarations__\n" >>
    hPutStr if_hdl (ppShow 100 (ppAboves [
248
249
250
	ppAboves (map ppr_class sorted_classes),
	ppAboves (map ppr_tycon sorted_tycons),
	ppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
251
252
253
254
255
256
\end{code}

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

ifaceInstances (Just if_hdl) (_, _, _, insts)
257
258
  = let
	exported_insts	= filter is_exported_inst (bagToList insts)
259

260
	sorted_insts	= sortLt lt_inst exported_insts
261
    in
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
    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 _ _ _ _ _ _ _ _)
285
286
287
288
289
      = let
	    forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
	    renumbered_ty = initNmbr (nmbrType forall_ty)
	in
	ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi]
290
291
292
293
\end{code}

%************************************************************************
%*									*
294
\subsection{Printing tycons, classes, ...}
295
296
297
298
%*									*
%************************************************************************

\begin{code}
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
ppr_class :: Class -> Pretty

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 ->

	ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
		    ppr_name n, ppr_tyvar tyvar,
		    if null ops then ppSemi else ppStr "where {"])
	    (if (null ops)
	     then ppNil
	     else ppAbove (ppNest 2 (ppAboves (map ppr_op ops)))
			  (ppStr "};")
	    )
    }
315
  where
316
    ppr_theta :: TyVar -> [Class] -> Pretty
317

318
319
320
321
322
323
    ppr_theta tv []   = ppNil
    ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>")
    ppr_theta tv super_classes
      = ppBesides [ppLparen,
		   ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes),
		   ppStr ") =>"]
324

325
    ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
326

327
    ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
328
329
330
\end{code}

\begin{code}
331
332
333
ppr_val v ty -- renumber the type first!
  = --pprTrace "ppr_val:" (ppr PprDebug v) $
    pp_sig v (initNmbr (nmbrType ty))
334

335
336
pp_sig op ty
  = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
337
338
339
\end{code}

\begin{code}
340
341
342
ppr_tycon tycon
  = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
    ppr_tc (initNmbr (nmbrTyCon tycon))
343

344
345
346
------------------------
ppr_tc (PrimTyCon _ n _)
  = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
347

348
349
ppr_tc FunTyCon
  = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
350

351
352
ppr_tc (TupleTyCon _ n _)
  = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
353

354
ppr_tc (SynTyCon _ n _ _ tvs expand)
355
  = let
356
	pp_tyvars   = map ppr_tyvar tvs
357
    in
358
359
360
361
362
363
364
365
366
367
368
    ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars,
	   ppPStr SLIT(" = "), ppr_ty expand, ppSemi]

ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
  = ppHang (ppCat [pp_data_or_new,
		   ppr_context ctxt,
		   ppr_name n,
		   ppIntersperse ppSP (map ppr_tyvar tvs)])
	   2
	   (ppBeside pp_unabstract_condecls ppSemi)
	   -- NB: we do not print deriving info in interfaces
369
  where
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
    pp_data_or_new = case data_or_new of
		      DataType -> ppPStr SLIT("data")
		      NewType  -> ppPStr SLIT("newtype")

    ppr_context []      = ppNil
    ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"]
    ppr_context cs
      = ppBesides[ppLparen,
		  ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
		  ppRparen, ppStr " =>"]

    yes_we_print_condecls
      = case (getExportFlag n) of
	  ExportAbs -> False
	  other	    -> True

    pp_unabstract_condecls
      = if yes_we_print_condecls
	then ppCat [ppEquals, pp_condecls]
	else ppNil

    pp_condecls
392
      = let
393
	    (c:cs) = cons
394
	in
395
	ppSep ((ppr_con c) : (map ppr_next_con cs))
396

397
    ppr_next_con con = ppCat [ppChar '|', ppr_con con]
398

399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
    ppr_con con
      = let
	    (_, _, con_arg_tys, _) = dataConSig con
	    labels       = dataConFieldLabels con -- none if not a record
	    strict_marks = dataConStrictMarks con
	in
	ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]

    ppr_fields labels strict_marks con_arg_tys
      = if null labels then -- not a record thingy
	    ppIntersperse ppSP (zipWithEqual  ppr_bang_ty strict_marks con_arg_tys)
	else
	    ppCat [ ppChar '{',
	    ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys),
	    ppChar '}' ]

    ppr_bang_ty b t
      = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil })
		 (pprParendType PprInterface t)

    ppr_field l b t
      = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "),
		   case b of { MarkedStrict -> ppChar '!'; _ -> ppNil },
		   ppr_ty t]
423
\end{code}