Revu les impressions du compilateur

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2908 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 125 insertions, 162 deletions

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 0e21ef131d..6921529e5a 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -15,7 +15,7 @@
 (* To print values *)
 
 open Misc
-open Formatmsg
+open Format
 open Longident
 open Path
 open Types
@@ -38,10 +38,10 @@ module type S =
     val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
     val remove_printer : Path.t -> unit
 
-    val print_exception : t -> unit
+    val print_exception : formatter -> t -> unit
     val print_value :
           int -> int -> (int -> t -> Types.type_expr -> bool) ->
-          Env.t -> t -> type_expr -> unit
+          Env.t -> t -> formatter -> type_expr -> unit
   end
 
 module Make(O : OBJ) = struct
@@ -53,85 +53,76 @@ module Make(O : OBJ) = struct
        Here, we do a feeble attempt to print
        integer, string and float arguments... *)
 
-    let print_exception_args obj start_offset =
+    let print_exception_args obj ppf start_offset =
       if O.size obj > start_offset then begin
-        open_box 1;
-        print_string "(";
+        fprintf ppf "@[<1>(";
         for i = start_offset to O.size obj - 1 do
-          if i > start_offset then begin print_string ","; print_space() end;
+          if i > start_offset then fprintf ppf ",@ ";
           let arg = O.field obj i in
           if not (O.is_block arg) then
-            print_int(O.obj arg : int)  (* Note: this could be a char! *)
-          else if O.tag arg = Obj.string_tag then begin
-            print_string "\"";
-            print_string (String.escaped (O.obj arg : string));
-            print_string "\""
-          end else if O.tag arg = Obj.double_tag then
-            print_float (O.obj arg : float)
+            fprintf ppf "%i" (O.obj arg : int) (* Note: this could be a char! *)
+          else if O.tag arg = Obj.string_tag then
+            fprintf ppf "\"%s\"" (String.escaped (O.obj arg : string))
+          else if O.tag arg = Obj.double_tag then
+            fprintf ppf "%f" (O.obj arg : float)
           else
-            print_string "_"
+            fprintf ppf "_"
         done;
-        print_string ")";
-        close_box()
+        fprintf ppf ")@]"
       end
 
-    let print_exception bucket =
+    let print_path = Printtyp.path
+
+    let print_exception ppf bucket =
       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
-      print_string name;
       if (name = "Match_failure" || name = "Assert_failure")
       && O.size bucket = 2
       && O.tag(O.field bucket 1) = 0
-      then print_exception_args (O.field bucket 1) 0
-      else print_exception_args bucket 1
+      then fprintf ppf "%s%a" name (print_exception_args (O.field bucket 1)) 0
+      else fprintf ppf "%s%a" name (print_exception_args bucket) 1
 
     (* The user-defined printers. Also used for some builtin types. *)
 
     let printers = ref ([
       Pident(Ident.create "print_int"), Predef.type_int,
-        (fun x -> print_int (O.obj x : int));
+        (fun ppf x -> fprintf ppf "%i" (O.obj x : int));
       Pident(Ident.create "print_float"), Predef.type_float,
-        (fun x -> print_float(O.obj x : float));
+        (fun ppf x -> fprintf ppf "%f" (O.obj x : float));
       Pident(Ident.create "print_char"), Predef.type_char,
-        (fun x -> print_string "'";
-                  print_string (Char.escaped (O.obj x : char));
-                  print_string "'");
+        (fun ppf x ->
+          fprintf ppf "'%s'" (Char.escaped (O.obj x : char)));
       Pident(Ident.create "print_string"), Predef.type_string,
-        (fun x -> print_string "\"";
-                  print_string (String.escaped (O.obj x : string));
-                  print_string "\"");
+        (fun ppf x ->
+          fprintf ppf "\"%s\"" (String.escaped (O.obj x : string)));
       Pident(Ident.create "print_int32"), Predef.type_int32,
-        (fun x -> print_string "<int32 ";
-                  print_string (Int32.to_string (O.obj x : int32));
-                  print_string ">");
+        (fun ppf x ->
+          fprintf ppf "<int32 %s>" (Int32.to_string (O.obj x : int32)));
       Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
-        (fun x -> print_string "<nativeint ";
-                  print_string (Nativeint.to_string (O.obj x : nativeint));
-                  print_string ">");
+        (fun ppf x ->
+          fprintf ppf "<nativeint %s>"
+            (Nativeint.to_string (O.obj x : nativeint)));
       Pident(Ident.create "print_int64"), Predef.type_int64,
-        (fun x -> print_string "<int64 ";
-                  print_string (Int64.to_string (O.obj x : int64));
-                  print_string ">")
-    ] : (Path.t * type_expr * (O.t -> unit)) list)
+        (fun ppf x -> 
+          fprintf ppf "<int64 %s>" (Int64.to_string (O.obj x : int64)));
+    ] : (Path.t * type_expr * (Format.formatter -> O.t -> unit)) list)
 
     let install_printer path ty fn =
