Skip to content

Commit

Permalink
Runtime: implement Json output for Wasm (#1660)
Browse files Browse the repository at this point in the history
Co-authored-by: Jérôme Vouillon <[email protected]>
Co-authored-by: Hugo Heuzard <[email protected]>
  • Loading branch information
3 people authored Aug 26, 2024
1 parent 2f98d17 commit c58a528
Show file tree
Hide file tree
Showing 5 changed files with 162 additions and 15 deletions.
4 changes: 4 additions & 0 deletions lib/js_of_ocaml/js_of_ocaml_stubs.c
Original file line number Diff line number Diff line change
Expand Up @@ -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!");
}
Expand Down
116 changes: 114 additions & 2 deletions lib/js_of_ocaml/json.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand All @@ -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)
13 changes: 13 additions & 0 deletions lib/js_of_ocaml/json.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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}. *)
38 changes: 25 additions & 13 deletions lib/tests/test_json.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 |}]
6 changes: 6 additions & 0 deletions runtime/obj.js
Original file line number Diff line number Diff line change
Expand Up @@ -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);
}

0 comments on commit c58a528

Please sign in to comment.