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
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* To print values *)
open Misc
open Format
open Longident
open Path
open Types
open Outcometree
module type OBJ =
sig
type t
val obj : t -> 'a
val is_block : t -> bool
val tag : t -> int
val size : t -> int
val field : t -> int -> t
end
module type EVALPATH =
sig
type value
val eval_path: Path.t -> value
exception Error
val same_value: value -> value -> bool
end
module type S =
sig
type t
val install_printer :
Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
val remove_printer : Path.t -> unit
val outval_of_untyped_exception : t -> Outcometree.out_value
val outval_of_value :
int -> int ->
(int -> t -> Types.type_expr -> Outcometree.out_value option) ->
Env.t -> t -> type_expr -> Outcometree.out_value
end
module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
type t = O.t
(* 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 outval_of_untyped_exception_args obj start_offset =
if O.size obj > start_offset then begin
let list = ref [] in
for i = start_offset to O.size obj - 1 do
let arg = O.field obj i in
if not (O.is_block arg) then
list := Oval_int (O.obj arg : int) :: !list
(* Note: this could be a char or a constant constructor... *)
else if O.tag arg = Obj.string_tag then
list :=
Oval_string (String.escaped (O.obj arg : string)) :: !list
else if O.tag arg = Obj.double_tag then
list := Oval_float (O.obj arg : float) :: !list
else
list := Oval_constr (Oide_ident "_", []) :: !list
done;
List.rev !list
end
else []
let outval_of_untyped_exception bucket =
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
let args =
if (name = "Match_failure"
|| name = "Assert_failure"
|| name = "Undefined_recursive_module")
&& O.size bucket = 2
&& O.tag(O.field bucket 1) = 0
then outval_of_untyped_exception_args (O.field bucket 1) 0
else outval_of_untyped_exception_args bucket 1 in
Oval_constr (Oide_ident name, args)
(* The user-defined printers. Also used for some builtin types. *)
let printers = ref ([
Pident(Ident.create "print_int"), Predef.type_int,
(fun x -> Oval_int (O.obj x : int));
Pident(Ident.create "print_float"), Predef.type_float,
(fun x -> Oval_float (O.obj x : float));
Pident(Ident.create "print_char"), Predef.type_char,
(fun x -> Oval_char (O.obj x : char));
Pident(Ident.create "print_string"), Predef.type_string,
(fun x -> Oval_string (O.obj x : string));
Pident(Ident.create "print_int32"), Predef.type_int32,
(fun x -> Oval_int32 (O.obj x : int32));
Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
(fun x -> Oval_nativeint (O.obj x : nativeint));
Pident(Ident.create "print_int64"), Predef.type_int64,
(fun x -> Oval_int64 (O.obj x : int64))
] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
let install_printer path ty fn =
let print_val ppf obj =
try fn ppf obj with
| exn ->
fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
printers := (path, ty, printer) :: !printers
let remove_printer path =
let rec remove = function
| [] -> 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
| (name, sch, printer) :: remainder ->
if Ctype.moregeneral env false 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 tree_of_qualified lookup_fun env ty_path name =
match ty_path with
| Pident id ->
Oide_ident name
| Pdot(p, s, pos) ->
if try
match (lookup_fun (Lident name) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
| _ -> false
with Not_found -> false
then Oide_ident name
else Oide_dot (Printtyp.tree_of_path p, name)
| Papply(p1, p2) ->
Printtyp.tree_of_path ty_path
let tree_of_constr =
tree_of_qualified
(fun lid env -> (Env.lookup_constructor lid env).cstr_res)
and tree_of_label =
tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
(* An abstract type *)
let abstract_type =
Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))
(* The main printing function *)
let outval_of_value max_steps max_depth check_depth env obj ty =
let printer_steps = ref max_steps in
let rec tree_of_val depth obj ty =
decr printer_steps;
if !printer_steps < 0 || depth < 0 then Oval_ellipsis
else begin
try
find_printer env ty obj
with Not_found ->
match (Ctype.repr ty).desc with
| Tvar _ | Tunivar _ ->
Oval_stuff "<poly>"
| Tarrow(_, ty1, ty2, _) ->
Oval_stuff "<fun>"
| Ttuple(ty_list) ->
Oval_tuple (tree_of_val_list 0 depth obj ty_list)
| Tconstr(path, [], _) when Path.same path Predef.path_exn ->
tree_of_exception depth obj
| Tconstr(path, [ty_arg], _)
when Path.same path Predef.path_list ->
if O.is_block obj then
match check_depth depth obj ty with
Some x -> x
| None ->
let rec tree_of_conses tree_list obj =
if !printer_steps < 0 || depth < 0 then
Oval_ellipsis :: tree_list
else if O.is_block obj then
let tree =
tree_of_val (depth - 1) (O.field obj 0) ty_arg in
let next_obj = O.field obj 1 in
tree_of_conses (tree :: tree_list) next_obj
else tree_list
in
Oval_list (List.rev (tree_of_conses [] obj))
else
Oval_list []
| Tconstr(path, [ty_arg], _)
when Path.same path Predef.path_array ->
let length = O.size obj in
if length > 0 then
match check_depth depth obj ty with
Some x -> x
| None ->
let rec tree_of_items tree_list i =
if !printer_steps < 0 || depth < 0 then
Oval_ellipsis :: tree_list
else if i < length then
let tree =
tree_of_val (depth - 1) (O.field obj i) ty_arg in
tree_of_items (tree :: tree_list) (i + 1)
else tree_list
in
Oval_array (List.rev (tree_of_items [] 0))
else
Oval_array []
| Tconstr (path, [ty_arg], _)
when Path.same path Predef.path_lazy_t ->
if Lazy.lazy_is_val (O.obj obj)
then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
Oval_constr (Oide_ident "lazy", [v])
else Oval_stuff "<lazy>"
| Tconstr(path, ty_list, _) ->
begin try
let decl = Env.find_type path env in
match decl with
| {type_kind = Type_abstract; type_manifest = None} ->
Oval_stuff "<abstr>"
| {type_kind = Type_abstract; type_manifest = Some body} ->
tree_of_val depth obj
(try Ctype.apply env decl.type_params body ty_list with
Ctype.Cannot_apply -> abstract_type)
| {type_kind = Type_variant constr_list} ->
let tag =
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
let (constr_name, constr_args,ret_type) =
Datarepr.find_constr_by_tag tag constr_list in
let type_params =
match ret_type with
Some t ->
begin match (Ctype.repr t).desc with
Tconstr (_,params,_) ->
params
| _ -> assert false end
| None -> decl.type_params
in
let ty_args =
List.map
(function ty ->
try Ctype.apply env type_params ty ty_list with
Ctype.Cannot_apply -> abstract_type)
constr_args in
tree_of_constr_with_args (tree_of_constr env path)
constr_name 0 depth obj ty_args
| {type_kind = Type_record(lbl_list, rep)} ->
begin match check_depth depth obj ty with
Some x -> x
| None ->
let rec tree_of_fields pos = function
| [] -> []
| (lbl_name, _, lbl_arg) :: remainder ->
let ty_arg =
try
Ctype.apply env decl.type_params lbl_arg
ty_list
with
Ctype.Cannot_apply -> abstract_type in
let lid = tree_of_label env path lbl_name in
let v =
tree_of_val (depth - 1) (O.field obj pos)
ty_arg
in
(lid, v) :: tree_of_fields (pos + 1) remainder
in
Oval_record (tree_of_fields 0 lbl_list)
end
with
Not_found -> (* raised by Env.find_type *)
Oval_stuff "<abstr>"
| Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
Oval_stuff "<unknown constructor>"
end
| Tvariant row ->
let row = Btype.row_repr row in
if O.is_block obj then
let tag : int = O.obj (O.field obj 0) in
let rec find = function
| (l, f) :: fields ->
if Btype.hash_variant l = tag then
match Btype.row_field_repr f with
| Rpresent(Some ty) | Reither(_,[ty],_,_) ->
let args =
tree_of_val (depth - 1) (O.field obj 1) ty in
Oval_variant (l, Some args)
| _ -> find fields
else find fields
| [] -> Oval_stuff "<variant>" in
find row.row_fields
else
let tag : int = O.obj obj in
let rec find = function
| (l, _) :: fields ->
if Btype.hash_variant l = tag then
Oval_variant (l, None)
else find fields
| [] -> Oval_stuff "<variant>" in
find row.row_fields
| Tobject (_, _) ->
Oval_stuff "<obj>"
| Tsubst ty ->
tree_of_val (depth - 1) obj ty
| Tfield(_, _, _, _) | Tnil | Tlink _ ->
fatal_error "Printval.outval_of_value"
| Tpoly (ty, _) ->
tree_of_val (depth - 1) obj ty
| Tproc _ -> assert false
| Tpackage _ ->
Oval_stuff "<module>"
end
and tree_of_val_list start depth obj ty_list =
let rec tree_list i = function
| [] -> []
| ty :: ty_list ->
let tree = tree_of_val (depth - 1) (O.field obj i) ty in
tree :: tree_list (i + 1) ty_list in
tree_list start ty_list
and tree_of_constr_with_args
tree_of_cstr cstr_name start depth obj ty_args =
let lid = tree_of_cstr cstr_name in
let args = tree_of_val_list start depth obj ty_args in
Oval_constr (lid, args)
and tree_of_exception depth bucket =
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
let lid = Longident.parse name in
try
(* Attempt to recover the constructor description for the exn
from its name *)
let cstr = Env.lookup_constructor lid env in
let path =
match cstr.cstr_tag with
Cstr_exception (p, _) -> p | _ -> raise Not_found in
(* Make sure this is the right exception and not an homonym,
by evaluating the exception found and comparing with the
identifier contained in the exception bucket *)
if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
then raise Not_found;
tree_of_constr_with_args
(fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
with Not_found | EVP.Error ->
match check_depth depth bucket ty with
Some x -> x
| None -> outval_of_untyped_exception bucket
in tree_of_val max_depth obj ty
end
|