Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
951 lines (797 sloc) 23.1 KB
open Printf
open Bi_outbuf
open Bi_inbuf
type node_tag = int
let bool_tag = 0
let int8_tag = 1
let int16_tag = 2
let int32_tag = 3
let int64_tag = 4
let float32_tag = 11
let float64_tag = 12
let uvint_tag = 16
let svint_tag = 17
let string_tag = 18
let array_tag = 19
let tuple_tag = 20
let record_tag = 21
let num_variant_tag = 22
let variant_tag = 23
let unit_tag = 24
let table_tag = 25
let shared_tag = 26
type hash = int
(*
Data tree, for testing purposes.
*)
type tree =
[ `Unit
| `Bool of bool
| `Int8 of char
| `Int16 of int
| `Int32 of Int32.t
| `Int64 of Int64.t
| `Float32 of float
| `Float64 of float
| `Uvint of int
| `Svint of int
| `String of string
| `Array of (node_tag * tree array) option
| `Tuple of tree array
| `Record of (string option * hash * tree) array
| `Num_variant of (int * tree option)
| `Variant of (string option * hash * tree option)
| `Table of
((string option * hash * node_tag) array * tree array array) option
| `Shared of tree ]
(* extend sign bit *)
let make_signed x =
if x > 0x3FFFFFFF then x - (1 lsl 31) else x
(*
Same function as the one used for OCaml variants and object methods.
*)
let hash_name s =
let accu = ref 0 in
for i = 0 to String.length s - 1 do
accu := 223 * !accu + Char.code s.[i]
done;
(* reduce to 31 bits *)
accu := !accu land (1 lsl 31 - 1);
(* make it signed for 64 bits architectures *)
make_signed !accu
(*
Structure of a hashtag: 4 bytes,
argbit 7bits 8bits 8bits 8bits
+---------------------+
31-bit hash
argbit = 1 iff hashtag is followed by an argument, this is always 1 for
record fields.
*)
let write_hashtag ob h has_arg =
let h = h land 0x7fffffff in
let pos = Bi_outbuf.alloc ob 4 in
let s = ob.o_s in
String.unsafe_set s (pos+3) (Char.chr (h land 0xff));
let h = h lsr 8 in
String.unsafe_set s (pos+2) (Char.chr (h land 0xff));
let h = h lsr 8 in
String.unsafe_set s (pos+1) (Char.chr (h land 0xff));
let h = h lsr 8 in
String.unsafe_set s pos (
Char.chr (
if has_arg then h lor 0x80
else h
)
)
let string_of_hashtag h has_arg =
let ob = Bi_outbuf.create 4 in
write_hashtag ob h has_arg;
Bi_outbuf.contents ob
let read_hashtag ib cont =
let i = Bi_inbuf.read ib 4 in
let s = ib.i_s in
let x0 = Char.code s.[i] in
let has_arg = x0 >= 0x80 in
let x1 = (x0 land 0x7f) lsl 24 in
let x2 = (Char.code s.[i+1]) lsl 16 in
let x3 = (Char.code s.[i+2]) lsl 8 in
let x4 = Char.code s.[i+3] in
let h = make_signed (x1 lor x2 lor x3 lor x4) in
cont ib h has_arg
let read_field_hashtag ib =
let i = Bi_inbuf.read ib 4 in
let s = ib.i_s in
let x0 = Char.code (String.unsafe_get s i) in
if x0 < 0x80 then
Bi_util.error "Corrupted data (invalid field hashtag)";
let x1 = (x0 land 0x7f) lsl 24 in
let x2 = (Char.code (String.unsafe_get s (i+1))) lsl 16 in
let x3 = (Char.code (String.unsafe_get s (i+2))) lsl 8 in
let x4 = Char.code (String.unsafe_get s (i+3)) in
make_signed (x1 lor x2 lor x3 lor x4)
type int7 = int
let write_numtag ob i has_arg =
if i < 0 || i > 0x7f then
Bi_util.error "Corrupted data (invalid numtag)";
let x =
if has_arg then i lor 0x80
else i
in
Bi_outbuf.add_char ob (Char.chr x)
let read_numtag ib cont =
let i = Bi_inbuf.read ib 1 in
let x = Char.code ib.i_s.[i] in
let has_arg = x >= 0x80 in
cont ib (x land 0x7f) has_arg
let make_unhash l =
let tbl = Hashtbl.create (4 * List.length l) in
List.iter (
fun s ->
let h = hash_name s in
try
match Hashtbl.find tbl h with
Some s' ->
if s <> s' then
failwith (
sprintf
"Bi_io.make_unhash: \
%S and %S have the same hash, please pick another name"
s s'
)
| None -> assert false
with Not_found -> Hashtbl.add tbl h (Some s)
) l;
fun h ->
try Hashtbl.find tbl h
with Not_found -> None
let write_tag ob x =
Bi_outbuf.add_char ob (Char.chr x)
let write_untagged_unit ob () =
Bi_outbuf.add_char ob '\x00'
let write_untagged_bool ob x =
Bi_outbuf.add_char ob (if x then '\x01' else '\x00')
let write_untagged_char ob x =
Bi_outbuf.add_char ob x
let write_untagged_int8 ob x =
Bi_outbuf.add_char ob (Char.chr x)
let write_untagged_int16 ob x =
Bi_outbuf.add_char ob (Char.chr (x lsr 8));
Bi_outbuf.add_char ob (Char.chr (x land 0xff))
let write_untagged_int32 ob x =
let high = Int32.to_int (Int32.shift_right_logical x 16) in
Bi_outbuf.add_char ob (Char.chr (high lsr 8));
Bi_outbuf.add_char ob (Char.chr (high land 0xff));
let low = Int32.to_int x in
Bi_outbuf.add_char ob (Char.chr ((low lsr 8) land 0xff));
Bi_outbuf.add_char ob (Char.chr (low land 0xff))
let write_untagged_float32 ob x =
write_untagged_int32 ob (Int32.bits_of_float x)
let float_endianness = lazy (
match String.unsafe_get (Obj.magic 1.0) 0 with
'\x3f' -> `Big
| '\x00' -> `Little
| _ -> assert false
)
let read_untagged_float64 ib =
let i = Bi_inbuf.read ib 8 in
let s = ib.i_s in
let x = Obj.new_block Obj.double_tag 8 in
(match Lazy.force float_endianness with
`Little ->
for j = 0 to 7 do
String.unsafe_set (Obj.obj x) (7-j) (String.unsafe_get s (i+j))
done
| `Big ->
for j = 0 to 7 do
String.unsafe_set (Obj.obj x) j (String.unsafe_get s (i+j))
done
);
(Obj.obj x : float)
let write_untagged_float64 ob x =
let i = Bi_outbuf.alloc ob 8 in
let s = ob.o_s in
(match Lazy.force float_endianness with
`Little ->
for j = 0 to 7 do
String.unsafe_set s (i+j) (String.unsafe_get (Obj.magic x) (7-j))
done
| `Big ->
for j = 0 to 7 do
String.unsafe_set s (i+j) (String.unsafe_get (Obj.magic x) j)
done
)
(*
let write_untagged_int64 ob x =
let x4 = Int64.to_int (Int64.shift_right_logical x 48) in
Bi_outbuf.add_char ob (Char.chr (x4 lsr 8));
Bi_outbuf.add_char ob (Char.chr (x4 land 0xff));
let x3 = Int64.to_int (Int64.shift_right_logical x 32) in
Bi_outbuf.add_char ob (Char.chr ((x3 lsr 8) land 0xff));
Bi_outbuf.add_char ob (Char.chr (x3 land 0xff));
let x2 = Int64.to_int (Int64.shift_right_logical x 16) in
Bi_outbuf.add_char ob (Char.chr ((x2 lsr 8) land 0xff));
Bi_outbuf.add_char ob (Char.chr (x2 land 0xff));
let x1 = Int64.to_int x in
Bi_outbuf.add_char ob (Char.chr ((x1 lsr 8) land 0xff));
Bi_outbuf.add_char ob (Char.chr (x1 land 0xff))
*)
let write_untagged_int64 ob x =
write_untagged_float64 ob (Int64.float_of_bits x)
let safety_test () =
let s = "\x3f\xf0\x06\x05\x04\x03\x02\x01" in
let x = 1.00146962706651288 in
let y = read_untagged_float64 (Bi_inbuf.from_string s) in
if x <> y then
assert false;
let ob = Bi_outbuf.create 8 in
write_untagged_float64 ob x;
if Bi_outbuf.contents ob <> s then
assert false
let write_untagged_string ob s =
Bi_vint.write_uvint ob (String.length s);
Bi_outbuf.add_string ob s
let write_untagged_uvint = Bi_vint.write_uvint
let write_untagged_svint = Bi_vint.write_svint
let write_unit ob () =
write_tag ob unit_tag;
write_untagged_unit ob ()
let write_bool ob x =
write_tag ob bool_tag;
write_untagged_bool ob x
let write_char ob x =
write_tag ob int8_tag;
write_untagged_char ob x
let write_int8 ob x =
write_tag ob int8_tag;
write_untagged_int8 ob x
let write_int16 ob x =
write_tag ob int16_tag;
write_untagged_int16 ob x
let write_int32 ob x =
write_tag ob int32_tag;
write_untagged_int32 ob x
let write_int64 ob x =
write_tag ob int64_tag;
write_untagged_int64 ob x
let write_float32 ob x =
write_tag ob float32_tag;
write_untagged_float32 ob x
let write_float64 ob x =
write_tag ob float64_tag;
write_untagged_float64 ob x
let write_string ob x =
write_tag ob string_tag;
write_untagged_string ob x
let write_uvint ob x =
write_tag ob uvint_tag;
write_untagged_uvint ob x
let write_svint ob x =
write_tag ob svint_tag;
write_untagged_svint ob x
let rec write_t ob tagged (x : tree) =
match x with
`Unit ->
if tagged then
write_tag ob unit_tag;
write_untagged_unit ob ()
| `Bool x ->
if tagged then
write_tag ob bool_tag;
write_untagged_bool ob x
| `Int8 x ->
if tagged then
write_tag ob int8_tag;
write_untagged_char ob x
| `Int16 x ->
if tagged then
write_tag ob int16_tag;
write_untagged_int16 ob x
| `Int32 x ->
if tagged then
write_tag ob int32_tag;
write_untagged_int32 ob x
| `Int64 x ->
if tagged then
write_tag ob int64_tag;
write_untagged_int64 ob x
| `Float32 x ->
if tagged then
write_tag ob float32_tag;
write_untagged_float32 ob x
| `Float64 x ->
if tagged then
write_tag ob float64_tag;
write_untagged_float64 ob x
| `Uvint x ->
if tagged then
write_tag ob uvint_tag;
Bi_vint.write_uvint ob x
| `Svint x ->
if tagged then
write_tag ob svint_tag;
Bi_vint.write_svint ob x
| `String s ->
if tagged then
write_tag ob string_tag;
write_untagged_string ob s
| `Array o ->
if tagged then
write_tag ob array_tag;
(match o with
None -> Bi_vint.write_uvint ob 0
| Some (node_tag, a) ->
let len = Array.length a in
Bi_vint.write_uvint ob len;
if len > 0 then (
write_tag ob node_tag;
Array.iter (write_t ob false) a
)
)
| `Tuple a ->
if tagged then
write_tag ob tuple_tag;
Bi_vint.write_uvint ob (Array.length a);
Array.iter (write_t ob true) a
| `Record a ->
if tagged then
write_tag ob record_tag;
Bi_vint.write_uvint ob (Array.length a);
Array.iter (write_field ob) a
| `Num_variant (i, x) ->
if tagged then
write_tag ob num_variant_tag;
write_numtag ob i (x <> None);
(match x with
None -> ()
| Some v -> write_t ob true v)
| `Variant (o, h, x) ->
if tagged then
write_tag ob variant_tag;
write_hashtag ob h (x <> None);
(match x with
None -> ()
| Some v -> write_t ob true v)
| `Table o ->
if tagged then
write_tag ob table_tag;
(match o with
None -> Bi_vint.write_uvint ob 0
| Some (fields, a) ->
let row_num = Array.length a in
Bi_vint.write_uvint ob row_num;
if row_num > 0 then
let col_num = Array.length fields in
Bi_vint.write_uvint ob col_num;
Array.iter (
fun (name, h, tag) ->
write_hashtag ob h true;
write_tag ob tag
) fields;
if row_num > 0 then (
for i = 0 to row_num - 1 do
let ai = a.(i) in
if Array.length ai <> col_num then
invalid_arg "Bi_io.write_t: Malformed `Table";
for j = 0 to col_num - 1 do
write_t ob false ai.(j)
done
done
)
)
| `Shared x ->
if tagged then
write_tag ob shared_tag;
let offset =
Bi_share.Wr.put ob.o_shared
(x, Bi_share.dummy_type_id) (ob.o_offs + ob.o_len) in
Bi_vint.write_uvint ob offset;
if offset = 0 then
write_t ob true x
and write_field ob (s, h, x) =
write_hashtag ob h true;
write_t ob true x
let write_tree ob x =
write_t ob true x
let string_of_tree x =
let ob = Bi_outbuf.create 1000 in
write_tree ob x;
Bi_outbuf.contents ob
let tag_of_tree (x : tree) =
match x with
`Unit -> unit_tag
| `Bool _ -> bool_tag
| `Int8 _ -> int8_tag
| `Int16 _ -> int16_tag
| `Int32 _ -> int32_tag
| `Int64 _ -> int64_tag
| `Float32 _ -> float32_tag
| `Float64 _ -> float64_tag
| `Uvint _ -> uvint_tag
| `Svint _ -> svint_tag
| `String _ -> string_tag
| `Array _ -> array_tag
| `Tuple _ -> tuple_tag
| `Record _ -> record_tag
| `Num_variant _ -> num_variant_tag
| `Variant _ -> variant_tag
| `Table _ -> table_tag
| `Shared _ -> shared_tag
let read_tag ib =
Char.code (Bi_inbuf.read_char ib)
let read_untagged_unit ib =
match Bi_inbuf.read_char ib with
'\x00' -> ()
| _ -> Bi_util.error "Corrupted data (unit value)"
let read_untagged_bool ib =
match Bi_inbuf.read_char ib with
'\x00' -> false
| '\x01' -> true
| _ -> Bi_util.error "Corrupted data (bool value)"
let read_untagged_char ib = Bi_inbuf.read_char ib
let read_untagged_int8 ib =
Char.code (Bi_inbuf.read_char ib)
let read_untagged_int16 ib =
let i = Bi_inbuf.read ib 2 in
let s = ib.i_s in
((Char.code s.[i]) lsl 8) lor (Char.code s.[i+1])
let read_untagged_int32 ib =
let i = Bi_inbuf.read ib 4 in
let s = ib.i_s in
let x1 =
Int32.of_int (((Char.code s.[i ]) lsl 8) lor (Char.code s.[i+1])) in
let x2 =
Int32.of_int (((Char.code s.[i+2]) lsl 8) lor (Char.code s.[i+3])) in
Int32.logor (Int32.shift_left x1 16) x2
let read_untagged_float32 ib =
Int32.float_of_bits (read_untagged_int32 ib)
(*
let read_untagged_int64 ib =
let i = Bi_inbuf.read ib 8 in
let s = ib.i_s in
let x1 =
Int64.of_int (((Char.code s.[i ]) lsl 8) lor (Char.code s.[i+1])) in
let x2 =
Int64.of_int (((Char.code s.[i+2]) lsl 8) lor (Char.code s.[i+3])) in
let x3 =
Int64.of_int (((Char.code s.[i+4]) lsl 8) lor (Char.code s.[i+5])) in
let x4 =
Int64.of_int (((Char.code s.[i+6]) lsl 8) lor (Char.code s.[i+7])) in
Int64.logor (Int64.shift_left x1 48)
(Int64.logor (Int64.shift_left x2 32)
(Int64.logor (Int64.shift_left x3 16) x4))
*)
let read_untagged_int64 ib =
Int64.bits_of_float (read_untagged_float64 ib)
let read_untagged_string ib =
let len = Bi_vint.read_uvint ib in
let str = String.create len in
let pos = ref 0 in
let rem = ref len in
while !rem > 0 do
let bytes_read = Bi_inbuf.try_preread ib !rem in
if bytes_read = 0 then
Bi_util.error "Corrupted data (string)"
else (
String.blit ib.i_s ib.i_pos str !pos bytes_read;
ib.i_pos <- ib.i_pos + bytes_read;
pos := !pos + bytes_read;
rem := !rem - bytes_read
)
done;
str
let read_untagged_uvint = Bi_vint.read_uvint
let read_untagged_svint = Bi_vint.read_svint
let read_unit ib = read_untagged_unit ib; `Unit
let read_bool ib = `Bool (read_untagged_bool ib)
let read_int8 ib = `Int8 (read_untagged_char ib)
let read_int16 ib = `Int16 (read_untagged_int16 ib)
let read_int32 ib = `Int32 (read_untagged_int32 ib)
let read_int64 ib = `Int64 (read_untagged_int64 ib)
let read_float32 ib =
`Float32 (read_untagged_float32 ib)
let read_float64 ib =
`Float64 (read_untagged_float64 ib)
let read_uvint ib = `Uvint (read_untagged_uvint ib)
let read_svint ib = `Svint (read_untagged_svint ib)
let read_string ib = `String (read_untagged_string ib)
let print s = print_string s; print_newline ()
let read_tree ?(unhash = make_unhash []) ib : tree =
let rec read_array ib =
let len = Bi_vint.read_uvint ib in
if len = 0 then `Array None
else
let tag = read_tag ib in
let read = reader_of_tag tag in
`Array (Some (tag, Array.init len (fun _ -> read ib)))
and read_tuple ib =
let len = Bi_vint.read_uvint ib in
`Tuple (Array.init len (fun _ -> read_tree ib))
and read_field ib =
let h = read_field_hashtag ib in
let name = unhash h in
let x = read_tree ib in
(name, h, x)
and read_record ib =
let len = Bi_vint.read_uvint ib in
`Record (Array.init len (fun _ -> read_field ib))
and read_num_variant_cont ib i has_arg =
let x =
if has_arg then
Some (read_tree ib)
else
None
in
`Num_variant (i, x)
and read_num_variant ib =
read_numtag ib read_num_variant_cont
and read_variant_cont ib h has_arg =
let name = unhash h in
let x =
if has_arg then
Some (read_tree ib)
else
None
in
`Variant (name, h, x)
and read_variant ib =
read_hashtag ib read_variant_cont
and read_table ib =
let row_num = Bi_vint.read_uvint ib in
if row_num = 0 then
`Table None
else
let col_num = Bi_vint.read_uvint ib in
let fields =
Array.init col_num (
fun _ ->
let h = read_field_hashtag ib in
let name = unhash h in
let tag = read_tag ib in
(name, h, tag)
)
in
let readers =
Array.map (fun (name, h, tag) -> reader_of_tag tag) fields in
let a =
Array.init row_num
(fun _ ->
Array.init col_num (fun j -> readers.(j) ib))
in
`Table (Some (fields, a))
and read_shared ib =
let pos = ib.i_offs + ib.i_pos in
let offset = Bi_vint.read_uvint ib in
if offset = 0 then
let rec r = `Shared r in
Bi_share.Rd.put ib.i_shared
(pos, Bi_share.dummy_type_id) (Obj.repr r);
let x = read_tree ib in
Obj.set_field (Obj.repr r) 1 (Obj.repr x);
r
else
Obj.obj (Bi_share.Rd.get ib.i_shared
(pos - offset, Bi_share.dummy_type_id))
and reader_of_tag = function
0 (* bool *) -> read_bool
| 1 (* int8 *) -> read_int8
| 2 (* int16 *) -> read_int16
| 3 (* int32 *) -> read_int32
| 4 (* int64 *) -> read_int64
| 11 (* float32 *) -> read_float32
| 12 (* float64 *) -> read_float64
| 16 (* uvint *) -> read_uvint
| 17 (* svint *) -> read_svint
| 18 (* string *) -> read_string
| 19 (* array *) -> read_array
| 20 (* tuple *) -> read_tuple
| 21 (* record *) -> read_record
| 22 (* num_variant *) -> read_num_variant
| 23 (* variant *) -> read_variant
| 24 (* unit *) -> read_unit
| 25 (* table *) -> read_table
| 26 (* shared *) -> read_shared
| _ -> Bi_util.error "Corrupted data (invalid tag)"
and read_tree ib : tree =
reader_of_tag (read_tag ib) ib
in
read_tree ib
let tree_of_string ?unhash s = read_tree ?unhash (Bi_inbuf.from_string s)
let skip_bytes ib n = ignore (Bi_inbuf.read ib n)
let skip_unit ib = skip_bytes ib 1
let skip_bool ib = skip_bytes ib 1
let skip_int8 ib = skip_bytes ib 1
let skip_int16 ib = skip_bytes ib 2
let skip_int32 ib = skip_bytes ib 4
let skip_int64 ib = skip_bytes ib 8
let skip_float32 ib = skip_bytes ib 4
let skip_float64 ib = skip_bytes ib 8
let skip_uvint ib = ignore (read_untagged_uvint ib)
let skip_svint ib = ignore (read_untagged_svint ib)
let skip_string ib =
let len = Bi_vint.read_uvint ib in
skip_bytes ib len
let rec skip_array ib =
let len = Bi_vint.read_uvint ib in
if len = 0 then ()
else
let tag = read_tag ib in
let read = skipper_of_tag tag in
for i = 1 to len do
read ib
done
and skip_tuple ib =
let len = Bi_vint.read_uvint ib in
for i = 1 to len do
skip ib
done
and skip_field ib =
ignore (read_field_hashtag ib);
skip ib
and skip_record ib =
let len = Bi_vint.read_uvint ib in
for i = 1 to len do
skip_field ib
done
and skip_num_variant_cont ib i has_arg =
if has_arg then
skip ib
and skip_num_variant ib =
read_numtag ib skip_num_variant_cont
and skip_variant_cont ib h has_arg =
if has_arg then
skip ib
and skip_variant ib =
read_hashtag ib skip_variant_cont
and skip_table ib =
let row_num = Bi_vint.read_uvint ib in
if row_num = 0 then
()
else
let col_num = Bi_vint.read_uvint ib in
let readers =
Array.init col_num (
fun _ ->
ignore (read_field_hashtag ib);
skipper_of_tag (read_tag ib)
)
in
for i = 1 to row_num do
for j = 1 to col_num do
readers.(j) ib
done
done
and skipper_of_tag = function
0 (* bool *) -> skip_bool
| 1 (* int8 *) -> skip_int8
| 2 (* int16 *) -> skip_int16
| 3 (* int32 *) -> skip_int32
| 4 (* int64 *) -> skip_int64
| 11 (* float32 *) -> skip_float32
| 12 (* float64 *) -> skip_float64
| 16 (* uvint *) -> skip_uvint
| 17 (* svint *) -> skip_svint
| 18 (* string *) -> skip_string
| 19 (* array *) -> skip_array
| 20 (* tuple *) -> skip_tuple
| 21 (* record *) -> skip_record
| 22 (* num_variant *) -> skip_num_variant
| 23 (* variant *) -> skip_variant
| 24 (* unit *) -> skip_unit
| 25 (* table *) -> skip_table
| _ -> Bi_util.error "Corrupted data (invalid tag)"
and skip ib : unit =
skipper_of_tag (read_tag ib) ib
(* Equivalent of Array.map that guarantees a left-to-right order *)
let array_map f a =
let len = Array.length a in
if len = 0 then [||]
else (
let r = Array.make len (f (Array.unsafe_get a 0)) in
for i = 1 to len - 1 do
Array.unsafe_set r i (f (Array.unsafe_get a i))
done;
r
)
module Pp =
struct
open Easy_format
let array = list
let record = list
let tuple = { list with
space_after_opening = false;
space_before_closing = false;
align_closing = false }
let variant = { list with
separators_stick_left = true }
let map f a = Array.to_list (array_map f a)
let rec format shared (x : tree) =
match x with
`Unit -> Atom ("unit", atom)
| `Bool x -> Atom ((if x then "true" else "false"), atom)
| `Int8 x -> Atom (sprintf "0x%02x" (Char.code x), atom)
| `Int16 x -> Atom (sprintf "0x%04x" x, atom)
| `Int32 x -> Atom (sprintf "0x%08lx" x, atom)
| `Int64 x -> Atom (sprintf "0x%016Lx" x, atom)
| `Float32 x -> Atom (string_of_float x, atom)
| `Float64 x -> Atom (string_of_float x, atom)
| `Uvint x -> Atom (string_of_int x, atom)
| `Svint x -> Atom (string_of_int x, atom)
| `String s -> Atom (sprintf "%S" s, atom)
| `Array None -> Atom ("[]", atom)
| `Array (Some (_, a)) ->
List (("[", ",", "]", array), map (format shared) a)
| `Tuple a -> List (("(", ",", ")", tuple), map (format shared) a)
| `Record a -> List (("{", ",", "}", record), map (format_field shared) a)
| `Num_variant (i, o) ->
let suffix =
if i = 0 then ""
else string_of_int i
in
(match o with
None -> Atom ("None" ^ suffix, atom)
| Some x ->
let cons = Atom ("Some" ^ suffix, atom) in
Label ((cons, label), format shared x))
| `Variant (opt_name, h, o) ->
let name =
match opt_name with
None -> sprintf "#%08lx" (Int32.of_int h)
| Some s -> sprintf "%S" s
in
(match o with
None -> Atom ("<" ^ name ^ ">", atom)
| Some x ->
List (("<", "", ">", tuple),
[ Label ((Atom (name ^ ":", atom), label),
format shared x) ])
)
| `Table None -> Atom ("[]", atom)
| `Table (Some (header, aa)) ->
let record_array =
`Array (
Some (
record_tag,
Array.map (
fun a ->
`Record (
Array.mapi (
fun i x ->
let s, h, _ = header.(i) in
(s, h, x)
) a
)
) aa
)
) in
format shared record_array
| `Shared x ->
let tbl, p = shared in
incr p;
let pos = !p in
let offset = Bi_share.Wr.put tbl (x, Bi_share.dummy_type_id) pos in
if offset = 0 then
Label ((Atom (sprintf "shared%i ->" pos, atom), label),
format shared x)
else
Atom (sprintf "shared%i" (pos - offset), atom)
and format_field shared (o, h, x) =
let s =
match o with
None -> sprintf "#%08lx" (Int32.of_int h)
| Some s -> sprintf "%S" s
in
Label ((Atom (sprintf "%s:" s, atom), label), format shared x)
end
let init () = (Bi_share.Wr.create 512, ref 0)
let view_of_tree t =
Easy_format.Pretty.to_string (Pp.format (init ()) t)
let print_view_of_tree t =
Easy_format.Pretty.to_stdout (Pp.format (init ()) t)
let output_view_of_tree oc t =
Easy_format.Pretty.to_channel oc (Pp.format (init ()) t)
let view ?unhash s =
view_of_tree (tree_of_string ?unhash s)
let print_view ?unhash s =
print_view_of_tree (tree_of_string ?unhash s)
let output_view ?unhash oc s =
output_view_of_tree oc (tree_of_string ?unhash s)
Something went wrong with that request. Please try again.