« back to all changes in this revision
Viewing changes to printer.ml
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Samuel Mimram
- Date: 2006-07-11 12:26:18 UTC
- Revision ID: james.westby@ubuntu.com-20060711122618-dea56bmjs3qlmsd8
Tags: upstream-20060615.dfsg
Import upstream version 20060615.dfsg
- files added:
- demos
- demos/calc
- demos/calc-two
added
removed
printer.ml
1
(**************************************************************************)
2
(* *)
3
(* Menhir *)
4
(* *)
5
(* Fran�ois Pottier and Yann R�gis-Gianas, INRIA Rocquencourt *)
6
(* *)
7
(* Copyright 2005 Institut National de Recherche en Informatique et *)
8
(* en Automatique. All rights reserved. This file is distributed *)
9
(* under the terms of the Q Public License version 1.0, with the *)
10
(* change described in file LICENSE. *)
11
(* *)
12
(**************************************************************************)
13
14
(* A pretty-printer for [IL]. *)
15
16
open IL
17
open Printf
18
19
module Make (X : sig
20
21
(* This is the channel that is being written to. *)
22
23
val f: out_channel
24
25
(* If [raw_stretch_action] is set, then we print the semantic actions
26
as they are found into the original source code. *)
27
val raw_stretch_action: bool
28
29
(* This controls the way we print Objective Caml stretches (types and
30
semantic actions). We either surround them with #line directives
31
(for better error reports if the generated code is ill-typed) or
32
don't (for better readability). The value is either [None] -- do
33
not provide #line directives -- or [Some filename] -- do provide
34
them. [filename] is the name of the file that is being written
35
to. *)
36
37
val locate_stretches: string option
38
39
end) = struct
40
41
(* ------------------------------------------------------------------------- *)
42
(* Dealing with newlines and indentation. *)
43
44
let maxindent =
45
120
46
47
let whitespace =
48
String.make maxindent ' '
49
50
let indentation =
51
ref 0
52
53
let line =
54
ref 1
55
56
(* [rawnl] is, in principle, the only place where writing a newline
57
character to the output channel is permitted. This ensures that the
58
line counter remains correct. But see also [stretch] and [typ0]. *)
59
60
let rawnl f =
61
incr line;
62
output_char f '\n'
63
64
let nl f =
65
rawnl f;
66
output f whitespace 0 !indentation
67
68
let indent ofs producer f x =
69
let old_indentation = !indentation in
70
let new_indentation = old_indentation + ofs in
71
if new_indentation <= maxindent then
72
indentation := new_indentation;
73
nl f;
74
producer f x;
75
indentation := old_indentation
76
77
(* This produces a #line directive. *)
78
79
let sharp f line file =
80
fprintf f "%t# %d \"%s\"%t" rawnl line file rawnl
81
82
(* ------------------------------------------------------------------------- *)
83
(* Printers of atomic elements. *)
84
85
let space f =
86
output_char f ' '
87
88
let comma f =
89
output_string f ", "
90
91
let seminl f =
92
output_char f ';';
93
nl f
94
95
let times f =
96
output_string f " * "
97
98
let letrec f =
99
output_string f "let rec "
100
101
let letnonrec f =
102
output_string f "let "
103
104
let keytyp f =
105
output_string f "type "
106
107
let exc f =
108
output_string f "exception "
109
110
let et f =
111
output_string f "and "
112
113
let var f x =
114
output_string f x
115
116
let bar f =
117
output_string f " | "
118
119
(* ------------------------------------------------------------------------- *)
120
(* List printers. *)
121
122
let rec list elem sep f = function
123
| [] ->
124
()
125
| e :: es ->
126
fprintf f "%t%a%a" sep elem e (list elem sep) es
127
128
let rec typeparams p0 p1 f = function
129
| [] ->
130
()
131
| [ param ] ->
132
fprintf f "%a " p0 param
133
| param :: params ->
134
fprintf f "(%a%a) " p1 param (list p1 comma) params
135
136
(* ------------------------------------------------------------------------- *)
137
(* Expression printer. *)
138
139
(* We use symbolic constants that stand for subsets of the
140
expression constructors. We do not use numeric levels
141
to stand for subsets, because our subsets do not form
142
a linear inclusion chain. *)
143
144
type subset =
145
| All
146
| AllButSeq
147
| AllButFunTryMatch
148
| AllButFunTryMatchSeq
149
| AllButLetFunTryMatch
150
| AllButLetFunTryMatchSeq
151
| AllButIfThen
152
| AllButIfThenSeq
153
| OnlyAppOrAtom
154
| OnlyAtom
155
156
(* This computes the intersection of a subset with the
157
constraint "should not be a sequence". *)
158
159
let andNotSeq = function
160
| All
161
| AllButSeq ->
162
AllButSeq
163
| AllButFunTryMatch
164
| AllButFunTryMatchSeq ->
165
AllButFunTryMatchSeq
166
| AllButLetFunTryMatch
167
| AllButLetFunTryMatchSeq ->
168
AllButLetFunTryMatchSeq
169
| AllButIfThen
170
| AllButIfThenSeq ->
171
AllButIfThenSeq
172
| OnlyAppOrAtom ->
173
OnlyAppOrAtom
174
| OnlyAtom ->
175
OnlyAtom
176
177
(* This defines the semantics of subsets by relating
178
expressions with subsets. *)
179
180
let rec member e k =
181
match e with
182
| EComment _
183
| EPatComment _ ->
184
true
185
| EFun _
186
| ETry _
187
| EMatch _ ->
188
begin
189
match k with
190
| AllButFunTryMatch
191
| AllButFunTryMatchSeq
192
| AllButLetFunTryMatch
193
| AllButLetFunTryMatchSeq
194
| OnlyAppOrAtom
195
| OnlyAtom ->
196
false
197
| _ ->
198
true
199
end
200
| ELet ([], e) ->
201
member e k
202
| ELet ((PUnit, _) :: _, _) ->
203
begin
204
match k with
205
| AllButSeq
206
| AllButFunTryMatchSeq
207
| AllButLetFunTryMatchSeq
208
| AllButIfThenSeq
209
| OnlyAppOrAtom
210
| OnlyAtom ->
211
false
212
| _ ->
213
true
214
end
215
| ELet (_ :: _, _) ->
216
begin
217
match k with
218
| AllButLetFunTryMatch
219
| AllButLetFunTryMatchSeq
220
| OnlyAppOrAtom
221
| OnlyAtom ->
222
false
223
| _ ->
224
true
225
end
226
| EIfThen _ ->
227
begin
228
match k with
229
| AllButIfThen
230
| AllButIfThenSeq
231
| OnlyAppOrAtom
232
| OnlyAtom ->
233
false
234
| _ ->
235
true
236
end
237
| EApp (_, _ :: _)
238
| EData (_, _ :: _)
239
| EMagic _
240
| ERaise _ ->
241
begin
242
match k with
243
| OnlyAtom ->
244
false
245
| _ ->
246
true
247
end
248
| ERecordWrite _
249
| EIfThenElse _ ->
250
begin
251
match k with
252
| OnlyAppOrAtom
253
| OnlyAtom ->
254
false
255
| _ ->
256
true
257
end
258
| EVar _
259
| ETextual _
260
| EApp (_, [])
261
| EData (_, [])
262
| ETuple _
263
| EAnnot _
264
| ERecord _
265
| ERecordAccess (_, _)
266
| EIntConst _
267
| EStringConst _
268
| EUnit ->
269
true
270
271
let rec exprlet k pes f e2 =
272
match pes with
273
| [] ->
274
exprk k f e2
275
| (PUnit, e1) :: pes ->
276
fprintf f "%a%t%a" (exprk AllButLetFunTryMatch) e1 seminl (exprlet k pes) e2
277
| (PVar id1, EAnnot (e1, ts1)) :: pes ->
278
(* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
279
fprintf f "let %s : %a = %a in%t%a" id1 typ ts1.body (* scheme ts1 *) expr e1 nl (exprlet k pes) e2
280
| (PVar id1, EFun (ps1, e1)) :: pes ->
281
fprintf f "let %s%a = %a in%t%t%a" id1 (list pat0 space) ps1 (indent 2 expr) e1 nl nl (exprlet k pes) e2
282
| (p1, (ELet _ as e1)) :: pes ->
283
fprintf f "let %a =%a%tin%t%a" pat p1 (indent 2 expr) e1 nl nl (exprlet k pes) e2
284
| (p1, e1) :: pes ->
285
fprintf f "let %a = %a in%t%a" pat p1 expr e1 nl (exprlet k pes) e2
286
287
and atom f e =
288
exprk OnlyAtom f e
289
290
and app f e =
291
exprk OnlyAppOrAtom f e
292
293
and expr f e =
294
exprk All f e
295
296
and exprk k f e =
297
if member e k then
298
match e with
299
| EComment (c, e) ->
300
if Settings.comment then
301
fprintf f "(* %s *)%t%a" c nl (exprk k) e
302
else
303
exprk k f e
304
| EPatComment (s, p, e) ->
305
if Settings.comment then
306
fprintf f "(* %s%a *)%t%a" s pat p nl (exprk k) e
307
else
308
exprk k f e
309
| ELet (pes, e2) ->
310
exprlet k pes f e2
311
| ERecordWrite (e1, field, e2) ->
312
fprintf f "%a.%s <- %a" atom e1 field (exprk (andNotSeq k)) e2
313
| EMatch (e, []) ->
314
assert false
315
| EMatch (e, brs) ->
316
fprintf f "match %a with%a" expr e (branches k) brs
317
| ETry (_, []) ->
318
assert false
319
| ETry (e, brs) ->
320
fprintf f "try%a%twith%a" (indent 2 expr) e nl (branches k) brs
321
| EIfThen (e1, e2) ->
322
fprintf f "if %a then%a" expr e1 (indent 2 (exprk (andNotSeq k))) e2
323
| EIfThenElse (e0, e1, e2) ->
324
fprintf f "if %a then%a%telse%a"
325
expr e0 (indent 2 (exprk AllButIfThenSeq)) e1 nl (indent 2 (exprk (andNotSeq k))) e2
326
| EFun (ps, e) ->
327
fprintf f "fun%a ->%a" (list pat0 space) ps (indent 2 (exprk k)) e
328
| EApp (EVar op, [ e1; e2 ])
329
when op.[0] = '(' && op.[String.length op - 1] = ')' ->
330
let op = String.sub op 1 (String.length op - 2) in
331
fprintf f "%a %s %a" app e1 op app e2
332
| EApp (e, args) ->
333
fprintf f "%a%a" app e (list atom space) args
334
| ERaise e ->
335
fprintf f "raise %a" atom e
336
| EMagic e ->
337
fprintf f "Obj.magic %a" atom e
338
| EData (d, []) ->
339
var f d
340
| EData (d, [ arg ]) ->
341
fprintf f "%s %a" d atom arg
342
| EData (d, arg :: args) ->
343
fprintf f "%s (%a%a)" d app arg (list app comma) args
344
| EVar v ->
345
var f v
346
| ETextual action ->
347
stretch (X.raw_stretch_action) f action
348
| EUnit ->
349
fprintf f "()"
350
| EIntConst k ->
351
if k >= 0 then
352
fprintf f "%d" k
353
else
354
fprintf f "(%d)" k
355
| EStringConst s ->
356
fprintf f "\"%s\"" (String.escaped s)
357
| ETuple [] ->
358
assert false
359
| ETuple [ e ] ->
360
atom f e
361
| ETuple (e :: es) ->
362
fprintf f "(%a%a)" app e (list app comma) es
363
| EAnnot (e, s) ->
364
(* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
365
fprintf f "(%a : %a)" app e typ s.body (* should be scheme s *)
366
| ERecordAccess (e, field) ->
367
fprintf f "%a.%s" atom e field
368
| ERecord fs ->
369
fprintf f "{%a%t}" (indent 2 fields) fs nl
370
else
371
fprintf f "(%a)" expr e
372
373
and stretch raw f stretch =
374
let content = stretch.Stretch.stretch_content
375
and raw_content = stretch.Stretch.stretch_raw_content in
376
match X.locate_stretches with
377
| Some basename ->
378
sharp f stretch.Stretch.stretch_linenum stretch.Stretch.stretch_filename;
379
output_string f content;
380
line := !line + stretch.Stretch.stretch_linecount;
381
sharp f (!line + 2) basename;
382
output f whitespace 0 !indentation
383
| None ->
384
output_string f (if raw then raw_content else content)
385
386
and branches k f = function
387
| [] ->
388
()
389
| [ br ] ->
390
fprintf f "%t| %a" nl (branch k) br
391
| br :: brs ->
392
fprintf f "%t| %a%a" nl (branch AllButFunTryMatch) br (branches k) brs
393
394
and branch k f br =
395
fprintf f "%a ->%a" pat br.branchpat (indent 4 (exprk k)) br.branchbody
396
397
and fields f = function
398
| [] ->
399
assert false
400
| fl :: fls ->
401
fprintf f "%a%a" field fl (list field seminl) fls
402
403
and field f (label, e) =
404
fprintf f "%s = %a" label app e
405
406
and pat0 f = function
407
| PUnit ->
408
fprintf f "()"
409
| PWildcard ->
410
fprintf f "_"
411
| PVar x ->
412
var f x
413
| PData (d, []) ->
414
var f d
415
| PTuple [] ->
416
assert false
417
| PTuple [ p ] ->
418
pat0 f p
419
| PTuple (p :: ps) ->
420
fprintf f "(%a%a)" pat1 p (list pat1 comma) ps
421
| PAnnot (p, t) ->
422
fprintf f "(%a : %a)" pat p typ t
423
| p ->
424
fprintf f "(%a)" pat p
425
426
and pat1 f = function
427
| PData (d, [ arg ]) ->
428
fprintf f "%s %a" d pat0 arg
429
| PData (d, arg :: args) ->
430
fprintf f "%s (%a%a)" d pat1 arg (list pat1 comma) args
431
| PTuple [ p ] ->
432
pat1 f p
433
| p ->
434
pat0 f p
435
436
and pat2 f = function
437
| POr [] ->
438
assert false
439
| POr (p :: ps) ->
440
fprintf f "%a%a" pat2 p (list pat2 bar) ps
441
| PTuple [ p ] ->
442
pat2 f p
443
| p ->
444
pat1 f p
445
446
and pat f p =
447
pat2 f p
448
449
and typevar f v =
450
fprintf f "'%s" v
451
452
and typ0 f = function
453
| TypTextual (Stretch.Declared ocamltype) ->
454
(* Parentheses are necessary to avoid confusion between 1-ary
455
data constructor with n arguments and n-ary data constructor. *)
456
fprintf f "(%a)" (stretch true) ocamltype
457
| TypTextual (Stretch.Inferred t) ->
458
line := !line + LineCount.count 0 (Lexing.from_string t);
459
fprintf f "(%s)" t
460
| TypVar v ->
461
typevar f v
462
| TypApp (t, params) ->
463
fprintf f "%a%s" (typeparams typ0 typ) params t
464
| t ->
465
fprintf f "(%a)" typ t
466
467
and typ1 f = function
468
| TypTuple [] ->
469
assert false
470
| TypTuple [ t ] ->
471
typ1 f t
472
| TypTuple (t :: ts) ->
473
fprintf f "%a%a" typ0 t (list typ0 times) ts
474
| t ->
475
typ0 f t
476
477
and typ2 f = function
478
| TypArrow (t1, t2) ->
479
fprintf f "%a -> %a" typ1 t1 typ2 t2
480
| t ->
481
typ1 f t
482
483
and typ f =
484
typ2 f
485
486
and scheme f scheme =
487
match scheme.quantifiers with
488
| [] ->
489
typ f scheme.body
490
| qs ->
491
fprintf f "%a. %a" (list typevar space) qs typ scheme.body
492
493
(* ------------------------------------------------------------------------- *)
494
(* Toplevel definition printer. *)
495
496
let datavalparams f = function
497
| [] ->
498
()
499
| valparam :: valparams ->
500
fprintf f " of %a%a" typ valparam (list typ times) valparams
501
502
let datatypeparams f = function
503
| None ->
504
()
505
| Some typs ->
506
fprintf f "(* %a*)" (list typ space) typs (* TEMPORARY not great *)
507
508
let datadef f def =
509
fprintf f " | %s%a%a" def.dataname datavalparams def.datavalparams datatypeparams def.datatypeparams
510
511
let fielddef f def =
512
fprintf f " %s%s: %a"
513
(if def.modifiable then "mutable " else "")
514
def.fieldname
515
scheme def.fieldtype
516
517
let typerhs f = function
518
| TDefRecord [] ->
519
assert false
520
| TDefRecord (field :: fields) ->
521
fprintf f " = {%t%a%a%t}" nl fielddef field (list fielddef seminl) fields nl
522
| TDefSum [] ->
523
()
524
| TDefSum defs ->
525
fprintf f " = %a" (list datadef nl) defs
526
527
let typeconstraint f = function
528
| None ->
529
()
530
| Some (t1, t2) ->
531
fprintf f "%tconstraint %a = %a" nl typ t1 typ t2
532
533
let typedef f def =
534
fprintf f "%a%s%a%a%t%t"
535
(typeparams typevar typevar) def.typeparams
536
def.typename
537
typerhs def.typerhs
538
typeconstraint def.typeconstraint
539
nl nl
540
541
let rec pdefs pdef sep1 sep2 f = function
542
| [] ->
543
()
544
| def :: defs ->
545
fprintf f "%t%a%a" sep1 pdef def (pdefs pdef sep2 sep2) defs
546
547
let valdef f = function
548
| { valpat = PVar id; valval = EAnnot (e, ts) } ->
549
(* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
550
fprintf f "%s : %a =%a%t%t" id typ ts.body (* scheme ts *) (indent 2 expr) e nl nl
551
| { valpat = p; valval = e } ->
552
fprintf f "%a =%a%t%t" pat p (indent 2 expr) e nl nl
553
554
let valdefs =
555
pdefs valdef letrec et
556
557
let nonrecvaldefs =
558
pdefs valdef letnonrec letnonrec
559
560
let typedefs =
561
pdefs typedef keytyp et
562
563
let excdef f def =
564
fprintf f "%s%t%t" def.excname nl nl
565
566
let excdefs =
567
pdefs excdef exc exc
568
569
let functorparams intf body b f params =
570
match params with
571
| [] ->
572
fprintf f "%a%!" body b
573
| _ ->
574
fprintf f "module Make%a%t%s%t%a%t%tend%t%!"
575
(list (stretch false) nl) params
576
nl (if intf then ": sig" else "= struct") nl
577
(indent 2 body) b
578
nl nl nl
579
580
let program f p =
581
List.iter (stretch false f) p.prologue;
582
fprintf f "%a%a%a%a" excdefs p.excdefs typedefs p.typedefs nonrecvaldefs p.nonrecvaldefs valdefs p.valdefs;
583
List.iter (output_string f) p.postlogue
584
585
let valdecl f (x, ts) =
586
fprintf f "val %s: %a" x typ ts.body
587
588
let interface f i =
589
fprintf f "%a%a%a%!" excdefs i.excdecls typedefs i.typedecls (list valdecl nl) i.valdecls
590
591
let program p =
592
functorparams false program p X.f p.paramdefs
593
594
let interface i =
595
functorparams true interface i X.f i.paramdecls
596
597
let expr e =
598
expr X.f e
599
600
end
601
Loggerhead is a web-based interface for Breezy
Version: 2.0.1