From 96b8278b53ccce0ce30bbeb4a81cb16da4332a3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 9 Oct 2023 10:48:36 +0200 Subject: [PATCH 1/5] Runtime: implement Json.output --- lib/js_of_ocaml/js_of_ocaml_stubs.c | 4 + lib/js_of_ocaml/json.ml | 110 +++++++++++++++++++++++++++- lib/js_of_ocaml/json.mli | 9 +++ lib/tests/test_json.ml | 54 ++++++++------ runtime/obj.js | 6 ++ 5 files changed, 157 insertions(+), 26 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..472ca5cfa2 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,18 @@ 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" -> failwith "Json.unsafe_input: not implemented" + | _ -> 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 +163,18 @@ 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 obj = + match Sys.backend_type with + | Other "js_of_ocaml" when use_native_stringify () -> + json##stringify_ obj (Js.wrap_callback output_reviver) + | _ -> Js.string (to_json (Obj.repr obj)) diff --git a/lib/js_of_ocaml/json.mli b/lib/js_of_ocaml/json.mli index 828755f595..380ea1008a 100644 --- a/lib/js_of_ocaml/json.mli +++ b/lib/js_of_ocaml/json.mli @@ -25,3 +25,12 @@ 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 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..5c1bf0371a 100644 --- a/lib/tests/test_json.ml +++ b/lib/tests/test_json.ml @@ -23,29 +23,35 @@ 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) + (* 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 |}]; - round_trip "asd"; - [%expect {| - "asd" - true |}]; - round_trip "\000\255\254"; - [%expect {| - "\u0000ÿþ" - true |}]; - 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 |}] + let tests ~use_native_stringify = + let () = Json.set_use_native_stringify use_native_stringify in + round_trip 123L; + [%expect {| + [255,123,0,0] |}]; + round_trip "asd"; + [%expect {| + "asd" |}]; + round_trip "\000\255\254"; + [%expect {| + "\u0000ÿþ" |}]; + round_trip (2, 3); + round_trip (2., 3.); + round_trip (2.2, 3.3); + [%expect {| + [0,2,3] + [0,2,3] + [0,2.2,3.3] |}] + in + tests ~use_native_stringify:false; + match Sys.backend_type with + | Other "js_of_ocaml" -> tests ~use_native_stringify:true + | _ -> () 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); +} From 998d95cec159c01ecc0d5d60d80a9616e2947a70 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 24 Aug 2024 09:44:24 +0200 Subject: [PATCH 2/5] fmt --- lib/js_of_ocaml/json.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 472ca5cfa2..61d51394dd 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -164,10 +164,10 @@ let output_reviver _key (value : Unsafe.any) : Obj.t = else Obj.repr value let use_native_stringify_ = - ref ( - match Sys.backend_type with - | Other "js_of_ocaml" -> true - | Native | Bytecode | Other _ -> false) + ref + (match Sys.backend_type with + | Other "js_of_ocaml" -> true + | Native | Bytecode | Other _ -> false) let use_native_stringify () = !use_native_stringify_ From b6a20121748d8a5259d45d9573d654a9a3e4d537 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 24 Aug 2024 17:07:29 +0200 Subject: [PATCH 3/5] CR --- lib/js_of_ocaml/json.ml | 4 +++- lib/js_of_ocaml/json.mli | 4 ++++ lib/tests/test_json.ml | 50 ++++++++++++++++++++++------------------ 3 files changed, 35 insertions(+), 23 deletions(-) diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 61d51394dd..541f6fc5c2 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -173,8 +173,10 @@ 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 (to_json (Obj.repr obj)) + | _ -> Js.string (output_ obj) diff --git a/lib/js_of_ocaml/json.mli b/lib/js_of_ocaml/json.mli index 380ea1008a..45641c2d9f 100644 --- a/lib/js_of_ocaml/json.mli +++ b/lib/js_of_ocaml/json.mli @@ -26,6 +26,10 @@ 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 diff --git a/lib/tests/test_json.ml b/lib/tests/test_json.ml index 5c1bf0371a..6360260bcb 100644 --- a/lib/tests/test_json.ml +++ b/lib/tests/test_json.ml @@ -22,7 +22,16 @@ open Js_of_ocaml let round_trip x = let s = Json.output x in - Printf.printf "%s\n" (Js.to_bytestring s); + 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 @@ -32,26 +41,23 @@ let round_trip x = | _ -> () let%expect_test _ = - let tests ~use_native_stringify = - let () = Json.set_use_native_stringify use_native_stringify in - round_trip 123L; - [%expect {| + round_trip 123L; + [%expect {| [255,123,0,0] |}]; - round_trip "asd"; - [%expect {| + round_trip "asd"; + [%expect {| "asd" |}]; - round_trip "\000\255\254"; - [%expect {| - "\u0000ÿþ" |}]; - round_trip (2, 3); - round_trip (2., 3.); - round_trip (2.2, 3.3); - [%expect {| - [0,2,3] - [0,2,3] - [0,2.2,3.3] |}] - in - tests ~use_native_stringify:false; - match Sys.backend_type with - | Other "js_of_ocaml" -> tests ~use_native_stringify:true - | _ -> () + round_trip "\000\255\254"; + [%expect {| "\u0000ÿþ" |}]; + round_trip (2, 3); + round_trip (2., 3.); + round_trip (2.2, 3.3); + [%expect {| + [0,2,3] + [0,2,3] + [0,2.2,3.3] + |}]; + round_trip [| 1.; 2.; 3. |]; + [%expect {| [254,1,2,3] |}]; + round_trip 2n; + [%expect {| 2 |}] From 6ec6e75baad6a6ac832f123b2cbd88fa0f199965 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 26 Aug 2024 11:19:57 +0200 Subject: [PATCH 4/5] Improve error message --- lib/js_of_ocaml/json.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 541f6fc5c2..4d9a88efc7 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -140,7 +140,10 @@ let input_reviver = let unsafe_input s = match Sys.backend_type with - | Other "wasm_of_ocaml" -> failwith "Json.unsafe_input: not implemented" + | Other "wasm_of_ocaml" -> + failwith + "Json.unsafe_input: not implemented (and not planned) in the Wasm backend as the \ + inverse of `output` is not implementable" | _ -> json##parse_ s input_reviver class type obj = object From f90904bf6099adefc54507ffdcb519b3734e35ed Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 26 Aug 2024 13:58:07 +0200 Subject: [PATCH 5/5] FIX --- lib/js_of_ocaml/json.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 4d9a88efc7..fb525fb321 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -141,9 +141,10 @@ let input_reviver = let unsafe_input s = match Sys.backend_type with | Other "wasm_of_ocaml" -> - failwith - "Json.unsafe_input: not implemented (and not planned) in the Wasm backend as the \ - inverse of `output` is not implementable" + (* 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