From 78375020b8147d79b0043eb5a9d75fc7e91e5300 Mon Sep 17 00:00:00 2001
From: Andrey Popp <8mayday@gmail.com>
Date: Mon, 7 Oct 2024 23:30:37 +0400
Subject: [PATCH 1/2] ppx: consistent errors in runtime

The main thing we fix here is the consistent use of exceptions in native
runtime, which used, before this commit either its own Of_json_error or
yojson's Type_error.

Then there's
```
val of_string : string -> t
```
which is not required by ppx but was introduced so that the runtime
modules can function as minimal JSON interfaces usable both in native
and browser environments (so called universal workflow).

Before this commit the error behaviour was not specified, now we
introduce `exception Of_json of string` in both native and browser and
make `of_string` raise it in case of invalid JSON.
---
 ppx/browser/ppx_deriving_json_runtime.ml | 19 +++++++-
 ppx/native/ppx_deriving_json_runtime.ml  | 59 ++++++++++++++++++++----
 2 files changed, 68 insertions(+), 10 deletions(-)

diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml
index 44100e5..a6cb4e4 100644
--- a/ppx/browser/ppx_deriving_json_runtime.ml
+++ b/ppx/browser/ppx_deriving_json_runtime.ml
@@ -3,8 +3,23 @@ type t = Js.Json.t
 let to_json t = t
 let of_json t = t
 let to_string t = Js.Json.stringify t
-let of_string s = Js.Json.parseExn s
-let of_json_error msg = raise @@ Json.Decode.DecodeError msg
+
+exception Json_error of string
+
+let of_string s =
+  try Js.Json.parseExn s
+  with exn ->
+    let msg =
+      match Js.Exn.asJsExn exn with
+      | Some jsexn -> Js.Exn.message jsexn
+      | None -> None
+    in
+    let msg = Option.value msg ~default:"JSON error" in
+    raise (Json_error msg)
+
+exception Of_json_error = Json.Decode.DecodeError
+
+let of_json_error msg = raise (Of_json_error msg)
 
 module To_json = struct
   external string_to_json : string -> t = "%identity"
diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/ppx/native/ppx_deriving_json_runtime.ml
index 6d0bcef..138a7f3 100644
--- a/ppx/native/ppx_deriving_json_runtime.ml
+++ b/ppx/native/ppx_deriving_json_runtime.ml
@@ -3,12 +3,31 @@ type t = Yojson.Basic.t
 let to_json t = t
 let of_json t = t
 let to_string t = Yojson.Basic.to_string t
-let of_string s = Yojson.Basic.from_string s
+
+exception Json_error of string
+
+let of_string s =
+  try Yojson.Basic.from_string s
+  with Yojson.Json_error msg -> raise (Json_error msg)
 
 exception Of_json_error of string
 
 let of_json_error msg = raise (Of_json_error msg)
 
+let show_js_type = function
+  | `Assoc _ -> "object"
+  | `Bool _ -> "bool"
+  | `Float _ -> "float"
+  | `Int _ -> "int"
+  | `List _ -> "array"
+  | `Null -> "null"
+  | `String _ -> "string"
+
+let of_json_error_type_mismatch json expected =
+  raise
+    (Of_json_error
+       ("expected " ^ expected ^ " but got " ^ show_js_type json))
+
 module To_json = struct
   let string_to_json v = `String v
   let bool_to_json v = `Bool v
@@ -28,19 +47,43 @@ module To_json = struct
 end
 
 module Of_json = struct
-  let string_of_json = Yojson.Basic.Util.to_string
-  let bool_of_json = Yojson.Basic.Util.to_bool
-  let int_of_json = Yojson.Basic.Util.to_int
-  let float_of_json = Yojson.Basic.Util.to_number
+  let typeof = function
+    | `Assoc _ -> "object"
+    | `Bool _ -> "bool"
+    | `Float _ -> "float"
+    | `Int _ -> "int"
+    | `List _ -> "array"
+    | `Null -> "null"
+    | `String _ -> "string"
+
+  let string_of_json = function
+    | `String s -> s
+    | json -> of_json_error_type_mismatch json "string"
+
+  let bool_of_json = function
+    | `Bool b -> b
+    | json -> of_json_error_type_mismatch json "bool"
+
+  let int_of_json = function
+    | `Int i -> i
+    | json -> of_json_error_type_mismatch json "int"
+
+  let float_of_json = function
+    | `Float f -> f
+    | `Int i -> float_of_int i
+    | json -> of_json_error_type_mismatch json "float"
 
   let unit_of_json = function
     | `Null -> ()
     | _ -> of_json_error "expected null"
 
-  let option_of_json v_of_json = Yojson.Basic.Util.to_option v_of_json
+  let option_of_json v_of_json = function
+    | `Null -> None
+    | json -> Some (v_of_json json)
 
-  let list_of_json v_of_json json =
-    List.map v_of_json (Yojson.Basic.Util.to_list json)
+  let list_of_json v_of_json = function
+    | `List l -> List.map v_of_json l
+    | json -> of_json_error_type_mismatch json "array"
 
   let result_of_json ok_of_json err_of_json json =
     match json with

From df73c229517c2c7e9e4053302b6f51f2d6d21faf Mon Sep 17 00:00:00 2001
From: Andrey Popp <8mayday@gmail.com>
Date: Tue, 8 Oct 2024 12:56:12 +0400
Subject: [PATCH 2/2] fixup! ppx: consistent errors in runtime

---
 ppx/browser/ppx_deriving_json_runtime.ml | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml
index a6cb4e4..e079441 100644
--- a/ppx/browser/ppx_deriving_json_runtime.ml
+++ b/ppx/browser/ppx_deriving_json_runtime.ml
@@ -14,7 +14,10 @@ let of_string s =
       | Some jsexn -> Js.Exn.message jsexn
       | None -> None
     in
-    let msg = Option.value msg ~default:"JSON error" in
+    let msg =
+      (* msg really cannot be None in browser or any sane JS runtime *)
+      Option.value msg ~default:"JSON error"
+    in
     raise (Json_error msg)
 
 exception Of_json_error = Json.Decode.DecodeError