235 lines
8.1 KiB
OCaml
235 lines
8.1 KiB
OCaml
(* To print values *)
|
|
|
|
open Obj
|
|
open Format
|
|
open Longident
|
|
open Path
|
|
open Typedtree
|
|
|
|
|
|
(* Given an exception value, we cannot recover its type,
|
|
hence we cannot print its arguments in general.
|
|
Here, we do a feeble attempt to print
|
|
integer, string and float arguments... *)
|
|
|
|
let print_exception obj =
|
|
print_string (Obj.magic(Obj.field(Obj.field obj 0) 0) : string);
|
|
if Obj.size obj > 1 then begin
|
|
open_hovbox 1;
|
|
print_string "(";
|
|
for i = 1 to Obj.size obj - 1 do
|
|
if i > 1 then begin print_string ","; print_space() end;
|
|
let arg = Obj.field obj i in
|
|
if not (Obj.is_block arg) then
|
|
print_int(Obj.magic arg : int) (* Note: this could be a char! *)
|
|
else if Obj.tag arg = 253 then begin
|
|
print_string "\"";
|
|
print_string (String.escaped (Obj.magic arg : string));
|
|
print_string "\""
|
|
end else if Obj.tag arg = 254 then
|
|
print_float (Obj.magic arg : float)
|
|
else
|
|
print_string "_"
|
|
done;
|
|
print_string ")";
|
|
close_box()
|
|
end
|
|
|
|
(* Recover a constructor by its tag *)
|
|
|
|
exception Constr_not_found
|
|
|
|
let rec find_constr tag = function
|
|
[] ->
|
|
raise Constr_not_found
|
|
| constr :: rest ->
|
|
if tag = 0 then constr else find_constr (tag - 1) rest
|
|
|
|
(* The user-defined printers. Also used for some builtin types. *)
|
|
|
|
let printers = ref ([
|
|
Pident(Ident.new "print_int"), Predef.type_int,
|
|
(fun x -> print_int (Obj.magic x : int));
|
|
Pident(Ident.new "print_float"), Predef.type_float,
|
|
(fun x -> print_float(Obj.magic x : float));
|
|
Pident(Ident.new "print_char"), Predef.type_char,
|
|
(fun x -> print_string "'";
|
|
print_string (Char.escaped (Obj.magic x : char));
|
|
print_string "'");
|
|
Pident(Ident.new "print_string"), Predef.type_string,
|
|
(fun x -> print_string "\"";
|
|
print_string (String.escaped (Obj.magic x : string));
|
|
print_string "\"")
|
|
] : (Path.t * type_expr * (Obj.t -> unit)) list)
|
|
|
|
let find_printer env ty =
|
|
let rec find = function
|
|
[] -> raise Not_found
|
|
| (name, sch, printer) :: remainder ->
|
|
if Ctype.moregeneral env sch ty
|
|
then printer
|
|
else find remainder
|
|
in find !printers
|
|
|
|
(* Print a constructor or label, giving it the same prefix as the type
|
|
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 =
|
|
match ty_path with
|
|
Pident id ->
|
|
print_string name
|
|
| Pdot(p, s, pos) ->
|
|
if try
|
|
match lookup_fun (Lident name) env with
|
|
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)
|
|
|
|
let print_constr =
|
|
print_qualified (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
|
|
and print_label =
|
|
print_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
|
|
|
|
(* The main printing function *)
|
|
|
|
let max_printer_depth = ref 100
|
|
let max_printer_steps = ref 300
|
|
exception Ellipsis
|
|
|
|
let cautious f arg = try f arg with Ellipsis -> print_string "..."
|
|
|
|
let print_value env obj ty =
|
|
|
|
let printer_steps = ref !max_printer_steps in
|
|
|
|
let rec print_val prio depth obj ty =
|
|
decr printer_steps;
|
|
if !printer_steps < 0 or depth < 0 then raise Ellipsis;
|
|
try
|
|
find_printer env ty obj; ()
|
|
with Not_found ->
|
|
match Ctype.repr ty with
|
|
Tvar _ ->
|
|
print_string "<poly>"
|
|
| Tarrow(ty1, ty2) ->
|
|
print_string "<fun>"
|
|
| Ttuple(ty_list) ->
|
|
if prio > 0
|
|
then begin open_hovbox 1; print_string "(" end
|
|
else open_hovbox 0;
|
|
print_val_list 1 depth obj ty_list;
|
|
if prio > 0 then print_string ")";
|
|
close_box()
|
|
| Tconstr(path, []) when Path.same path Predef.path_exn ->
|
|
if prio > 1
|
|
then begin open_hovbox 2; print_string "(" end
|
|
else open_hovbox 1;
|
|
print_exception obj;
|
|
if prio > 1 then print_string ")";
|
|
close_box()
|
|
| Tconstr(path, [ty_arg]) when Path.same path Predef.path_list ->
|
|
let rec print_conses depth cons =
|
|
if Obj.tag cons != 0 then begin
|
|
print_val 0 (depth - 1) (Obj.field cons 0) ty_arg;
|
|
let next_obj = Obj.field cons 1 in
|
|
if Obj.tag next_obj != 0 then begin
|
|
print_string ";"; print_space();
|
|
print_conses (depth - 1) next_obj
|
|
end
|
|
end in
|
|
open_hovbox 1;
|
|
print_string "[";
|
|
cautious (print_conses depth) obj;
|
|
print_string "]";
|
|
close_box()
|
|
| Tconstr(path, [ty_arg]) when Path.same path Predef.path_array ->
|
|
let rec print_items depth i =
|
|
if i < Obj.size obj then begin
|
|
if i > 0 then begin print_string ";"; print_space() end;
|
|
print_val 0 (depth - 1) (Obj.field obj i) ty_arg;
|
|
print_items (depth - 1) (i + 1)
|
|
end in
|
|
open_hovbox 2;
|
|
print_string "[|";
|
|
cautious (print_items depth) 0;
|
|
print_string "|]";
|
|
close_box()
|
|
| Tconstr(path, ty_list) ->
|
|
let decl = Env.find_type path env in
|
|
match decl.type_kind with
|
|
Type_abstract ->
|
|
print_string "<abstr>"
|
|
| Type_manifest body ->
|
|
print_val prio depth obj
|
|
(Ctype.substitute decl.type_params ty_list body)
|
|
| Type_variant constr_list ->
|
|
let tag = Obj.tag obj in
|
|
begin try
|
|
let (constr_name, constr_args) =
|
|
find_constr tag constr_list in
|
|
let ty_args =
|
|
List.map (Ctype.substitute decl.type_params ty_list)
|
|
constr_args in
|
|
match ty_args with
|
|
[] ->
|
|
print_constr env path constr_name
|
|
| [ty1] ->
|
|
if prio > 1
|
|
then begin open_hovbox 2; print_string "(" end
|
|
else open_hovbox 1;
|
|
print_constr env path constr_name;
|
|
print_space();
|
|
cautious (print_val 2 (depth - 1) (Obj.field obj 0)) ty1;
|
|
if prio > 1 then print_string ")";
|
|
close_box()
|
|
| tyl ->
|
|
if prio > 1
|
|
then begin open_hovbox 2; print_string "(" end
|
|
else open_hovbox 1;
|
|
print_constr env path constr_name;
|
|
print_space();
|
|
open_hovbox 1;
|
|
print_string "(";
|
|
print_val_list 1 depth obj tyl;
|
|
print_string ")";
|
|
close_box();
|
|
if prio > 1 then print_string ")";
|
|
close_box()
|
|
with
|
|
Constr_not_found ->
|
|
print_string "<unknown constructor>"
|
|
end
|
|
| Type_record lbl_list ->
|
|
let rec print_fields depth pos = function
|
|
[] -> ()
|
|
| (lbl_name, _, lbl_arg) :: remainder ->
|
|
if pos > 0 then begin print_string ";"; print_space() end;
|
|
open_hovbox 1;
|
|
print_label env path lbl_name;
|
|
print_string "="; print_cut();
|
|
let ty_arg =
|
|
Ctype.substitute decl.type_params ty_list lbl_arg in
|
|
cautious (print_val 0 (depth - 1) (Obj.field obj pos))
|
|
ty_arg;
|
|
close_box();
|
|
print_fields (depth - 1) (pos + 1) remainder in
|
|
open_hovbox 1;
|
|
print_string "{";
|
|
cautious (print_fields depth 0) lbl_list;
|
|
print_string "}";
|
|
close_box()
|
|
|
|
and print_val_list prio depth obj ty_list =
|
|
let rec print_list depth i = function
|
|
[] -> ()
|
|
| ty :: ty_list ->
|
|
if i > 0 then begin print_string ","; print_space() end;
|
|
print_val prio (depth - 1) (Obj.field obj i) ty;
|
|
print_list (depth - 1) (i + 1) ty_list in
|
|
cautious (print_list depth 0) ty_list
|
|
|
|
in print_val 0 !max_printer_depth obj ty
|