-      let print_val obj =
+      let print_val ppf obj =
         try fn obj with
-          exn ->
-            print_string "<printer ";
-            Printtyp.path path;
-            print_string " raised an exception>" in
+        | exn ->
+           fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
       printers := (path, ty, print_val) :: !printers
 
     let remove_printer path =
       let rec remove = function
-        [] -> raise Not_found
+      | [] -> raise Not_found
       | (p, ty, fn as printer) :: rem ->
           if Path.same p path then rem else printer :: remove rem in
       printers := remove !printers
 
     let find_printer env ty =
       let rec find = function
-        [] -> raise Not_found
+      | [] -> raise Not_found
       | (name, sch, printer) :: remainder ->
           if Ctype.moregeneral env false sch ty
           then printer
@@ -142,20 +133,20 @@ module Make(O : OBJ) = struct
        it comes from. Attempt to omit the prefix if the type comes from
        a module that has been opened. *)
 
-    let print_qualified lookup_fun env ty_path name =
+    let print_qualified lookup_fun env ty_path ppf name =
       match ty_path with
-        Pident id ->
-          print_string name
+      | Pident id ->
+          fprintf ppf "%s" name
       | Pdot(p, s, pos) ->
           if try
                match (lookup_fun (Lident name) env).desc with
-                 Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
+               | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
                | _ -> false
              with Not_found -> false
-          then print_string name
-          else (Printtyp.path p; print_string "."; print_string name)
+          then fprintf ppf "%s" name
+          else fprintf ppf "%a.%s" Printtyp.path p name
       | Papply(p1, p2) ->
-          Printtyp.path ty_path
+          Printtyp.path ppf ty_path
 
     let print_constr =
       print_qualified
@@ -175,83 +166,70 @@ module Make(O : OBJ) = struct
 
     let cautious f arg = try f arg with Ellipsis -> print_string "..."
 
-    let print_value max_steps max_depth check_depth env obj ty =
+    let print_value max_steps max_depth check_depth env obj ppf ty =
 
       let printer_steps = ref max_steps in
 
-      let rec print_val prio depth obj ty =
+      let rec print_val prio depth obj ppf ty =
         decr printer_steps;
         if !printer_steps < 0 or depth < 0 then raise Ellipsis;
         try
-          find_printer env ty obj; ()
+          find_printer env ty ppf obj
         with Not_found ->
           match (Ctype.repr ty).desc with
-            Tvar ->
-              print_string "<poly>"
+          | Tvar ->
+              fprintf ppf "<poly>"
           | Tarrow(_, ty1, ty2) ->
-              print_string "<fun>"
+              fprintf ppf "<fun>"
           | Ttuple(ty_list) ->
               if check_depth depth obj ty then begin
                 if prio > 0
-                then begin open_box 1; print_string "(" end
-                else open_box 0;
-                print_val_list 1 depth obj ty_list;
-                if prio > 0 then print_string ")";
-                close_box()
+                then
+                  fprintf ppf "@[<1>(%a)@]" (print_val_list 1 depth obj) ty_list
+                else fprintf ppf "@[%a@]" (print_val_list 1 depth obj) ty_list
               end
           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
               if check_depth depth obj ty then begin
                 if prio > 1
-                then begin open_box 2; print_string "(" end
-                else open_box 1;
-                print_exception obj;
-                if prio > 1 then print_string ")";
-                close_box()
+                then fprintf ppf "@[<2>(%a)@]" print_exception obj
+                else fprintf ppf "@[<1>%a@]" print_exception obj
               end
           | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
               if O.is_block obj then begin
                 if check_depth depth obj ty then begin
