Runtime: implement Json.output

Author: vouillon

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!");
 }

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))

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}. *)

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
+  | _ -> ()

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);
+}