Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 697 lines (655 sloc) 21.028 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 (* shorthand *)
21 module O = Ocaml
22
23 (* -- *)
24 module type Printer =
25 sig
26 type t
27 type 'a printer = t -> 'a -> unit
28 (* open OcamlAst *) open Ocaml
29 val const_expr : const_expr printer
30 val const_type_expr : const_type_expr printer
31 val type_name : type_name printer
32 val type_expr : type_expr printer
33 val pattern : pattern printer
34 val param_formel : param_formel printer
35 val param_effectif : param_effectif printer
36 val mlIdent : mlIdent printer
37 val code : code printer
38 val expr : expr printer
39 end
40
41 module type X =
42 sig
43 type t
44 val output_string : t -> string -> unit
45 end
46
47 (**
48 <!> The function used for print stident should return the original
49 name in case of a source. ident. (stident)
50 *)
51 let ident = Ident.stident
52
53 module Make ( X : X ) : Printer with type t = X.t =
54 struct
55 open X
56 type t = X.t
57 type 'a printer = t -> 'a -> unit
58
59 let paren printer oc a =
60 output_string oc "(";
61 printer oc a;
62 output_string oc ")"
63
64 let output_int oc i = output_string oc (string_of_int i)
65 let output_float oc f = output_string oc (string_of_float f)
66 let output_bool oc b = output_string oc (string_of_bool b)
67
68 let output_ident oc id =
69 match ident id with
70 | "*" -> output_string oc " * " (* accidental comments... *)
71 | idstr -> output_string oc idstr
72
73 let output_concat_map oc sep map =
74 let rec aux = function
75 | [] -> ()
76 | [last] -> map oc last
77 | t::q ->
78 map oc t;
79 output_string oc sep;
80 aux q
81 in aux
82
83 (* open OcamlAst *) open Ocaml
84 let const_expr oc = function
85 | String s ->
86 output_string oc "\"";
87 output_string oc (String.escaped s);
88 output_string oc "\""
89 | Int i ->
90 if i < 0 then (
91 output_string oc "(";
92 output_int oc i;
93 output_string oc ")"
94 )
95 else
96 output_int oc i
97 | Float f ->
98 if f < 0. then (
99 output_string oc "(";
100 output_float oc f;
101 output_string oc ")"
102 )
103 else
104 output_float oc f
105 | Bool b -> output_bool oc b
106 | Char c ->
107 output_string oc "'";
108 output_string oc (Char.escaped c);
109 output_string oc "'"
110 | Unit ->
111 output_string oc "()"
112
113 let const_type_expr oc = function
114 | TypeString -> output_string oc "string"
115 | TypeInt -> output_string oc "int"
116 | TypeInt64 -> output_string oc "int64"
117 | TypeFloat -> output_string oc "float"
118 | TypeBool -> output_string oc "bool"
119 | TypeUnit -> output_string oc "unit"
120
121 let type_name oc = output_concat_map oc "." output_string
122
123 let rec type_expr oc = function
124 | TypeTuple li ->
125 output_string oc "( ";
126 output_concat_map oc " * " type_expr li;
127 output_string oc " )";
128 | TypeVar s -> output_string oc s
129 | TypeName ([], name) -> type_name oc name
130 | TypeName (tl, name) ->
131 output_string oc "( ";
132 output_concat_map oc ", " type_expr tl;
133 output_string oc " ) ";
134 type_name oc name
135 | TypeConst c -> const_type_expr oc c
136 | TypeRef a ->
137 output_string oc "( ";
138 type_expr oc a;
139 output_string oc " ) ref";
140 | TypeRecord stl ->
141 output_string oc "{ ";
142 output_concat_map oc " ; " record stl;
143 output_string oc " }";
144 | TypeConstructor stl ->
145 output_concat_map oc " | " constructor stl
146 | TypeArrow (a, b) ->
147 (* FIXME, type within an arrow cannot be parenthesized for TypeLabels (for .mli files).
148 Is it safe to drop the parens altogether? *)
149 begin match a with
150 | TypeLabel _ ->
151 type_expr oc a;
152 output_string oc " -> ";
153 type_expr oc b
154 | _ ->
155 output_string oc "(";
156 type_expr oc a;
157 output_string oc ") -> ";
158 type_expr oc b
159 end
160 | TypeVerbatim v ->
161 output_string oc v
162 | TypeLabel (opt, vname, vtype) ->
163 if opt then
164 output_string oc "?";
165 output_string oc vname;
166 output_string oc ":";
167 type_expr oc vtype
168 and record oc = function
169 | mutable_, field, type_expr' ->
170 (if mutable_ then output_string oc "mutable ");
171 output_string oc field;
172 output_string oc " : ";
173 type_expr oc type_expr'
174 and constructor oc = function
175 | name, None ->
176 output_string oc name
177 | name, Some of_type_expr ->
178 output_string oc name;
179 output_string oc " of ";
180 type_expr oc of_type_expr
181
182 let rec pattern oc = function
183 | PatVar v -> output_ident oc v
184 | PatList (a, b) ->
185 output_string oc "(";
186 pattern oc a;
187 output_string oc ") :: (";
188 pattern oc b;
189 output_string oc ")"
190 | PatEmptyList -> output_string oc "[]"
191 | PatRecord spl ->
192 output_string oc "{ ";
193 output_concat_map oc " ; " pattern_record spl;
194 output_string oc " }"
195 | PatConstructor (s, []) | PatVariant (s, []) -> mlIdent oc s
196 | PatConstructor (s, pl) | PatVariant (s, pl) ->
197 mlIdent oc s;
198 output_string oc " ( ";
199 output_concat_map oc ", " pattern pl;
200 output_string oc " )";
201 | PatPVariant (s, []) ->
202 output_string oc "`";
203 mlIdent oc s
204 | PatPVariant (s, pl) ->
205 output_string oc "`";
206 mlIdent oc s;
207 output_string oc " ( ";
208 output_concat_map oc ", " pattern pl;
209 output_string oc " )";
210
211 | PatConst c -> const_expr oc c
212 | PatAny -> output_string oc "_"
213 | PatAnnot (p, ty) ->
214 output_string oc "( (";
215 pattern oc p;
216 output_string oc ") : ";
217 type_expr oc ty;
218 output_string oc " )"
219 | PatAs (p, s) ->
220 output_string oc "( ";
221 pattern oc p;
222 output_string oc " ) as ";
223 output_ident oc s
224 | PatTuple pl ->
225 output_string oc "( ";
226 output_concat_map oc ", " pattern pl;
227 output_string oc " )"
228 | PatArray pl ->
229 output_string oc "[| ";
230 output_concat_map oc " ; " pattern pl;
231 output_string oc " |]"
232 | O.PatLazy p ->
233 output_string oc "lazy " ;
234 pattern oc p
235 | O.PatOr pl ->
236 output_string oc "( ";
237 output_concat_map oc " | " pattern pl;
238 output_string oc " )"
239
240 and pattern_record oc = function
241 | field, pattern' ->
242 output_string oc field;
243 output_string oc " = ";
244 pattern oc pattern'
245
246 and param_formel oc = function
247 | Label (s, None, None) ->
248 output_string oc "~";
249 output_string oc s
250 | Label (_, None, Some _) -> assert false (* TODO *)
251 (* (type_expr_to_fb (acc ++ "~(" ++ s ++ " : ") ty) ++ ")" *)
252 | Label (_, Some _, None) -> assert false (* TODO *)
253 (* pattern_to_fb (acc ++ "~" ++ s ++ " : ") n *)
254 | Label (_, Some _, Some _) -> assert false (* TODO *)
255 (* (type_expr_to_fb ((pattern_to_fb (acc ++ "~" ++ s ++ ":(") n) ++ " : ") ty) ++ ")" *)
256 | Opt (s, None, None) ->
257 output_string oc "?";
258 output_string oc s
259 | Opt (_, Some _, None) -> assert false (* TODO *)
260 (* (type_expr_to_fb (acc ++ "?(" ++ s ++ " : ") ty) ++ ")" *)
261 | Opt (s, None, Some e) ->
262 output_string oc "?(";
263 output_string oc s;
264 output_string oc " = ";
265 expr oc e;
266 output_string oc ")"
267 | Opt (_, Some _, Some _) -> assert false
268 (* (expr_to_fb ((type_expr_to_fb (acc ++ "?((" ++ s ++ " : ") ty) ++ ") = ") e) ++ ")" *)
269 | Pat p -> pattern oc p
270
271 and param_effectif oc = function
272 | Labeled (s, None) ->
273 output_string oc "~";
274 output_string oc s
275 | Labeled (s, Some e) ->
276 output_string oc "~";
277 output_string oc s;
278 output_string oc ":(";
279 expr oc e;
280 output_string oc ")"
281 | Pated (id, false) ->
282 mlIdent oc id
283 | Pated (id, true) ->
284 output_string oc "(";
285 mlIdent oc id;
286 output_string oc ")"
287
288 and mlIdent oc = function
289 | [] -> assert false
290 | idents -> output_concat_map oc "." output_ident idents
291
292 and code oc =
293 let iter e =
294 expr oc e;
295 output_string oc "\n" in
296 List.iter iter
297
298 and expr_type oc = function
299 | [], name, type_expr' ->
300 output_string oc name;
301 output_string oc " = ";
302 type_expr oc type_expr'
303 | params, name, type_expr' ->
304 output_string oc "(";
305 output_concat_map oc ", " output_string params;
306 output_string oc ") ";
307 output_string oc name;
308 output_string oc " = ";
309 type_expr oc type_expr'
310 and expr_let oc = function
311 | param_formel', expr' ->
312 param_formel oc param_formel';
313 begin
314 let expr' =
315 match expr' with
316 | Abs (params, expr') ->
317 output_string oc " ";
318 output_concat_map oc " " param_formel params;
319 expr'
320 | _ -> expr'
321 in
322 output_string oc " = ";
323 expr oc expr'
324 end
325 and expr_record oc = function
326 | field, expr' ->
327 output_string oc field;
328 output_string oc " = ";
329 expr oc expr'
330 and expr_pattern oc = function
331 | pattern', guard, expr' ->
332 pattern oc pattern';
333 let () =
334 match guard with
335 | None -> ()
336 | Some guard ->
337 output_string oc " when ";
338 expr oc guard
339 in
340 output_string oc " -> ";
341 expr oc expr'
342 and labelparam oc v =
343 begin match v with
344 | Var (
345 Labeled(_, _)
346 ) ->
347 expr oc v
348 | _ -> paren expr oc v
349 end
350
351 and expr oc = function
352 | Type [] -> assert false (* TODO: HdList.t in type definition *)
353 | Type defs ->
354 output_string oc "type ";
355 output_concat_map oc " and " expr_type defs
356 | Val (name, type_expr') ->
357 output_string oc "val ";
358 output_ident oc name;
359 output_string oc " : ";
360 type_expr oc type_expr'
361 | Open mlIdent' ->
362 output_string oc "open ";
363 mlIdent oc mlIdent'
364
365 (*
366 | Module of string * expr option * code * expr option
367 [Module(name, functor, contents, [Some e])] is a local module definition.
368 [Module(name, functor, contents, None)] is a global module definition.*)
369 | Module (name, None, code', None) ->
370 output_string oc "module ";
371 output_string oc name;
372 output_string oc " = struct\n";
373 code oc code';
374 output_string oc "end"
375
376 | Module (_, _, _, _) -> assert false
377
378 | ModuleType (name, code') ->
379 output_string oc "module type ";
380 output_string oc name;
381 output_string oc " = ";
382 code oc code' (* code' *should* be an expr (Signature ...) ! *)
383
384 | Structure code' ->
385 output_string oc "struct\n";
386 code oc code';
387 output_string oc "end"
388 | Signature (Inlined code') ->
389 output_string oc "sig\n";
390 code oc code';
391 output_string oc "end"
392 | Signature (Referenced _) -> assert false (* TODO *)
393
394 (* Used to print functor signatures (for .mli files) *)
395 | DeclareFunctor (name, args, (Some sign), (Structure [])) ->
396 (* Yeah, that's ugly, we could use an option ^^^^^^^^^^ *)
397 output_string oc "module ";
398 output_string oc name ;
399 output_string oc " :" ;
400 List.iter
401 (function
402 | s, None -> output_string oc ("\nfunctor " ^ s ^ " ->")
403 | s, Some si ->
404 output_string oc "\nfunctor ("; output_string oc s;
405 output_string oc " : "; expr oc si; output_string oc ") ->")
406 args;
407 output_string oc "\n" ; expr oc sign
408
409 | DeclareFunctor (name, args, sig_opt, content) ->
410 (* of string * (string * expr option) list * expr option * expr *)
411 output_string oc "module ";
412 output_string oc name;
413 List.iter
414 (function
415 | s, None -> output_string oc ("\n" ^ s)
416 | s, Some si ->
417 output_string oc "\n("; output_string oc s;
418 output_string oc " : "; expr oc si; output_string oc ")")
419 args;
420 (match sig_opt with
421 | None -> ()
422 | Some si -> output_string oc " :"; expr oc si) ;
423 output_string oc " = " ;
424 expr oc content
425
426 | Constructor (ml, []) ->
427 mlIdent oc ml
428 | Constructor (ml, list) ->
429 mlIdent oc ml;
430 output_string oc "(";
431 output_concat_map oc ", " expr list;
432 output_string oc ")";
433 | ConstructorPV (ml, []) ->
434 output_string oc "`";
435 mlIdent oc ml
436 | ConstructorPV (ml, list) ->
437 output_string oc "`";
438 mlIdent oc ml;
439 output_string oc "(";
440 output_concat_map oc ", " expr list;
441 output_string oc ")";
442 | Const const_expr' ->
443 const_expr oc const_expr'
444 | Var p ->
445 param_effectif oc p
446 | MakeRef expr' ->
447 output_string oc "ref (";
448 expr oc expr';
449 output_string oc ")"
450 | GetRef expr' ->
451 output_string oc "!(";
452 expr oc expr';
453 output_string oc ")"
454 | SetRef (e, f) ->
455 expr oc e;
456 output_string oc " := ";
457 expr oc f
458 | SetMutable (e, f) ->
459 expr oc e;
460 output_string oc " <- ";
461 expr oc f
462 | Lazy e ->
463 output_string oc "lazy (";
464 expr oc e;
465 output_string oc ")"
466 | Tuple pl ->
467 output_string oc "(";
468 output_concat_map oc ", " expr pl;
469 output_string oc ")"
470 | Cons (hd, (Cons (_, _) as tl)) ->
471 (* This is a kludge, maybe separate cons's for [1,2,3] and (1::(2::(3::[])))??? *)
472 let rec build acc = function
473 | Cons (a, l) -> build (a::acc) l
474 | EmptyList -> List.rev acc
475 | _ ->
476 (* Too much work to arrange for type sharing with_out_channel *)
477 (*output_string stderr "\nocamlPrint.ml Cons error <<<";
478 expr stderr e;
479 output_string stderr ">>>\n";*)
480 assert false
481 in
482 let list = build [hd] tl in
483 output_string oc "[ ";
484 output_concat_map oc " ; " expr list;
485 output_string oc " ]"
486 | Cons (hd, tl) ->
487 output_string oc "((";
488 expr oc hd;
489 output_string oc ")::(";
490 expr oc tl;
491 output_string oc "))"
492 | EmptyList ->
493 output_string oc "[]"
494 | Cond (if_, then_, else_) ->
495 output_string oc "if ( ";
496 expr oc if_;
497 output_string oc " ) then ( ";
498 expr oc then_;
499 output_string oc " ) else ( ";
500 expr oc else_;
501 output_string oc " )";
502 | App (e, f) ->
503 let rec print_fun e =
504 match e with
505 | App (e, f) ->
506 begin match e with
507 | Var (Pated (_, false)) -> expr oc e;
508 | _ -> print_fun e
509 end;
510 output_string oc " ";
511 labelparam oc f
512 | _ -> paren expr oc e;
513 in begin
514 output_string oc "(";
515 print_fun e;
516 output_string oc " ";
517 labelparam oc f;
518 output_string oc ")";
519 end
520 | Abs (params, e) ->
521 let e, params =
522 let rec uncons acc e =
523 match e with
524 | Abs(params, e) ->
525 uncons (params :: acc) e
526 | _ -> e, (List.flatten (List.rev acc))
527 in uncons [params] e
528 in
529 begin
530 output_string oc "(fun ";
531 output_concat_map oc " " param_formel params;
532 output_string oc " -> ";
533 expr oc e;
534 output_string oc ")"
535 end
536 | Let [] | Letrec [] | Letin ([], _) | Letrecin ([], _) -> assert false (* TODO: HdList.t *)
537 | Let binds ->
538 output_string oc "let ";
539 output_concat_map oc "\nand " expr_let binds;
540 | Letrec binds ->
541 output_string oc "let rec ";
542 output_concat_map oc "\nand " expr_let binds;
543 | Letin (binds, e) ->
544 output_string oc "let ";
545 output_concat_map oc "\nand " expr_let binds;
546 output_string oc " in\n";
547 expr oc e
548 | Letrecin (binds, e) ->
549 output_string oc "let rec ";
550 output_concat_map oc "\nand " expr_let binds;
551 output_string oc " in\n";
552 expr oc e
553 | Record (rec_opt,fields) ->
554 output_string oc "{ ";
555 (match rec_opt with Some r -> (output_string oc r; output_string oc " with ") | None -> ());
556 output_concat_map oc " ; " expr_record fields;
557 output_string oc " }"
558 | Dot (((Var _) as a), s) ->
559 expr oc a;
560 output_string oc ".";
561 output_string oc s
562 | Dot (a, s) ->
563 output_string oc "(";
564 expr oc a;
565 output_string oc ").";
566 output_string oc s
567 | Match (e, pel) ->
568 output_string oc "(match ";
569 expr oc e;
570 output_string oc " with\n";
571 output_concat_map oc "\n| " expr_pattern pel;
572 output_string oc ")";
573 | Sequence (e, f) ->
574 expr oc e;
575 output_string oc " ; ";
576 expr oc f
577 | Annot (e, ty) ->
578 output_string oc "( ( ";
579 expr oc e;
580 output_string oc " ) : ";
581 type_expr oc ty;
582 output_string oc " )"
583 | Function [] -> assert false
584 | Function pel ->
585 output_string oc "function ";
586 output_concat_map oc "\n| " expr_pattern pel
587 | Exception (s, None) ->
588 output_string oc "exception ";
589 output_string oc s;
590 | Exception (s, Some type_expr') ->
591 output_string oc "exception ";
592 output_string oc s;
593 output_string oc " of ";
594 type_expr oc type_expr'
595 | Raise (ml, None) ->
596 output_string oc "raise ";
597 mlIdent oc ml
598 | Raise (ml, Some e) ->
599 output_string oc "raise ";
600 output_string oc "(";
601 mlIdent oc ml;
602 output_string oc "( ";
603 expr oc e;
604 output_string oc " ))";
605 | Try (e, with_) ->
606 output_string oc "(try (\n";
607 expr oc e;
608 output_string oc "\n) with\n";
609 output_concat_map oc "\n| " expr_pattern with_;
610 output_string oc ")\n" (* We may be in a pat match... *)
611 | AnArray el ->
612 output_string oc "[| ";
613 output_concat_map oc " ; " (paren expr) el;
614 output_string oc " |]";
615 | Comment comment ->
616 output_string oc "(* ";
617 output_string oc comment;
618 output_string oc " *) "
619 | Comments (comment, expr') ->
620 output_string oc "( (* ";
621 output_string oc comment;
622 output_string oc " *) ";
623 expr oc expr';
624 output_string oc ")"
625 | Assert e ->
626 output_string oc "(assert ";
627 expr oc e;
628 output_string oc ")";
629 | LineAnnot (n, f, e) ->
630 output_string oc "\n#";
631 output_int oc n;
632 output_string oc " \"";
633 output_string oc f;
634 output_string oc "\"\n";
635 expr oc e
636 | Verbatim s -> output_string oc s
637 end
638
639 module X_Output : X with type t = out_channel =
640 struct
641 type t = out_channel
642 let output_string = Pervasives.output_string
643 end
644
645 module X_Buf : X with type t = Buffer.t =
646 struct
647 type t = Buffer.t
648 let output_string = Buffer.add_string
649 end
650
651 module X_Fmt : X with type t = Format.formatter =
652 struct
653 type t = Format.formatter
654 let output_string = Format.pp_print_string
655 end
656
657 module X_FBuf : X with type t = FBuffer.t ref =
658 struct
659 type t = FBuffer.t ref
660 let output_string t s =
661 let t' = FBuffer.add !t s in
662 t := t'
663 end
664
665 module Output = Make ( X_Output )
666 module Buf = Make ( X_Buf )
667 module Fmt = Make ( X_Fmt )
668 module FBuf = Make ( X_FBuf )
669
670 module Deprecated =
671 struct
672 type 'a printer = FBuffer.t -> 'a -> FBuffer.t
673 let const_expr fb c =
674 let r = ref fb in
675 FBuf.const_expr r c;
676 !r
677 let type_expr fb t =
678 let r = ref fb in
679 FBuf.type_expr r t;
680 !r
681 end
682
683 (* {6 Pretty printer} *)
684 type 'a pprinter = 'a LangPrint.pprinter
685
686 let pp_list = Base.Format.pp_list
687 (* beware for error message, oneline should be set to true *)
688 (*
689 <!> Rather than trying to hack LangPrint with optionnal arguments,
690 OcamlPrint defines his own pp_parameters.
691 *)
692 let pp_parameters pp name fmt params =
693 match params with
694 | [] -> Format.pp_print_string fmt name
695 | [p] -> Format.fprintf fmt "%a %s" pp p name
696 | _ -> Format.fprintf fmt "(%a) %s" (pp_list ", " pp) params name
Something went wrong with that request. Please try again.