From c58a528be89071e77edf62dda9c42f55c84a8c29 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 26 Aug 2024 14:10:19 +0200 Subject: [PATCH] Runtime: implement Json output for Wasm (#1660) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon Co-authored-by: Hugo Heuzard --- lib/js_of_ocaml/js_of_ocaml_stubs.c | 4 + lib/js_of_ocaml/json.ml | 116 +++++++++++++++++++++++++++- lib/js_of_ocaml/json.mli | 13 ++++ lib/tests/test_json.ml | 38 +++++---- runtime/obj.js | 6 ++ 5 files changed, 162 insertions(+), 15 deletions(-) diff --git a/lib/js_of_ocaml/js_of_ocaml_stubs.c b/lib/js_of_ocaml/js_of_ocaml_stubs.c index 36f5cf8bfa..292c88f081 100644 --- a/lib/js_of_ocaml/js_of_ocaml_stubs.c +++ b/lib/js_of_ocaml/js_of_ocaml_stubs.c @@ -4,6 +4,10 @@ void caml_bytes_of_array () { caml_fatal_error("Unimplemented Javascript primitive caml_bytes_of_array!"); } +void caml_custom_identifier () { + caml_fatal_error("Unimplemented Javascript primitive caml_custom_identifier!"); +} + void caml_js_error_of_exception () { caml_fatal_error("Unimplemented Javascript primitive caml_js_error_of_exception!"); } diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 4447897e09..fb525fb321 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -20,6 +20,93 @@ open Js open! Import +(****) + +(* The writing logic for basic types is copied from [lib/deriving_json]. *) + +let write_string buffer s = + Buffer.add_char buffer '"'; + for i = 0 to String.length s - 1 do + match s.[i] with + | '"' -> Buffer.add_string buffer {|\"|} + | '\\' -> Buffer.add_string buffer {|\\|} + | '\b' -> Buffer.add_string buffer {|\b|} + | '\x0C' -> Buffer.add_string buffer {|\f|} + | '\n' -> Buffer.add_string buffer {|\n|} + | '\r' -> Buffer.add_string buffer {|\r|} + | '\t' -> Buffer.add_string buffer {|\t|} + | c when Poly.(c <= '\x1F') -> + (* Other control characters are escaped. *) + Printf.bprintf buffer {|\u%04X|} (int_of_char c) + | c when Poly.(c < '\x80') -> Buffer.add_char buffer s.[i] + | _c (* >= '\x80' *) -> + (* Bytes greater than 127 are embedded in a UTF-8 sequence. *) + Buffer.add_char buffer (Char.chr (0xC2 lor (Char.code s.[i] lsr 6))); + Buffer.add_char buffer (Char.chr (0x80 lor (Char.code s.[i] land 0x3F))) + done; + Buffer.add_char buffer '"' + +let write_float buffer f = + (* "%.15g" can be (much) shorter; "%.17g" is round-trippable *) + let s = Printf.sprintf "%.15g" f in + if Poly.(float_of_string s = f) + then Buffer.add_string buffer s + else Printf.bprintf buffer "%.17g" f + +let write_int64 buffer i = + let mask16 = Int64.of_int 0xffff in + let mask24 = Int64.of_int 0xffffff in + Printf.bprintf + buffer + "[255,%Ld,%Ld,%Ld]" + (Int64.logand i mask24) + (Int64.logand (Int64.shift_right i 24) mask24) + (Int64.logand (Int64.shift_right i 48) mask16) + +external custom_identifier : Obj.t -> string = "caml_custom_identifier" + +let rec write b v = + if Obj.is_int v + then Printf.bprintf b "%d" (Obj.obj v : int) + else + let t = Obj.tag v in + if t <= Obj.last_non_constant_constructor_tag + then ( + Printf.bprintf b "[%d" t; + for i = 0 to Obj.size v - 1 do + Buffer.add_char b ','; + write b (Obj.field v i) + done; + Buffer.add_char b ']') + else if t = Obj.string_tag + then write_string b (Obj.obj v : string) + else if t = Obj.double_tag + then write_float b (Obj.obj v : float) + else if t = Obj.double_array_tag + then ( + Printf.bprintf b "[%d" t; + for i = 0 to Obj.size v - 1 do + Buffer.add_char b ','; + write_float b (Obj.double_field v i) + done; + Buffer.add_char b ']') + else if t = Obj.custom_tag + then + match custom_identifier v with + | "_i" -> Printf.bprintf b "%ld" (Obj.obj v : int32) + | "_j" -> + let i : int64 = Obj.obj v in + write_int64 b i + | id -> failwith (Printf.sprintf "Json.output: unsupported custom value %s " id) + else failwith (Printf.sprintf "Json.output: unsupported tag %d " t) + +let to_json v = + let buf = Buffer.create 50 in + write buf v; + Buffer.contents buf + +(****) + class type json = object method parse : 'a. js_string t -> 'a meth @@ -51,13 +138,22 @@ let input_reviver = in wrap_meth_callback reviver -let unsafe_input s = json##parse_ s input_reviver +let unsafe_input s = + match Sys.backend_type with + | Other "wasm_of_ocaml" -> + (* https://github.com/ocsigen/js_of_ocaml/pull/1660#discussion_r1731099372 + The encoding of OCaml values is ambiguous since both integers and floats + are mapped to numbers *) + failwith "Json.unsafe_input: not implemented in the Wasm backend" + | _ -> json##parse_ s input_reviver class type obj = object method constructor : 'a. 'a constr Js.readonly_prop end let mlInt64_constr = + Js.Unsafe.pure_expr + @@ fun () -> let dummy_int64 = 1L in let dummy_obj : obj t = Obj.magic dummy_int64 in dummy_obj##.constructor @@ -71,4 +167,20 @@ let output_reviver _key (value : Unsafe.any) : Obj.t = Obj.repr (array [| 255; value##.lo; value##.mi; value##.hi |]) else Obj.repr value -let output obj = json##stringify_ obj (Js.wrap_callback output_reviver) +let use_native_stringify_ = + ref + (match Sys.backend_type with + | Other "js_of_ocaml" -> true + | Native | Bytecode | Other _ -> false) + +let use_native_stringify () = !use_native_stringify_ + +let set_use_native_stringify b = use_native_stringify_ := b + +let output_ x = to_json (Obj.repr x) + +let output obj = + match Sys.backend_type with + | Other "js_of_ocaml" when use_native_stringify () -> + json##stringify_ obj (Js.wrap_callback output_reviver) + | _ -> Js.string (output_ obj) diff --git a/lib/js_of_ocaml/json.mli b/lib/js_of_ocaml/json.mli index 828755f595..45641c2d9f 100644 --- a/lib/js_of_ocaml/json.mli +++ b/lib/js_of_ocaml/json.mli @@ -25,3 +25,16 @@ val output : 'a -> Js.js_string Js.t val unsafe_input : Js.js_string Js.t -> 'a (** Unmarshal a string in JSON format as an OCaml value (unsafe but fast !). *) + +(**/**) + +val output_ : 'a -> string + +val set_use_native_stringify : bool -> unit +(** Only affects js_of_ocaml. Whether to use native Javascript [stringify] to + turn a value into JSON in {!val:output}. Otherwise, fall back to the slower + method used by other backends, such as wasm_of_ocaml. *) + +val use_native_stringify : unit -> bool +(** Whether js_of_ocaml is using [stringify] in {!val:output}. See + {!val:set_use_native_stringify}. *) diff --git a/lib/tests/test_json.ml b/lib/tests/test_json.ml index 7f07f19bb1..6360260bcb 100644 --- a/lib/tests/test_json.ml +++ b/lib/tests/test_json.ml @@ -22,30 +22,42 @@ open Js_of_ocaml let round_trip x = let s = Json.output x in - Printf.printf "%s\n" (Js.to_bytestring s); - let y = Json.unsafe_input s in - Printf.printf "%b\n" (x = y) + let s1 = Js.to_bytestring s in + let s2 = + let old = Json.use_native_stringify () in + Json.set_use_native_stringify false; + let s = Json.output x in + Json.set_use_native_stringify old; + Js.to_bytestring s + in + Printf.printf "%s\n" s1; + if s1 <> s2 then Printf.printf "Json.output mismatch: %s vs %s\n" s1 s2; + (* Other direction of the round-trip (unmarshalling from JSON) is only + available with js_of_ocaml *) + match Sys.backend_type with + | Other "js_of_ocaml" when Json.use_native_stringify () -> + let y = Json.unsafe_input s in + if not (x = y) then Printf.printf "not invariant by round-trip\n" + | _ -> () let%expect_test _ = round_trip 123L; [%expect {| - [255,123,0,0] - true |}]; + [255,123,0,0] |}]; round_trip "asd"; [%expect {| - "asd" - true |}]; + "asd" |}]; round_trip "\000\255\254"; - [%expect {| - "\u0000ÿþ" - true |}]; + [%expect {| "\u0000ÿþ" |}]; round_trip (2, 3); round_trip (2., 3.); round_trip (2.2, 3.3); [%expect {| [0,2,3] - true [0,2,3] - true [0,2.2,3.3] - true |}] + |}]; + round_trip [| 1.; 2.; 3. |]; + [%expect {| [254,1,2,3] |}]; + round_trip 2n; + [%expect {| 2 |}] diff --git a/runtime/obj.js b/runtime/obj.js index 03820076ec..7d3bfee3c9 100644 --- a/runtime/obj.js +++ b/runtime/obj.js @@ -214,3 +214,9 @@ function caml_is_continuation_tag(t) { function caml_is_continuation_tag(t) { return (t == 245) ? 1 : 0; } + +//Provides: caml_custom_identifier +//Requires: caml_string_of_jsstring +function caml_custom_identifier (o) { + return caml_string_of_jsstring(o.caml_custom); +}