Skip to content

Commit

Permalink
ppx: consistent errors in runtime
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
andreypopp committed Oct 7, 2024
1 parent 5c3062a commit 7837502
Show file tree
Hide file tree
Showing 2 changed files with 68 additions and 10 deletions.
19 changes: 17 additions & 2 deletions ppx/browser/ppx_deriving_json_runtime.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down
59 changes: 51 additions & 8 deletions ppx/native/ppx_deriving_json_runtime.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down

0 comments on commit 7837502

Please sign in to comment.