MkIface.lhs 11.7 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
18
module MkIface (
	startIface, endIface,
	ifaceVersions,
	ifaceExportList,
	ifaceFixities,
	ifaceInstanceModules,
	ifaceDecls,
	ifaceInstances,
	ifacePragmas
    ) where
19
20
21
22

import Ubiq{-uitous-}

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

50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
\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 ()
104
105
106
107
ifacePragmas
	    :: Maybe Handle
	    -> IO ()
ifacePragmas = panic "ifacePragmas" -- stub
108
109
110
111
112
113
114
115
116
117
118
119
120
\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
121
122
\end{code}

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
181
182
183
184
185
186
187
188
189
190
191
192
193
194
\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)
195
      = ppBeside (ppr_name n) (pp_export ef)
196
197
198
199
200
201
202
203
204
      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 _ _ _ _ _ _ _ _ _)
205
206
207
208
  = let
	local_fixities = filter from_here fixities
    in
    if null local_fixities then
209
210
211
	return ()
    else 
	hPutStr if_hdl "\n__fixities__\n" >>
212
213
214
215
216
	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
217
218
219
220
221
222
\end{code}

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

ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
223
  = let
224
225
226
227
228
229
230
231
	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
232
233
    ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))

234
235
    hPutStr if_hdl "\n__declarations__\n" >>
    hPutStr if_hdl (ppShow 100 (ppAboves [
236
237
238
	ppAboves (map ppr_class sorted_classes),
	ppAboves (map ppr_tycon sorted_tycons),
	ppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
239
240
241
242
243
244
\end{code}

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

ifaceInstances (Just if_hdl) (_, _, _, insts)
245
246
  = let
	exported_insts	= filter is_exported_inst (bagToList insts)
247

248
	sorted_insts	= sortLt lt_inst exported_insts
249
    in
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    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 _ _ _ _ _ _ _ _)
273
274
275
276
277
      = 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]
278
279
280
281
\end{code}

%************************************************************************
%*									*
282
\subsection{Printing tycons, classes, ...}
283
284
285
286
%*									*
%************************************************************************

\begin{code}
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
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 "};")
	    )
    }
303
  where
304
    ppr_theta :: TyVar -> [Class] -> Pretty
305

306
307
308
309
310
311
    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 ") =>"]
312

313
    ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
314

315
    ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
316
317
318
\end{code}

\begin{code}
319
320
321
ppr_val v ty -- renumber the type first!
  = --pprTrace "ppr_val:" (ppr PprDebug v) $
    pp_sig v (initNmbr (nmbrType ty))
322

323
324
pp_sig op ty
  = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
325
326
327
\end{code}

\begin{code}
328
329
330
ppr_tycon tycon
  = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
    ppr_tc (initNmbr (nmbrTyCon tycon))
331

332
333
334
------------------------
ppr_tc (PrimTyCon _ n _)
  = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
335

336
337
ppr_tc FunTyCon
  = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
338

339
340
ppr_tc (TupleTyCon _ n _)
  = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
341

342
ppr_tc (SynTyCon _ n _ _ tvs expand)
343
  = let
344
	pp_tyvars   = map ppr_tyvar tvs
345
    in
346
347
348
349
350
351
352
353
354
355
356
    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
357
  where
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
    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
380
      = let
381
	    (c:cs) = cons
382
	in
383
	ppSep ((ppr_con c) : (map ppr_next_con cs))
384

385
    ppr_next_con con = ppCat [ppChar '|', ppr_con con]
386

387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
    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]
411
\end{code}