ppx: add to_json_string,of_json_string,json_string derivers

CHANGES.md

@@ -13,6 +13,9 @@
   ([#27](https://github.com/melange-community/melange-json/pull/27))
 - PPX: Consistent use of exceptions in runtime.
   ([#28](https://github.com/melange-community/melange-json/pull/28))
+- PPX: add `[@@json_string]` for deriving converters to/from JSON strings
+  directly
+  ([#30](https://github.com/melange-community/melange-json/pull/30))
 
 ## 1.3.0 (2024-08-28)
 

README.md

@@ -279,6 +279,21 @@ let json = to_json B
 (* "bbb" *)
 ```
 
+#### `[@@deriving json_string]`: a shortcut for JSON string conversion
+
+For convenience, one can use `[@@deriving json_string]` to generate converters
+directly to and from JSON strings:
+
+```ocaml
+type t = A [@@deriving json, json_string]
+
+let "\"A\"" = to_json_string A
+let A = of_json_string "\"A\""
+```
+
+Similarly, there's `[@@deriving to_json_string]` and `[@@deriving
+of_json_string]` to generate the converters separately.
+
 ## PPX for OCaml native
 
 A similar PPX is exposed in the `melange-json-native` package, which works with

ppx/browser/ppx_deriving_json_js.ml

@@ -211,10 +211,13 @@ module To_json = struct
 end
 
 let () =
-  let _ = Ppx_deriving_tools.register Of_json.deriving in
-  let _ = Ppx_deriving_tools.register To_json.deriving in
-  let _ =
+  let of_json = Ppx_deriving_tools.register Of_json.deriving in
+  let to_json = Ppx_deriving_tools.register To_json.deriving in
+  let json =
     Ppx_deriving_tools.register_combined "json"
       [ To_json.deriving; Of_json.deriving ]
   in
+  let (_ : Deriving.t) = Of_json_string.register ~of_json () in
+  let (_ : Deriving.t) = To_json_string.register ~to_json () in
+  let (_ : Deriving.t) = Json_string.register ~json () in
   ()

ppx/native/ppx_deriving_json_common.ml

@@ -1,4 +1,6 @@
+open StdLabels
 open Ppxlib
+open Ast_builder.Default
 open Ppx_deriving_tools.Conv
 
 let get_of_variant_case ?mark_as_seen ~variant ~polyvariant = function
@@ -78,3 +80,78 @@ let ld_drop_default ld =
         "found [@drop_default] attribute without [@option]"
   | Some (), Some () -> `Drop_option
   | None, _ -> `No
+
+let expand_via ~what ~through make ~ctxt (rec_flag, tds) =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  let expand_one (td : type_declaration) =
+    let loc = td.ptype_loc in
+    let pat =
+      let { txt; loc } = td.ptype_name in
+      let txt = Expansion_helpers.mangle what txt in
+      ppat_var ~loc { Location.txt; loc }
+    in
+    let name_of_td_param idx (ty, _) =
+      match ty.ptyp_desc with
+      | Ptyp_any -> Printf.sprintf "_%d" idx
+      | Ptyp_var name -> name
+      | _ ->
+          Location.raise_errorf ~loc:ty.ptyp_loc
+            "unsupported type parameter"
+    in
+    let names = List.mapi td.ptype_params ~f:name_of_td_param in
+    let expr =
+      let of_json =
+        let { txt; loc = _ } = td.ptype_name in
+        let txt = Expansion_helpers.mangle through txt in
+        let of_json = pexp_ident ~loc { loc; txt = lident txt } in
+        pexp_apply ~loc of_json
+          (List.map names ~f:(fun name -> Nolabel, evar ~loc name))
+      in
+      let body = make ~loc of_json in
+      List.fold_left (List.rev names) ~init:body ~f:(fun e name ->
+          [%expr fun [%p pvar ~loc name] -> [%e e]])
+    in
+    value_binding ~loc ~pat ~expr
+  in
+  pstr_value_list ~loc rec_flag (List.map tds ~f:expand_one)
+
+module Of_json_string = struct
+  let expand =
+    expand_via ~what:(Expansion_helpers.Suffix "of_json_string")
+      ~through:(Expansion_helpers.Suffix "of_json") (fun ~loc of_json ->
+        [%expr
+          fun _json ->
+            [%e of_json] (Ppx_deriving_json_runtime.of_string _json)])
+
+  let register ~of_json () =
+    Deriving.add "of_json_string"
+      ~str_type_decl:
+        (Deriving.Generator.V2.make ~deps:[ of_json ] Deriving.Args.empty
+           expand)
+end
+
+module To_json_string = struct
+  let expand =
+    expand_via ~what:(Expansion_helpers.Suffix "to_json_string")
+      ~through:(Expansion_helpers.Suffix "to_json") (fun ~loc to_json ->
+        [%expr
+          fun _data ->
+            Ppx_deriving_json_runtime.to_string ([%e to_json] _data)])
+
+  let register ~to_json () =
+    Deriving.add "to_json_string"
+      ~str_type_decl:
+        (Deriving.Generator.V2.make ~deps:[ to_json ] Deriving.Args.empty
+           expand)
+end
+
+module Json_string = struct
+  let expand ~ctxt tds =
+    Of_json_string.expand ~ctxt tds @ To_json_string.expand ~ctxt tds
+
+  let register ~json () =
+    Deriving.add "json_string"
+      ~str_type_decl:
+        (Deriving.Generator.V2.make ~deps:[ json ] Deriving.Args.empty
+           expand)
+end

ppx/native/ppx_deriving_json_native.ml

@@ -230,10 +230,13 @@ module To_json = struct
 end
 
 let () =
-  let _ = Ppx_deriving_tools.register Of_json.deriving in
-  let _ = Ppx_deriving_tools.register To_json.deriving in
-  let _ =
+  let of_json = Ppx_deriving_tools.register Of_json.deriving in
+  let to_json = Ppx_deriving_tools.register To_json.deriving in
+  let (json : Deriving.t) =
     Ppx_deriving_tools.(
       register_combined "json" [ To_json.deriving; Of_json.deriving ])
   in
+  let (_ : Deriving.t) = Of_json_string.register ~of_json () in
+  let (_ : Deriving.t) = To_json_string.register ~to_json () in
+  let (_ : Deriving.t) = Json_string.register ~json () in
   ()

ppx/test/dune

@@ -2,6 +2,7 @@
  (deps
   (package melange-json)
   ./example.ml
+  ./example_json_string.ml
   ../../.ocamlformat
   ../native/ppx_deriving_json_native_test.exe
   ../browser/ppx_deriving_json_js_test.exe))

ppx/test/example.ml

@@ -21,48 +21,46 @@ type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields]
 type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json]
 type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json]
 
-module Cases = struct
-  type json = Ppx_deriving_json_runtime.t
-  type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json
-  let of_json_cases = [
-    C ({|1|}, user_of_json, user_to_json, 1);
-    C ({|1.1|}, floaty_of_json, floaty_to_json, 1.1);
-    C ({|1.0|}, floaty_of_json, floaty_to_json, 1.0);
-    C ({|42|}, floaty_of_json, floaty_to_json, 42.0);
-    C ({|"OK"|}, (param_of_json string_of_json), (param_to_json string_to_json), "OK");
-    C ({|"some"|}, opt_of_json, opt_to_json, (Some "some"));
-    C ({|["Ok", 1]|}, res_of_json, res_to_json, Ok 1);
-    C ({|["Error", "oops"]|}, res_of_json, res_to_json, Error "oops");
-    C ({|[42, "works"]|}, tuple_of_json, tuple_to_json, (42, "works"));
-    C ({|{"name":"N","age":1}|}, record_of_json, record_to_json, {name="N"; age=1});
-    C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
-    C ({|["B", 42]|}, sum_of_json, sum_to_json, (B 42 : sum));
-    C ({|["C", {"name": "cname"}]|}, sum_of_json, sum_to_json, (C {name="cname"} : sum));
-    C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
-    C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello")));
-    C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly));
-    C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2));
-    C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A))));
-    C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A))));
-    C ({|{"my_name":"N","my_age":1}|}, record_aliased_of_json, record_aliased_to_json, {name="N"; age=1});
-    C ({|{"my_name":"N"}|}, record_aliased_of_json, record_aliased_to_json, {name="N"; age=100});
-    C ({|{}|}, record_opt_of_json, record_opt_to_json, {k=None});
-    C ({|{"k":42}|}, record_opt_of_json, record_opt_to_json, {k=Some 42});
-    C ({|["A",1]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, A 1);
-    C ({|["B","ok"]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, B "ok");
-    C ({|{"a":1,"b":2}|}, allow_extra_fields_of_json, allow_extra_fields_to_json, {a=1});
-    C ({|["A",{"a":1,"b":2}]|}, allow_extra_fields2_of_json, allow_extra_fields2_to_json, A {a=1});
-    C ({|{"a":1}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=None});
-    C ({|{"a":1,"b_opt":2}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=Some 2});
-  ]
-  let run' ~json_of_string ~json_to_string (C (data, of_json, to_json, v)) =
-    print_endline (Printf.sprintf "JSON    DATA: %s" data);
-    let json = json_of_string data in
-    let v' = of_json json in
-    assert (v' = v);
-    let json' = to_json v' in
-    let data' = json_to_string json' in
-    print_endline (Printf.sprintf "JSON REPRINT: %s" data')
-  let run ~json_of_string ~json_to_string () =
-    List.iter (run' ~json_of_string ~json_to_string) of_json_cases
-end
+type json = Ppx_deriving_json_runtime.t
+type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json
+let of_json_cases = [
+  C ({|1|}, user_of_json, user_to_json, 1);
+  C ({|1.1|}, floaty_of_json, floaty_to_json, 1.1);
+  C ({|1.0|}, floaty_of_json, floaty_to_json, 1.0);
+  C ({|42|}, floaty_of_json, floaty_to_json, 42.0);
+  C ({|"OK"|}, (param_of_json string_of_json), (param_to_json string_to_json), "OK");
+  C ({|"some"|}, opt_of_json, opt_to_json, (Some "some"));
+  C ({|["Ok", 1]|}, res_of_json, res_to_json, Ok 1);
+  C ({|["Error", "oops"]|}, res_of_json, res_to_json, Error "oops");
+  C ({|[42, "works"]|}, tuple_of_json, tuple_to_json, (42, "works"));
+  C ({|{"name":"N","age":1}|}, record_of_json, record_to_json, {name="N"; age=1});
+  C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
+  C ({|["B", 42]|}, sum_of_json, sum_to_json, (B 42 : sum));
+  C ({|["C", {"name": "cname"}]|}, sum_of_json, sum_to_json, (C {name="cname"} : sum));
+  C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
+  C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello")));
+  C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly));
+  C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2));
+  C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A))));
+  C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A))));
+  C ({|{"my_name":"N","my_age":1}|}, record_aliased_of_json, record_aliased_to_json, {name="N"; age=1});
+  C ({|{"my_name":"N"}|}, record_aliased_of_json, record_aliased_to_json, {name="N"; age=100});
+  C ({|{}|}, record_opt_of_json, record_opt_to_json, {k=None});
+  C ({|{"k":42}|}, record_opt_of_json, record_opt_to_json, {k=Some 42});
+  C ({|["A",1]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, A 1);
+  C ({|["B","ok"]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, B "ok");
+  C ({|{"a":1,"b":2}|}, allow_extra_fields_of_json, allow_extra_fields_to_json, {a=1});
+  C ({|["A",{"a":1,"b":2}]|}, allow_extra_fields2_of_json, allow_extra_fields2_to_json, A {a=1});
+  C ({|{"a":1}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=None});
+  C ({|{"a":1,"b_opt":2}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=Some 2});
+]
+let run' (C (data, of_json, to_json, v)) =
+  print_endline (Printf.sprintf "JSON    DATA: %s" data);
+  let json = Ppx_deriving_json_runtime.of_string data in
+  let v' = of_json json in
+  assert (v' = v);
+  let json' = to_json v' in
+  let data' = Ppx_deriving_json_runtime.to_string json' in
+  print_endline (Printf.sprintf "JSON REPRINT: %s" data')
+let test () =
+  List.iter run' of_json_cases

ppx/test/example_json_string.ml

@@ -0,0 +1,45 @@
+open Ppx_deriving_json_runtime.Primitives
+
+let print fmt = Printf.ksprintf print_endline fmt
+
+module To_json_string = struct
+  type ('a, 'b) t = A of 'a | B of 'b
+  [@@deriving to_json, to_json_string]
+
+  let test () =
+    let to_json_string = to_json_string int_to_json bool_to_json in
+    print "** To_json_string **";
+    print "A 42 -> %s" (to_json_string (A 42));
+    print "B false -> %s" (to_json_string (B false))
+end
+
+module Of_json_string = struct
+  type ('a, 'b) t = A of 'a | B of 'b
+  [@@deriving of_json, of_json_string]
+
+  let test () =
+    let of_json_string = of_json_string int_of_json bool_of_json in
+    print "** Of_json_string **";
+    print {|["A", 42] = A 42 -> %b|} (of_json_string {|["A", 42]|} = A 42);
+    print {|["B", false] = B false -> %b|}
+      (of_json_string {|["B", false]|} = B false)
+end
+
+module Json_string = struct
+  type ('a, 'b) t = A of 'a | B of 'b [@@deriving json, json_string]
+
+  let test () =
+    print "** Json_string **";
+    let to_json_string = to_json_string int_to_json bool_to_json in
+    print "A 42 -> %s" (to_json_string (A 42));
+    print "B false -> %s" (to_json_string (B false));
+    let of_json_string = of_json_string int_of_json bool_of_json in
+    print {|["A", 42] = A 42 -> %b|} (of_json_string {|["A", 42]|} = A 42);
+    print {|["B", false] = B false -> %b|}
+      (of_json_string {|["B", false]|} = B false)
+end
+
+let test () =
+  To_json_string.test ();
+  Of_json_string.test ();
+  Json_string.test ()

ppx/test/ppx_deriving_json_js.e2e.t

@@ -6,7 +6,7 @@
   > (library
   >  (name lib)
   >  (modes melange)
-  >  (modules example main)
+  >  (modules example example_json_string main)
   >  (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives)
   >  (preprocess (pps melange.ppx melange-json.ppx)))
   > (melange.emit
@@ -17,15 +17,16 @@
   >  (module_systems commonjs))' > dune
 
   $ echo '
-  > open Example
-  > let () = Cases.run ()
-  >   ~json_to_string:Js.Json.stringify
-  >   ~json_of_string:Js.Json.parseExn
+  > let () = print_endline "*** json deriver tests ***"
+  > let () = Example.test ()
+  > let () = print_endline "*** json_string deriver tests ***"
+  > let () = Example_json_string.test ()
   > ' >> main.ml
 
   $ dune build @js
 
   $ node ./_build/default/output/main.js
+  *** json deriver tests ***
   JSON    DATA: 1
   JSON REPRINT: 1
   JSON    DATA: 1.1
@@ -84,3 +85,15 @@
   JSON REPRINT: {"a":1}
   JSON    DATA: {"a":1,"b_opt":2}
   JSON REPRINT: {"a":1,"b_opt":2}
+  *** json_string deriver tests ***
+  ** To_json_string **
+  A 42 -> ["A",42]
+  B false -> ["B",false]
+  ** Of_json_string **
+  ["A", 42] = A 42 -> true
+  ["B", false] = B false -> true
+  ** Json_string **
+  A 42 -> ["A",42]
+  B false -> ["B",false]
+  ["A", 42] = A 42 -> true
+  ["B", false] = B false -> true

ppx/test/ppx_deriving_json_native.e2e.t

@@ -9,10 +9,9 @@
   >   (preprocess (pps melange-json-native.ppx)))' > dune
 
   $ echo '
-  > open Example
-  > let () = Cases.run ()
-  >   ~json_to_string:Yojson.Basic.to_string
-  >   ~json_of_string:Yojson.Basic.from_string
+  > let () = Example.test ()
+  > let () = print_endline "*** json_string deriver tests ***"
+  > let () = Example_json_string.test ()
   > ' >> main.ml
 
   $ dune build ./main.exe
@@ -76,3 +75,15 @@
   JSON REPRINT: {"a":1}
   JSON    DATA: {"a":1,"b_opt":2}
   JSON REPRINT: {"a":1,"b_opt":2}
+  *** json_string deriver tests ***
+  ** To_json_string **
+  A 42 -> ["A",42]
+  B false -> ["B",false]
+  ** Of_json_string **
+  ["A", 42] = A 42 -> true
+  ["B", false] = B false -> true
+  ** Json_string **
+  A 42 -> ["A",42]
+  B false -> ["B",false]
+  ["A", 42] = A 42 -> true
+  ["B", false] = B false -> true