-                  let rec print_conses cons =
-                    print_val 0 (depth - 1) (O.field cons 0) ty_arg;
+                  let rec print_conses ppf cons =
+                    print_val 0 (depth - 1) (O.field cons 0) ppf ty_arg;
                     let next_obj = O.field cons 1 in
-                    if O.is_block next_obj then begin
-                      print_string ";"; print_space();
-                      print_conses next_obj
-                    end
+                    if O.is_block next_obj then
+                      fprintf ppf ";@ %a" print_conses next_obj
                   in
-                  open_box 1;
-                  print_string "[";
-                  cautious print_conses obj;
-                  print_string "]";
-                  close_box()
+                  fprintf ppf "@[<1>[%a]@]"
+                  (fun ppf obj -> cautious (print_conses ppf) obj) obj
                 end
               end else
-                print_string "[]"
+                fprintf ppf "[]"
           | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
               let length = O.size obj in
               if length = 0 then
-                print_string "[||]"
+                fprintf ppf "[||]"
               else if check_depth depth obj ty then begin
-                let rec print_items i =
+                let rec print_items ppf i =
                   if i < length then begin
-                    if i > 0 then begin print_string ";"; print_space() end;
-                    print_val 0 (depth - 1) (O.field obj i) ty_arg;
-                    print_items (i + 1)
+                    if i > 0 then fprintf ppf ";@ ";
+                    print_val 0 (depth - 1) (O.field obj i) ppf ty_arg;
+                    print_items ppf (i + 1)
                   end in
-                open_box 2;
-                print_string "[|";
-                cautious print_items 0;
-                print_string "|]";
-                close_box()
+                fprintf ppf "@[<2>[|%a|]@]"
+                        (fun ppf i -> cautious (print_items ppf) i) 0;
               end
           | Tconstr(path, ty_list, _) ->
               begin try
                 let decl = Env.find_type path env in
                 match decl with
-                  {type_kind = Type_abstract; type_manifest = None} ->
-                    print_string "<abstr>"
+                | {type_kind = Type_abstract; type_manifest = None} ->
+                    fprintf ppf "<abstr>"
                 | {type_kind = Type_abstract; type_manifest = Some body} ->
-                    print_val prio depth obj
+                    print_val prio depth obj ppf
                       (try Ctype.apply env decl.type_params body ty_list with
                          Ctype.Cannot_apply -> abstract_type)
                 | {type_kind = Type_variant constr_list} ->
@@ -268,108 +246,93 @@ module Make(O : OBJ) = struct
                              Ctype.Cannot_apply -> abstract_type)
                         constr_args in
                     begin match ty_args with
-                      [] ->
-                        print_constr env path constr_name
+                    | [] ->
+                        print_constr env path ppf constr_name
                     | [ty1] ->
-                        if check_depth depth obj ty then begin
-                          if prio > 1
-                          then begin open_box 2; print_string "(" end
-                          else open_box 1;
-                          print_constr env path constr_name;
-                          print_space();
-                          cautious (print_val 2 (depth - 1)
-                                      (O.field obj 0)) ty1;
-                          if prio > 1 then print_string ")";
-                          close_box()
-                        end
+                        if check_depth depth obj ty then
+                          (if prio > 1
+                          then fprintf ppf "@[<2>(%a@ %a)@]"
+                          else fprintf ppf "@[<1>%a@ %a@]")
+                          (print_constr env path) constr_name
+                          (fun ppf ty ->
+                             cautious
+                              (print_val 2 (depth - 1) (O.field obj 0) ppf) ty)
+                          ty1;
                     | tyl ->
