Runtime: implement Json.output

lib/js_of_ocaml/js_of_ocaml_stubs.c

@@ -1,5 +1,9 @@
 #include <stdlib.h>
 #include <stdio.h>
+void caml_custom_identifier () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_custom_identifier!\n");
+  exit(1);
+}
 void caml_js_error_of_exception () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_js_error_of_exception!\n");
   exit(1);

lib/js_of_ocaml/json.ml

@@ -20,6 +20,88 @@
 open Js
 open! Import
 
+(****)
+
+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
+
+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
+          let mask16 = Int64.of_int 0xffff in
+          let mask24 = Int64.of_int 0xffffff in
+          Printf.bprintf
+            b
+            "[255,%Ld,%Ld,%Ld]"
+            (Int64.logand i mask24)
+            (Int64.logand (Int64.shift_right i 24) mask24)
+            (Int64.logand (Int64.shift_right i 48) mask16)
+      | 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
@@ -52,7 +134,10 @@ 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
@@ -73,4 +158,7 @@ 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 output obj =
+  match Sys.backend_type with
+  | Other "wasm_of_ocaml" -> Js.string (to_json (Obj.repr obj))
+  | _ -> json##stringify_ obj (Js.wrap_callback output_reviver)

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

runtime/wasm/custom.wat

@@ -109,4 +109,8 @@
       (call $caml_register_custom_operations (global.get $int64_ops))
       (call $caml_register_custom_operations (global.get $bigarray_ops))
       (global.set $initialized (i32.const 1)))
+
+  (func (export "caml_custom_identifier") (param $v (ref eq)) (result (ref eq))
+     (struct.get $custom_operations $id
+        (struct.get $custom 0 (ref.cast (ref $custom) (local.get $v)))))
 )