1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Damien Doligez, projet Para, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1999 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Asttypes;;
17 open Format;;
18 open Lexing;;
19 open Location;;
20 open Parsetree;;
21
22 let fmt_position with_name f l =
23 let fname = if with_name then l.pos_fname else "" in
24 if l.pos_lnum = -1
25 then fprintf f "%s[%d]" fname l.pos_cnum
26 else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
27 (l.pos_cnum - l.pos_bol)
28 ;;
29
30 let fmt_location f loc =
31 let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
32 fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
33 (fmt_position p_2nd_name) loc.loc_end;
34 if loc.loc_ghost then fprintf f " ghost";
35 ;;
36
37 let rec fmt_longident_aux f x =
38 match x with
39 | Longident.Lident (s) -> fprintf f "%s" s;
40 | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
41 | Longident.Lapply (y, z) ->
42 fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
43 ;;
44
45 let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
46
47 let fmt_longident_loc f (x : Longident.t loc) =
48 fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
49 ;;
50
51 let fmt_string_loc f (x : string loc) =
52 fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
53 ;;
54
55 let fmt_str_opt_loc f (x : string option loc) =
56 fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
57 ;;
58
59 let fmt_char_option f = function
60 | None -> fprintf f "None"
61 | Some c -> fprintf f "Some %c" c
62
63 let fmt_constant f x =
64 match x with
65 | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
66 | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
67 | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s;
68 | Pconst_string (s, Some delim) ->
69 fprintf f "PConst_string (%S,Some %S)" s delim;
70 | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
71 ;;
72
73 let fmt_mutable_flag f x =
74 match x with
75 | Immutable -> fprintf f "Immutable";
76 | Mutable -> fprintf f "Mutable";
77 ;;
78
79 let fmt_virtual_flag f x =
80 match x with
81 | Virtual -> fprintf f "Virtual";
82 | Concrete -> fprintf f "Concrete";
83 ;;
84
85 let fmt_override_flag f x =
86 match x with
87 | Override -> fprintf f "Override";
88 | Fresh -> fprintf f "Fresh";
89 ;;
90
91 let fmt_closed_flag f x =
92 match x with
93 | Closed -> fprintf f "Closed"
94 | Open -> fprintf f "Open"
95
96 let fmt_rec_flag f x =
97 match x with
98 | Nonrecursive -> fprintf f "Nonrec";
99 | Recursive -> fprintf f "Rec";
100 ;;
101
102 let fmt_direction_flag f x =
103 match x with
104 | Upto -> fprintf f "Up";
105 | Downto -> fprintf f "Down";
106 ;;
107
108 let fmt_private_flag f x =
109 match x with
110 | Public -> fprintf f "Public";
111 | Private -> fprintf f "Private";
112 ;;
113
114 let line i f s (*...*) =
115 fprintf f "%s" (String.make ((2*i) mod 72) ' ');
116 fprintf f s (*...*)
117 ;;
118
119 let list i f ppf l =
120 match l with
121 | [] -> line i ppf "[]\n";
122 | _ :: _ ->
123 line i ppf "[\n";
124 List.iter (f (i+1) ppf) l;
125 line i ppf "]\n";
126 ;;
127
128 let option i f ppf x =
129 match x with
130 | None -> line i ppf "None\n";
131 | Some x ->
132 line i ppf "Some\n";
133 f (i+1) ppf x;
134 ;;
135
136 let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
137 let string i ppf s = line i ppf "\"%s\"\n" s;;
138 let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
139 let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
140 let arg_label i ppf = function
141 | Nolabel -> line i ppf "Nolabel\n"
142 | Optional s -> line i ppf "Optional \"%s\"\n" s
143 | Labelled s -> line i ppf "Labelled \"%s\"\n" s
144 ;;
145
146 let rec core_type i ppf x =
147 line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
148 attributes i ppf x.ptyp_attributes;
149 let i = i+1 in
150 match x.ptyp_desc with
151 | Ptyp_any -> line i ppf "Ptyp_any\n";
152 | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
153 | Ptyp_arrow (l, ct1, ct2) ->
154 line i ppf "Ptyp_arrow\n";
155 arg_label i ppf l;
156 core_type i ppf ct1;
157 core_type i ppf ct2;
158 | Ptyp_tuple l ->
159 line i ppf "Ptyp_tuple\n";
160 list i core_type ppf l;
161 | Ptyp_constr (li, l) ->
162 line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
163 list i core_type ppf l;
164 | Ptyp_variant (l, closed, low) ->
165 line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed;
166 list i label_x_bool_x_core_type_list ppf l;
167 option i (fun i -> list i string) ppf low
168 | Ptyp_object (l, c) ->
169 line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
170 let i = i + 1 in
171 List.iter (fun field ->
172 match field.pof_desc with
173 | Otag (l, t) ->
174 line i ppf "method %s\n" l.txt;
175 attributes i ppf field.pof_attributes;
176 core_type (i + 1) ppf t
177 | Oinherit ct ->
178 line i ppf "Oinherit\n";
179 core_type (i + 1) ppf ct
180 ) l
181 | Ptyp_class (li, l) ->
182 line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
183 list i core_type ppf l
184 | Ptyp_alias (ct, s) ->
185 line i ppf "Ptyp_alias \"%s\"\n" s;
186 core_type i ppf ct;
187 | Ptyp_poly (sl, ct) ->
188 line i ppf "Ptyp_poly%a\n"
189 (fun ppf ->
190 List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt)
191 )
192 sl;
193 core_type i ppf ct;
194 | Ptyp_package (s, l) ->
195 line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
196 list i package_with ppf l;
197 | Ptyp_extension (s, arg) ->
198 line i ppf "Ptyp_extension \"%s\"\n" s.txt;
199 payload i ppf arg
200
201 and package_with i ppf (s, t) =
202 line i ppf "with type %a\n" fmt_longident_loc s;
203 core_type i ppf t
204
205 and pattern i ppf x =
206 line i ppf "pattern %a\n" fmt_location x.ppat_loc;
207 attributes i ppf x.ppat_attributes;
208 let i = i+1 in
209 match x.ppat_desc with
210 | Ppat_any -> line i ppf "Ppat_any\n";
211 | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
212 | Ppat_alias (p, s) ->
213 line i ppf "Ppat_alias %a\n" fmt_string_loc s;
214 pattern i ppf p;
215 | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
216 | Ppat_interval (c1, c2) ->
217 line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2;
218 | Ppat_tuple (l) ->
219 line i ppf "Ppat_tuple\n";
220 list i pattern ppf l;
221 | Ppat_construct (li, po) ->
222 line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
223 option i pattern ppf po;
224 | Ppat_variant (l, po) ->
225 line i ppf "Ppat_variant \"%s\"\n" l;
226 option i pattern ppf po;
227 | Ppat_record (l, c) ->
228 line i ppf "Ppat_record %a\n" fmt_closed_flag c;
229 list i longident_x_pattern ppf l;
230 | Ppat_array (l) ->
231 line i ppf "Ppat_array\n";
232 list i pattern ppf l;
233 | Ppat_or (p1, p2) ->
234 line i ppf "Ppat_or\n";
235 pattern i ppf p1;
236 pattern i ppf p2;
237 | Ppat_lazy p ->
238 line i ppf "Ppat_lazy\n";
239 pattern i ppf p;
240 | Ppat_constraint (p, ct) ->
241 line i ppf "Ppat_constraint\n";
242 pattern i ppf p;
243 core_type i ppf ct;
244 | Ppat_type (li) ->
245 line i ppf "Ppat_type\n";
246 longident_loc i ppf li
247 | Ppat_unpack s ->
248 line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
249 | Ppat_exception p ->
250 line i ppf "Ppat_exception\n";
251 pattern i ppf p
252 | Ppat_open (m,p) ->
253 line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
254 pattern i ppf p
255 | Ppat_extension (s, arg) ->
256 line i ppf "Ppat_extension \"%s\"\n" s.txt;
257 payload i ppf arg
258
259 and expression i ppf x =
260 line i ppf "expression %a\n" fmt_location x.pexp_loc;
261 attributes i ppf x.pexp_attributes;
262 let i = i+1 in
263 match x.pexp_desc with
264 | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
265 | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
266 | Pexp_let (rf, l, e) ->
267 line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
268 list i value_binding ppf l;
269 expression i ppf e;
270 | Pexp_function l ->
271 line i ppf "Pexp_function\n";
272 list i case ppf l;
273 | Pexp_fun (l, eo, p, e) ->
274 line i ppf "Pexp_fun\n";
275 arg_label i ppf l;
276 option i expression ppf eo;
277 pattern i ppf p;
278 expression i ppf e;
279 | Pexp_apply (e, l) ->
280 line i ppf "Pexp_apply\n";
281 expression i ppf e;
282 list i label_x_expression ppf l;
283 | Pexp_match (e, l) ->
284 line i ppf "Pexp_match\n";
285 expression i ppf e;
286 list i case ppf l;
287 | Pexp_try (e, l) ->
288 line i ppf "Pexp_try\n";
289 expression i ppf e;
290 list i case ppf l;
291 | Pexp_tuple (l) ->
292 line i ppf "Pexp_tuple\n";
293 list i expression ppf l;
294 | Pexp_construct (li, eo) ->
295 line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
296 option i expression ppf eo;
297 | Pexp_variant (l, eo) ->
298 line i ppf "Pexp_variant \"%s\"\n" l;
299 option i expression ppf eo;
300 | Pexp_record (l, eo) ->
301 line i ppf "Pexp_record\n";
302 list i longident_x_expression ppf l;
303 option i expression ppf eo;
304 | Pexp_field (e, li) ->
305 line i ppf "Pexp_field\n";
306 expression i ppf e;
307 longident_loc i ppf li;
308 | Pexp_setfield (e1, li, e2) ->
309 line i ppf "Pexp_setfield\n";
310 expression i ppf e1;
311 longident_loc i ppf li;
312 expression i ppf e2;
313 | Pexp_array (l) ->
314 line i ppf "Pexp_array\n";
315 list i expression ppf l;
316 | Pexp_ifthenelse (e1, e2, eo) ->
317 line i ppf "Pexp_ifthenelse\n";
318 expression i ppf e1;
319 expression i ppf e2;
320 option i expression ppf eo;
321 | Pexp_sequence (e1, e2) ->
322 line i ppf "Pexp_sequence\n";
323 expression i ppf e1;
324 expression i ppf e2;
325 | Pexp_while (e1, e2) ->
326 line i ppf "Pexp_while\n";
327 expression i ppf e1;
328 expression i ppf e2;
329 | Pexp_for (p, e1, e2, df, e3) ->
330 line i ppf "Pexp_for %a\n" fmt_direction_flag df;
331 pattern i ppf p;
332 expression i ppf e1;
333 expression i ppf e2;
334 expression i ppf e3;
335 | Pexp_constraint (e, ct) ->
336 line i ppf "Pexp_constraint\n";
337 expression i ppf e;
338 core_type i ppf ct;
339 | Pexp_coerce (e, cto1, cto2) ->
340 line i ppf "Pexp_coerce\n";
341 expression i ppf e;
342 option i core_type ppf cto1;
343 core_type i ppf cto2;
344 | Pexp_send (e, s) ->
345 line i ppf "Pexp_send \"%s\"\n" s.txt;
346 expression i ppf e;
347 | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
348 | Pexp_setinstvar (s, e) ->
349 line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
350 expression i ppf e;
351 | Pexp_override (l) ->
352 line i ppf "Pexp_override\n";
353 list i string_x_expression ppf l;
354 | Pexp_letmodule (s, me, e) ->
355 line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
356 module_expr i ppf me;
357 expression i ppf e;
358 | Pexp_letexception (cd, e) ->
359 line i ppf "Pexp_letexception\n";
360 extension_constructor i ppf cd;
361 expression i ppf e;
362 | Pexp_assert (e) ->
363 line i ppf "Pexp_assert\n";
364 expression i ppf e;
365 | Pexp_lazy (e) ->
366 line i ppf "Pexp_lazy\n";
367 expression i ppf e;
368 | Pexp_poly (e, cto) ->
369 line i ppf "Pexp_poly\n";
370 expression i ppf e;
371 option i core_type ppf cto;
372 | Pexp_object s ->
373 line i ppf "Pexp_object\n";
374 class_structure i ppf s
375 | Pexp_newtype (s, e) ->
376 line i ppf "Pexp_newtype \"%s\"\n" s.txt;
377 expression i ppf e
378 | Pexp_pack me ->
379 line i ppf "Pexp_pack\n";
380 module_expr i ppf me
381 | Pexp_open (o, e) ->
382 line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override;
383 module_expr i ppf o.popen_expr;
384 expression i ppf e
385 | Pexp_letop {let_; ands; body} ->
386 line i ppf "Pexp_letop\n";
387 binding_op i ppf let_;
388 list i binding_op ppf ands;
389 expression i ppf body
390 | Pexp_extension (s, arg) ->
391 line i ppf "Pexp_extension \"%s\"\n" s.txt;
392 payload i ppf arg
393 | Pexp_unreachable ->
394 line i ppf "Pexp_unreachable"
395
396 and value_description i ppf x =
397 line i ppf "value_description %a %a\n" fmt_string_loc
398 x.pval_name fmt_location x.pval_loc;
399 attributes i ppf x.pval_attributes;
400 core_type (i+1) ppf x.pval_type;
401 list (i+1) string ppf x.pval_prim
402
403 and type_parameter i ppf (x, _variance) = core_type i ppf x
404
405 and type_declaration i ppf x =
406 line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name
407 fmt_location x.ptype_loc;
408 attributes i ppf x.ptype_attributes;
409 let i = i+1 in
410 line i ppf "ptype_params =\n";
411 list (i+1) type_parameter ppf x.ptype_params;
412 line i ppf "ptype_cstrs =\n";
413 list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
414 line i ppf "ptype_kind =\n";
415 type_kind (i+1) ppf x.ptype_kind;
416 line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;
417 line i ppf "ptype_manifest =\n";
418 option (i+1) core_type ppf x.ptype_manifest
419
420 and attribute i ppf k a =
421 line i ppf "%s \"%s\"\n" k a.attr_name.txt;
422 payload i ppf a.attr_payload;
423
424 and attributes i ppf l =
425 let i = i + 1 in
426 List.iter (fun a ->
427 line i ppf "attribute \"%s\"\n" a.attr_name.txt;
428 payload (i + 1) ppf a.attr_payload;
429 ) l;
430
431 and payload i ppf = function
432 | PStr x -> structure i ppf x
433 | PSig x -> signature i ppf x
434 | PTyp x -> core_type i ppf x
435 | PPat (x, None) -> pattern i ppf x
436 | PPat (x, Some g) ->
437 pattern i ppf x;
438 line i ppf "<when>\n";
439 expression (i + 1) ppf g
440
441
442 and type_kind i ppf x =
443 match x with
444 | Ptype_abstract ->
445 line i ppf "Ptype_abstract\n"
446 | Ptype_variant l ->
447 line i ppf "Ptype_variant\n";
448 list (i+1) constructor_decl ppf l;
449 | Ptype_record l ->
450 line i ppf "Ptype_record\n";
451 list (i+1) label_decl ppf l;
452 | Ptype_open ->
453 line i ppf "Ptype_open\n";
454
455 and type_extension i ppf x =
456 line i ppf "type_extension\n";
457 attributes i ppf x.ptyext_attributes;
458 let i = i+1 in
459 line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path;
460 line i ppf "ptyext_params =\n";
461 list (i+1) type_parameter ppf x.ptyext_params;
462 line i ppf "ptyext_constructors =\n";
463 list (i+1) extension_constructor ppf x.ptyext_constructors;
464 line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private;
465
466 and type_exception i ppf x =
467 line i ppf "type_exception\n";
468 attributes i ppf x.ptyexn_attributes;
469 let i = i+1 in
470 line i ppf "ptyext_constructor =\n";
471 let i = i+1 in
472 extension_constructor i ppf x.ptyexn_constructor
473
474 and extension_constructor i ppf x =
475 line i ppf "extension_constructor %a\n" fmt_location x.pext_loc;
476 attributes i ppf x.pext_attributes;
477 let i = i + 1 in
478 line i ppf "pext_name = \"%s\"\n" x.pext_name.txt;
479 line i ppf "pext_kind =\n";
480 extension_constructor_kind (i + 1) ppf x.pext_kind;
481
482 and extension_constructor_kind i ppf x =
483 match x with
484 Pext_decl(a, r) ->
485 line i ppf "Pext_decl\n";
486 constructor_arguments (i+1) ppf a;
487 option (i+1) core_type ppf r;
488 | Pext_rebind li ->
489 line i ppf "Pext_rebind\n";
490 line (i+1) ppf "%a\n" fmt_longident_loc li;
491
492 and class_type i ppf x =
493 line i ppf "class_type %a\n" fmt_location x.pcty_loc;
494 attributes i ppf x.pcty_attributes;
495 let i = i+1 in
496 match x.pcty_desc with
497 | Pcty_constr (li, l) ->
498 line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
499 list i core_type ppf l;
500 | Pcty_signature (cs) ->
501 line i ppf "Pcty_signature\n";
502 class_signature i ppf cs;
503 | Pcty_arrow (l, co, cl) ->
504 line i ppf "Pcty_arrow\n";
505 arg_label i ppf l;
506 core_type i ppf co;
507 class_type i ppf cl;
508 | Pcty_extension (s, arg) ->
509 line i ppf "Pcty_extension \"%s\"\n" s.txt;
510 payload i ppf arg
511 | Pcty_open (o, e) ->
512 line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override
513 fmt_longident_loc o.popen_expr;
514 class_type i ppf e
515
516 and class_signature i ppf cs =
517 line i ppf "class_signature\n";
518 core_type (i+1) ppf cs.pcsig_self;
519 list (i+1) class_type_field ppf cs.pcsig_fields;
520
521 and class_type_field i ppf x =
522 line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
523 let i = i+1 in
524 attributes i ppf x.pctf_attributes;
525 match x.pctf_desc with
526 | Pctf_inherit (ct) ->
527 line i ppf "Pctf_inherit\n";
528 class_type i ppf ct;
529 | Pctf_val (s, mf, vf, ct) ->
530 line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
531 fmt_virtual_flag vf;
532 core_type (i+1) ppf ct;
533 | Pctf_method (s, pf, vf, ct) ->
534 line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
535 fmt_virtual_flag vf;
536 core_type (i+1) ppf ct;
537 | Pctf_constraint (ct1, ct2) ->
538 line i ppf "Pctf_constraint\n";
539 core_type (i+1) ppf ct1;
540 core_type (i+1) ppf ct2;
541 | Pctf_attribute a ->
542 attribute i ppf "Pctf_attribute" a
543 | Pctf_extension (s, arg) ->
544 line i ppf "Pctf_extension \"%s\"\n" s.txt;
545 payload i ppf arg
546
547 and class_description i ppf x =
548 line i ppf "class_description %a\n" fmt_location x.pci_loc;
549 attributes i ppf x.pci_attributes;
550 let i = i+1 in
551 line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
552 line i ppf "pci_params =\n";
553 list (i+1) type_parameter ppf x.pci_params;
554 line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
555 line i ppf "pci_expr =\n";
556 class_type (i+1) ppf x.pci_expr;
557
558 and class_type_declaration i ppf x =
559 line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
560 attributes i ppf x.pci_attributes;
561 let i = i+1 in
562 line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
563 line i ppf "pci_params =\n";
564 list (i+1) type_parameter ppf x.pci_params;
565 line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
566 line i ppf "pci_expr =\n";
567 class_type (i+1) ppf x.pci_expr;
568
569 and class_expr i ppf x =
570 line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
571 attributes i ppf x.pcl_attributes;
572 let i = i+1 in
573 match x.pcl_desc with
574 | Pcl_constr (li, l) ->
575 line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
576 list i core_type ppf l;
577 | Pcl_structure (cs) ->
578 line i ppf "Pcl_structure\n";
579 class_structure i ppf cs;
580 | Pcl_fun (l, eo, p, e) ->
581 line i ppf "Pcl_fun\n";
582 arg_label i ppf l;
583 option i expression ppf eo;
584 pattern i ppf p;
585 class_expr i ppf e;
586 | Pcl_apply (ce, l) ->
587 line i ppf "Pcl_apply\n";
588 class_expr i ppf ce;
589 list i label_x_expression ppf l;
590 | Pcl_let (rf, l, ce) ->
591 line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
592 list i value_binding ppf l;
593 class_expr i ppf ce;
594 | Pcl_constraint (ce, ct) ->
595 line i ppf "Pcl_constraint\n";
596 class_expr i ppf ce;
597 class_type i ppf ct;
598 | Pcl_extension (s, arg) ->
599 line i ppf "Pcl_extension \"%s\"\n" s.txt;
600 payload i ppf arg
601 | Pcl_open (o, e) ->
602 line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override
603 fmt_longident_loc o.popen_expr;
604 class_expr i ppf e
605
606 and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
607 line i ppf "class_structure\n";
608 pattern (i+1) ppf p;
609 list (i+1) class_field ppf l;
610
611 and class_field i ppf x =
612 line i ppf "class_field %a\n" fmt_location x.pcf_loc;
613 let i = i + 1 in
614 attributes i ppf x.pcf_attributes;
615 match x.pcf_desc with
616 | Pcf_inherit (ovf, ce, so) ->
617 line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
618 class_expr (i+1) ppf ce;
619 option (i+1) string_loc ppf so;
620 | Pcf_val (s, mf, k) ->
621 line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
622 line (i+1) ppf "%a\n" fmt_string_loc s;
623 class_field_kind (i+1) ppf k
624 | Pcf_method (s, pf, k) ->
625 line i ppf "Pcf_method %a\n" fmt_private_flag pf;
626 line (i+1) ppf "%a\n" fmt_string_loc s;
627 class_field_kind (i+1) ppf k
628 | Pcf_constraint (ct1, ct2) ->
629 line i ppf "Pcf_constraint\n";
630 core_type (i+1) ppf ct1;
631 core_type (i+1) ppf ct2;
632 | Pcf_initializer (e) ->
633 line i ppf "Pcf_initializer\n";
634 expression (i+1) ppf e;
635 | Pcf_attribute a ->
636 attribute i ppf "Pcf_attribute" a
637 | Pcf_extension (s, arg) ->
638 line i ppf "Pcf_extension \"%s\"\n" s.txt;
639 payload i ppf arg
640
641 and class_field_kind i ppf = function
642 | Cfk_concrete (o, e) ->
643 line i ppf "Concrete %a\n" fmt_override_flag o;
644 expression i ppf e
645 | Cfk_virtual t ->
646 line i ppf "Virtual\n";
647 core_type i ppf t
648
649 and class_declaration i ppf x =
650 line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
651 attributes i ppf x.pci_attributes;
652 let i = i+1 in
653 line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
654 line i ppf "pci_params =\n";
655 list (i+1) type_parameter ppf x.pci_params;
656 line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
657 line i ppf "pci_expr =\n";
658 class_expr (i+1) ppf x.pci_expr;
659
660 and module_type i ppf x =
661 line i ppf "module_type %a\n" fmt_location x.pmty_loc;
662 attributes i ppf x.pmty_attributes;
663 let i = i+1 in
664 match x.pmty_desc with
665 | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
666 | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li;
667 | Pmty_signature (s) ->
668 line i ppf "Pmty_signature\n";
669 signature i ppf s;
670 | Pmty_functor (Unit, mt2) ->
671 line i ppf "Pmty_functor ()\n";
672 module_type i ppf mt2;
673 | Pmty_functor (Named (s, mt1), mt2) ->
674 line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
675 module_type i ppf mt1;
676 module_type i ppf mt2;
677 | Pmty_with (mt, l) ->
678 line i ppf "Pmty_with\n";
679 module_type i ppf mt;
680 list i with_constraint ppf l;
681 | Pmty_typeof m ->
682 line i ppf "Pmty_typeof\n";
683 module_expr i ppf m;
684 | Pmty_extension (s, arg) ->
685 line i ppf "Pmod_extension \"%s\"\n" s.txt;
686 payload i ppf arg
687
688 and signature i ppf x = list i signature_item ppf x
689
690 and signature_item i ppf x =
691 line i ppf "signature_item %a\n" fmt_location x.psig_loc;
692 let i = i+1 in
693 match x.psig_desc with
694 | Psig_value vd ->
695 line i ppf "Psig_value\n";
696 value_description i ppf vd;
697 | Psig_type (rf, l) ->
698 line i ppf "Psig_type %a\n" fmt_rec_flag rf;
699 list i type_declaration ppf l;
700 | Psig_typesubst l ->
701 line i ppf "Psig_typesubst\n";
702 list i type_declaration ppf l;
703 | Psig_typext te ->
704 line i ppf "Psig_typext\n";
705 type_extension i ppf te
706 | Psig_exception te ->
707 line i ppf "Psig_exception\n";
708 type_exception i ppf te
709 | Psig_module pmd ->
710 line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
711 attributes i ppf pmd.pmd_attributes;
712 module_type i ppf pmd.pmd_type
713 | Psig_modsubst pms ->
714 line i ppf "Psig_modsubst %a = %a\n"
715 fmt_string_loc pms.pms_name
716 fmt_longident_loc pms.pms_manifest;
717 attributes i ppf pms.pms_attributes;
718 | Psig_recmodule decls ->
719 line i ppf "Psig_recmodule\n";
720 list i module_declaration ppf decls;
721 | Psig_modtype x ->
722 line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
723 attributes i ppf x.pmtd_attributes;
724 modtype_declaration i ppf x.pmtd_type
725 | Psig_open od ->
726 line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
727 fmt_longident_loc od.popen_expr;
728 attributes i ppf od.popen_attributes
729 | Psig_include incl ->
730 line i ppf "Psig_include\n";
731 module_type i ppf incl.pincl_mod;
732 attributes i ppf incl.pincl_attributes
733 | Psig_class (l) ->
734 line i ppf "Psig_class\n";
735 list i class_description ppf l;
736 | Psig_class_type (l) ->
737 line i ppf "Psig_class_type\n";
738 list i class_type_declaration ppf l;
739 | Psig_extension ((s, arg), attrs) ->
740 line i ppf "Psig_extension \"%s\"\n" s.txt;
741 attributes i ppf attrs;
742 payload i ppf arg
743 | Psig_attribute a ->
744 attribute i ppf "Psig_attribute" a
745
746 and modtype_declaration i ppf = function
747 | None -> line i ppf "#abstract"
748 | Some mt -> module_type (i+1) ppf mt
749
750 and with_constraint i ppf x =
751 match x with
752 | Pwith_type (lid, td) ->
753 line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
754 type_declaration (i+1) ppf td;
755 | Pwith_typesubst (lid, td) ->
756 line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
757 type_declaration (i+1) ppf td;
758 | Pwith_module (lid1, lid2) ->
759 line i ppf "Pwith_module %a = %a\n"
760 fmt_longident_loc lid1
761 fmt_longident_loc lid2;
762 | Pwith_modsubst (lid1, lid2) ->
763 line i ppf "Pwith_modsubst %a = %a\n"
764 fmt_longident_loc lid1
765 fmt_longident_loc lid2;
766
767 and module_expr i ppf x =
768 line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
769 attributes i ppf x.pmod_attributes;
770 let i = i+1 in
771 match x.pmod_desc with
772 | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
773 | Pmod_structure (s) ->
774 line i ppf "Pmod_structure\n";
775 structure i ppf s;
776 | Pmod_functor (Unit, me) ->
777 line i ppf "Pmod_functor ()\n";
778 module_expr i ppf me;
779 | Pmod_functor (Named (s, mt), me) ->
780 line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
781 module_type i ppf mt;
782 module_expr i ppf me;
783 | Pmod_apply (me1, me2) ->
784 line i ppf "Pmod_apply\n";
785 module_expr i ppf me1;
786 module_expr i ppf me2;
787 | Pmod_constraint (me, mt) ->
788 line i ppf "Pmod_constraint\n";
789 module_expr i ppf me;
790 module_type i ppf mt;
791 | Pmod_unpack (e) ->
792 line i ppf "Pmod_unpack\n";
793 expression i ppf e;
794 | Pmod_extension (s, arg) ->
795 line i ppf "Pmod_extension \"%s\"\n" s.txt;
796 payload i ppf arg
797
798 and structure i ppf x = list i structure_item ppf x
799
800 and structure_item i ppf x =
801 line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
802 let i = i+1 in
803 match x.pstr_desc with
804 | Pstr_eval (e, attrs) ->
805 line i ppf "Pstr_eval\n";
806 attributes i ppf attrs;
807 expression i ppf e;
808 | Pstr_value (rf, l) ->
809 line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
810 list i value_binding ppf l;
811 | Pstr_primitive vd ->
812 line i ppf "Pstr_primitive\n";
813 value_description i ppf vd;
814 | Pstr_type (rf, l) ->
815 line i ppf "Pstr_type %a\n" fmt_rec_flag rf;
816 list i type_declaration ppf l;
817 | Pstr_typext te ->
818 line i ppf "Pstr_typext\n";
819 type_extension i ppf te
820 | Pstr_exception te ->
821 line i ppf "Pstr_exception\n";
822 type_exception i ppf te
823 | Pstr_module x ->
824 line i ppf "Pstr_module\n";
825 module_binding i ppf x
826 | Pstr_recmodule bindings ->
827 line i ppf "Pstr_recmodule\n";
828 list i module_binding ppf bindings;
829 | Pstr_modtype x ->
830 line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
831 attributes i ppf x.pmtd_attributes;
832 modtype_declaration i ppf x.pmtd_type
833 | Pstr_open od ->
834 line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override;
835 module_expr i ppf od.popen_expr;
836 attributes i ppf od.popen_attributes
837 | Pstr_class (l) ->
838 line i ppf "Pstr_class\n";
839 list i class_declaration ppf l;
840 | Pstr_class_type (l) ->
841 line i ppf "Pstr_class_type\n";
842 list i class_type_declaration ppf l;
843 | Pstr_include incl ->
844 line i ppf "Pstr_include";
845 attributes i ppf incl.pincl_attributes;
846 module_expr i ppf incl.pincl_mod
847 | Pstr_extension ((s, arg), attrs) ->
848 line i ppf "Pstr_extension \"%s\"\n" s.txt;
849 attributes i ppf attrs;
850 payload i ppf arg
851 | Pstr_attribute a ->
852 attribute i ppf "Pstr_attribute" a
853
854 and module_declaration i ppf pmd =
855 str_opt_loc i ppf pmd.pmd_name;
856 attributes i ppf pmd.pmd_attributes;
857 module_type (i+1) ppf pmd.pmd_type;
858
859 and module_binding i ppf x =
860 str_opt_loc i ppf x.pmb_name;
861 attributes i ppf x.pmb_attributes;
862 module_expr (i+1) ppf x.pmb_expr
863
864 and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
865 line i ppf "<constraint> %a\n" fmt_location l;
866 core_type (i+1) ppf ct1;
867 core_type (i+1) ppf ct2;
868
869 and constructor_decl i ppf
870 {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
871 line i ppf "%a\n" fmt_location pcd_loc;
872 line (i+1) ppf "%a\n" fmt_string_loc pcd_name;
873 attributes i ppf pcd_attributes;
874 constructor_arguments (i+1) ppf pcd_args;
875 option (i+1) core_type ppf pcd_res
876
877 and constructor_arguments i ppf = function
878 | Pcstr_tuple l -> list i core_type ppf l
879 | Pcstr_record l -> list i label_decl ppf l
880
881 and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}=
882 line i ppf "%a\n" fmt_location pld_loc;
883 attributes i ppf pld_attributes;
884 line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable;
885 line (i+1) ppf "%a" fmt_string_loc pld_name;
886 core_type (i+1) ppf pld_type
887
888 and longident_x_pattern i ppf (li, p) =
889 line i ppf "%a\n" fmt_longident_loc li;
890 pattern (i+1) ppf p;
891
892 and case i ppf {pc_lhs; pc_guard; pc_rhs} =
893 line i ppf "<case>\n";
894 pattern (i+1) ppf pc_lhs;
895 begin match pc_guard with
896 | None -> ()
897 | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
898 end;
899 expression (i+1) ppf pc_rhs;
900
901 and value_binding i ppf x =
902 line i ppf "<def>\n";
903 attributes (i+1) ppf x.pvb_attributes;
904 pattern (i+1) ppf x.pvb_pat;
905 expression (i+1) ppf x.pvb_expr
906
907 and binding_op i ppf x =
908 line i ppf "<binding_op> %a %a"
909 fmt_string_loc x.pbop_op fmt_location x.pbop_loc;
910 pattern (i+1) ppf x.pbop_pat;
911 expression (i+1) ppf x.pbop_exp;
912
913 and string_x_expression i ppf (s, e) =
914 line i ppf "<override> %a\n" fmt_string_loc s;
915 expression (i+1) ppf e;
916
917 and longident_x_expression i ppf (li, e) =
918 line i ppf "%a\n" fmt_longident_loc li;
919 expression (i+1) ppf e;
920
921 and label_x_expression i ppf (l,e) =
922 line i ppf "<arg>\n";
923 arg_label i ppf l;
924 expression (i+1) ppf e;
925
926 and label_x_bool_x_core_type_list i ppf x =
927 match x.prf_desc with
928 Rtag (l, b, ctl) ->
929 line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
930 attributes (i+1) ppf x.prf_attributes;
931 list (i+1) core_type ppf ctl
932 | Rinherit (ct) ->
933 line i ppf "Rinherit\n";
934 core_type (i+1) ppf ct
935 ;;
936
937 let rec toplevel_phrase i ppf x =
938 match x with
939 | Ptop_def (s) ->
940 line i ppf "Ptop_def\n";
941 structure (i+1) ppf s;
942 | Ptop_dir {pdir_name; pdir_arg; _} ->
943 line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
944 match pdir_arg with
945 | None -> ()
946 | Some da -> directive_argument i ppf da;
947
948 and directive_argument i ppf x =
949 match x.pdira_desc with
950 | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
951 | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
952 | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
953 | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
954 | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
955 ;;
956
957 let interface ppf x = list 0 signature_item ppf x;;
958
959 let implementation ppf x = list 0 structure_item ppf x;;
960
961 let top_phrase ppf x = toplevel_phrase 0 ppf x;;
962