1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
(* 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
|