-                        if check_depth depth obj ty then begin
-                          if prio > 1
-                          then begin open_box 2; print_string "(" end
-                          else open_box 1;
-                          print_constr env path constr_name;
-                          print_space();
-                          open_box 1;
-                          print_string "(";
-                          print_val_list 1 depth obj tyl;
-                          print_string ")";
-                          close_box();
-                          if prio > 1 then print_string ")";
-                          close_box()
-                        end
+                        if check_depth depth obj ty then
+                          (if prio > 1
+                          then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
+                          else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
+                          (print_constr env path) constr_name
+                          (print_val_list 1 depth obj) tyl;
                     end
                 | {type_kind = Type_record lbl_list} ->
                     if check_depth depth obj ty then begin
-                      let rec print_fields pos = function
-                        [] -> ()
+                      let rec print_fields pos ppf = function
+                      | [] -> ()
                       | (lbl_name, _, lbl_arg) :: remainder ->
-                          if pos > 0 then begin
-                            print_string ";"; print_space()
-                          end;
-                          open_box 1;
-                          print_label env path lbl_name;
-                          print_string "="; print_cut();
                           let ty_arg =
                             try
                               Ctype.apply env decl.type_params lbl_arg ty_list
                             with
-                              Ctype.Cannot_apply -> abstract_type
-                          in
-                          cautious (print_val 0 (depth - 1)
-                                      (O.field obj pos)) ty_arg;
-                          close_box();
-                          print_fields (pos + 1) remainder in
-                      open_box 1;
-                      print_string "{";
-                      cautious (print_fields 0) lbl_list;
-                      print_string "}";
-                      close_box()
+                              Ctype.Cannot_apply -> abstract_type in
+                          if pos > 0 then fprintf ppf ";@ ";
+                          fprintf ppf "@[<1>%a=@,%a@]"
+                          (print_label env path) lbl_name
+                          (fun ppf t ->
+                             cautious (print_val 0 (depth - 1)
+                                      (O.field obj pos) ppf) t) ty_arg;
+                          (print_fields (pos + 1)) ppf remainder in
+
+                      fprintf ppf "@[<1>{%a}@]"
+                      (fun ppf l -> cautious (print_fields 0 ppf) l) lbl_list;
                     end
               with
                 Not_found ->                (* raised by Env.find_type *)
-                  print_string "<abstr>"
+                  fprintf ppf "<abstr>"
               | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
-                  print_string "<unknown constructor>"
+                  fprintf ppf "<unknown constructor>"
               end
           | Tvariant row ->
               let row = Btype.row_repr row in
               if O.is_block obj then begin
                 let tag : int = O.obj (O.field obj 0) in
-                if prio > 1 then (open_box 2; print_char '(');
-                print_char '`';
-                List.iter
-                  (fun (l,f) -> if Btype.hash_variant l = tag then
-                    match Btype.row_field_repr f with
-                      Rpresent(Some ty) ->
-                        print_string l; print_space ();
-                        cautious (print_val 2 (depth - 1) (O.field obj 1)) ty
-                    | _ -> ())
+                (if prio > 1
+                 then fprintf ppf "@[<2>(`%a)@]"
+                 else fprintf ppf "`%a")
+                (fun ppf ->
+                  List.iter
+                   (fun (l, f) -> if Btype.hash_variant l = tag then
+                     match Btype.row_field_repr f with
+                     | Rpresent(Some ty) ->
+                        fprintf ppf "%s@ " l;
+                        cautious (print_val 2 (depth - 1) (O.field obj 1) ppf)ty
+                     | _ -> ()))
                   row.row_fields;
-                if prio >1 then (print_char ')'; close_box ())
               end else begin
                 let tag : int = O.obj obj in
                 print_char '`';
                 List.iter
                   (fun (l,_) ->
-                    if Btype.hash_variant l = tag then print_string l)
+                    if Btype.hash_variant l = tag then fprintf ppf "%s" l)
                   row.row_fields
               end
           | Tobject (_, _) ->
-              print_string "<obj>"
+              fprintf ppf "<obj>"
           | Tsubst ty ->
-              print_val prio (depth - 1) obj ty
+              print_val prio (depth - 1) obj ppf ty
           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
               fatal_error "Printval.print_value"
 
-      and print_val_list prio depth obj ty_list =
+      and print_val_list prio depth obj ppf ty_list =
         let rec print_list i = function
-          [] -> ()
-        | ty :: ty_list ->
-            if i > 0 then begin print_string ","; print_space() end;
-            print_val prio (depth - 1) (O.field obj i) ty;
-            print_list (i + 1) ty_list in
+          |  [] -> ()
+          | ty :: ty_list ->
+              if i > 0 then fprintf ppf ",@ ";
+              print_val prio (depth - 1) (O.field obj i) ppf ty;
+              print_list (i + 1) ty_list in
       cautious (print_list 0) ty_list
 
-    in cautious (print_val 0 max_depth obj) ty
+    in cautious (print_val 0 max_depth obj ppf) ty
 
 end