From 0369d6cf38cd7a5414981aa2c287bb7f4e48b137 Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Thu, 5 Dec 2024 10:37:50 +0400 Subject: [PATCH 01/20] inline Json_decode/Json_encode sigs into Json.mli --- src/Json.mli | 590 +++++++++++++++++++++++++++++++++++++++++++- src/Json_decode.mli | 499 ------------------------------------- src/Json_encode.mli | 84 ------- 3 files changed, 588 insertions(+), 585 deletions(-) delete mode 100644 src/Json_decode.mli delete mode 100644 src/Json_encode.mli diff --git a/src/Json.mli b/src/Json.mli index 81918a7..4568dfc 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -101,8 +101,594 @@ let _ = ]} *) -module Decode = Json_decode -module Encode = Json_encode +module Decode : sig +(** Provides a set of low level combinator primitives to decode Js.Json.t data +structures +A decoder combinator will return the decoded value if successful, or raise a +[DecodeError of string] if unsuccessful, where the string argument contains the +error message. +Decoders are designed to be combined to produce more complex decoders that can +decode arbitrary data structures, though the emphasis for this library is for +it to be {i possible} to decode any given data structure, not necessarily for +it to be {i convenient}. For convenience you should look towards opinionated +third-party libraries. +*) + +type 'a decoder = Js.Json.t -> 'a +(** The type of a decoder combinator *) + +type error = Json_error of string | Unexpected_variant of string + +val error_to_string : error -> string + +exception DecodeError of error + +val id : Js.Json.t decoder +(** Identity decoder. + + {b Returns} the input JSON value. + + Always succeeds. You would use this if you wanted to partially decode + some JSON in stages; in the first stage you could decode some portion + of the input, while using [id] to keep the rest as JSON and decoding + that in subsequent stages. + + @example {[ + open Json + (* returns [(1 : int, {"a": true} : Js.Json.t)] *) + let json = parseOrRaise {|{"id": 1, {"a": true}}|} + let _ = Decode.(int json, id json) + ]} *) + +val bool : bool decoder +(** Decodes a JSON value into a [bool] + +{b Returns} a [bool] if the JSON value is a [true] or [false]. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns true *) + let _ = Json.parseOrRaise "true" |> Decode.bool + (* returns false *) + let _ = Json.parseOrRaise "false" |> Decode.bool + (* raises DecodeError *) + let _ = Json.parseOrRaise "123" |> Decode.bool + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.bool +]} +*) + +val float : float decoder +(** Decodes a JSON value into a [float] + +{b Returns} a [float] if the JSON value is a number. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns 1.23 *) + let _ = Json.parseOrRaise "1.23" |> Decode.float + (* returns 23. *) + let _ = Json.parseOrRaise "23" |> Decode.float + (* raises DecodeError *) + let _ = Json.parseOrRaise "true" |> Decode.float + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.float +]} +*) + +val int : int decoder +(** Decodes a JSON value into an [int] + +{b Returns} an [int] if the JSON value is a number. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise "23" |> Decode.int + (* raises DecodeError *) + let _ = Json.parseOrRaise "1.23" |> Decode.int + (* raises DecodeError *) + let _ = Json.parseOrRaise "true" |> Decode.int + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.int +]} +*) + +val string : string decoder +(** Decodes a JSON value into a [string] + +{b Returns} a [string] if the JSON value is a string. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns "foo" *) + let _ = Json.parseOrRaise "\"foo\"" |> Decode.string + (* raises DecodeError *) + let _ = Json.parseOrRaise "1.23" |> Decode.string + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.string +]} +*) + +val char : char decoder +(** Decodes a JSON value into a [char] + +{b Returns} a [char] if the JSON value is a single-character string. + +@raise [DecodeError] if unsuccessful. + +@example {[ + open Json + (* returns 'a' *) + let _ = Json.parseOrRaise "\"a\"" |> Decode.char + (* raises DecodeError *) + let _ = Json.parseOrRaise "\"abc\"" |> Decode.char + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.char +]} +*) + +val date : Js.Date.t decoder +(** Decodes an ISO8601-formatted JSON string into a [Js.Date.t] + +{b Returns} a [Js.Date.t] if the JSON value is an IS8601-formatted string. + +@raise [DecodeError] if unsuccessful +*) + +val nullable : 'a decoder -> 'a Js.null decoder +(** Decodes a JSON value into an ['a Js.null] + +{b Returns} [Js.null] if the JSON value is [null], or an ['a Js.null] if the +given decoder succeeds, + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns (Js.Null.return 23) *) + let _ = Json.parseOrRaise "23" |> Decode.(nullable int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "1.23" |> Decode.(nullable int) + (* returns Js.null *) + let _ = Json.parseOrRaise "null" |> Decode.(nullable int) +]} +*) + +val nullAs : 'a -> 'a decoder +(** Returns the given value if the JSON value is [null] + +{b Returns} an ['a] if the JSON value is [null]. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* raises DecodeError *) + let _ = Json.parseOrRaise "\"x\"" |> Decode.nullAs "x" + (* returns "x" *) + let _ = Json.parseOrRaise "null" |> Decode.nullAs "x" + (* returns None *) + let _ = Json.parseOrRaise "null" |> Decode.nullAs None +]} +*) + +val array : 'a decoder -> 'a array decoder +(** Decodes a JSON array into an ['a array] using the given decoder on each element + +{b Returns} an ['a array] if the JSON value is a JSON array and all its +elements are successfully decoded. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns [| 1; 2; 3 |] *) + let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(array int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(array int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "123" |> Decode.(array int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(array int) +]} +*) + +val list : 'a decoder -> 'a list decoder +(** Decodes a JSON array into an ['a list] using the given decoder on each element + +{b Returns} an ['a list] if the JSON value is a JSON array and all its +elements are successfully decoded. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns [1; 2; 3] *) + let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(list int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(list int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "123" |> Decode.(list int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(list int) +]} +*) + +val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder +(** Decodes a JSON array with two elements into an ['a * 'b] tuple using + each of the given decoders in order. + +{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both + its elements are successfully decoded. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns (1, "bar") *) + let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(pair int string) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2]" |> Decode.(pair int string) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(pair int int) +]} +*) + +val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder +(** Decodes a JSON array with two elements into an ['a * 'b] tuple using + each of the given decoders in order. + +{b Alias of [pair]} + +{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both + its elements are successfully decoded. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns (1, "bar") *) + let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(tuple2 int string) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2]" |> Decode.(tuple2 int string) + (* raises DecodeError *) + let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(tuple2 int int) +]} +*) + +val tuple3 : 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder +(** Decodes a JSON array with three elements into an ['a * 'b * 'c] tuple using + each of the given decoders in order. + +{b Returns} an ['a * 'b * 'c] if the JSON value is a JSON array of length 3 and + all its elements are successfully decoded. + +@raise [DecodeError] if unsuccessful +*) + +val tuple4 : 'a decoder -> 'b decoder -> 'c decoder -> 'd decoder -> ('a * 'b * 'c * 'd) decoder +(** Decodes a JSON array with four elements into an ['a * 'b * 'c * 'd] tuple + using each of the given decoders in order. + +{b Returns} an ['a * 'b * 'c * 'd] if the JSON value is a JSON array of length 4 + and all its elements are successfully decoded. + +@raise [DecodeError] if unsuccessful +*) + +val dict : 'a decoder -> 'a Js.Dict.t decoder +(** Decodes a JSON object into a dict using the given decoder on each of its values + +{b Returns} an ['a Js.Dict.t] if the JSON value is a JSON object and all its +values are successfully decoded. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns (Js.Dict.fromList [("x", 23); ("y", 42)]) *) + let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(dict int) + (* raises DecodeError *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(dict int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "123" |> Decode.(dict int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(dict int) +]} +*) + +val field : string -> 'a decoder -> 'a decoder +(** Decodes a JSON object with a specific field into the value of that field + +{b Returns} an ['a] if the JSON value is a JSON object with the given field +and a value that is successfully decoded with the given decoder. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(field "x" int) + (* returns 23 *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" int) + (* raises DecodeError *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "123" |> Decode.(field "x" int) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(field "x" int) +]} +*) + +val at : string list -> 'a decoder -> 'a decoder +(** Same as [field] but takes a top level field and a list of nested fields for decoding nested values. + +{b Returns} an ['a] if the JSON value is a JSON object with the given field +and a value that is successfully decoded with the given decoder. + +@raise [DecodeError] if unsuccessful +@raise [Invalid_argument] if list of fields is empty + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise {| { "x": {"foo": 23}, "y": 42 } |} |> Decode.(at ["x"; "foo"] int) + (* raises DecodeError *) + let _ = Json.parseOrRaise {| { "x": null, "y": "b" } |} |> Decode.(at ["x"; "foo"] int) +]} +*) + +val optional : 'a decoder -> 'a option decoder +(** Maps a decoder [result] to an option + +{b Returns} [Some of 'a] if the given decoder is successful, [None] if +it is not. + +This decoder will never raise a [DecodeError]. Its purpose is to catch and +transform [DecodeError]'s of a given decoder into [None]s by mapping its +[result] into an [option]. This prevents a decoder error from terminating +a composite decoder, and is useful to decode optional JSON object fields. + +@example {[ + open Json + (* returns (Some 23) *) + let _ = Json.parseOrRaise "23" |> Decode.(optional int) + (* returns None *) + let _ = Json.parseOrRaise 1.23 |> Decode.(optional int) + (* returns None *) + let _ = Json.parseOrRaise "null" |> Decode.(optional int) + (* returns (Some 23) *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "x" int)) + (* returns None *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "y" int)) + (* returns None *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "z" int)) + (* returns (Some 23) *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" (optional int)) + (* returns None *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" (optional int)) + (* raises DecodeError *) + let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "z" (optional int)) +]} +*) + +val oneOf : 'a decoder list -> 'a decoder +(** Tries each [decoder] in order, retunring the result of the first that succeeds + +{b Returns} an ['a] if one of the decoders succeed. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise "23" |> Decode.(oneOf [int; field "x" int]) + (* returns 42 *) + let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(oneOf [int; field "x" int]) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(oneOf [int; field "x" int] +]} +*) + +val either : 'a decoder -> 'a decoder -> 'a decoder +(** Tries each [decoder] in order, retunring the result of the first that succeeds + +{b Returns} an ['a] if one of the decoders succeed. + +@raise [DecodeError] if unsuccessful + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise "23" |> Decode.(either int (field "x" int)) + (* returns 42 *) + let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(either int (field "x" int)) + (* raises DecodeError *) + let _ = Json.parseOrRaise "null" |> Decode.(either int (field "x" int)) +]} +*) + +val withDefault : 'a -> 'a decoder -> 'a decoder +(** Tries the given [decoder] and returns its result if it succeeds, or the +given default value if it fails. + +{b Returns} an ['a]. + +@example {[ + open Json + (* returns 23 *) + let _ = Json.parseOrRaise "23" |> Decode.withDefault 0 int + (* returns 0 *) + let _ = Json.parseOrRaise "\"x\"" |> Decode.withDefault 0 int + (* returns 0 *) + let _ = Json.parseOrRaise "null" |> Decode.withDefault 0 int +]} +*) + +val map : ('a -> 'b) -> 'a decoder -> 'b decoder +(** Returns a decoder that maps the result of the given decoder if successful + +{b Returns} a ['b] if the given decoder succeeds. + +@example {[ + open Json + (* returns 46 *) + let _ = Json.parseOrRaise "23" |> Decode.map (fun x -> x + x) int +]} +*) + +val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder +(** Returns a decoder that maps the result of the given decoder if successful + +{b Returns} an ['a] if both decoders succeed. + +@example {[ + (* Decode a JSON tree structure *) + type 'a tree = + | Node of 'a * 'a tree list + | Leaf of 'a + + module Decode = struct + open Json.Decode + + let rec tree decoder = + field "type" string |> andThen ( + function | "node" -> node decoder + | "leaf" -> leaf decoder + | _ -> failwith "unknown node type" + ) + + and node decoder json = + Node ( + (json |> field "value" decoder), + (json |> field "children" (array (tree decoder) |> map Array.to_list)) + ) + + and leaf decoder json = + Leaf (json |> field "value" decoder) + end + + let json = {| { + "type": "node", + "value": 9, + "children": [{ + "type": "node", + "value": 5, + "children": [{ + "type": "leaf", + "value": 3 + }, { + "type": "leaf", + "value": 2 + }] + }, { + "type": "leaf", + "value": 4 + }] + } |} + + let myTree = + json |> Json.parseOrRaise + |> Decode.tree Json.Decode.int +]} +*) +end + +module Encode : sig +(** Provides functions for encoding a JSON data structure *) + +type 'a encoder = 'a -> Js.Json.t +(** The type of a encoder combinator *) + +external null : Js.Json.t = "null" + +(** [null] is the singleton null JSON value *) + +external string : string -> Js.Json.t = "%identity" +(** [string s] makes a JSON string of the [string] [s] *) + +external float : float -> Js.Json.t = "%identity" +(** [float n] makes a JSON number of the [float] [n] *) + +external int : int -> Js.Json.t = "%identity" +(** [int n] makes a JSON number of the [int] [n] *) + +external bool : bool -> Js.Json.t = "%identity" +(** [bool b] makes a JSON boolean of the [bool] [b] *) + +val char : char -> Js.Json.t +(** [char c] makes a JSON string of the [char] [c] *) + +val date : Js.Date.t -> Js.Json.t +(** [date d] makes an ISO 8601 JSON string of the [Js.Date.t] [d] *) + +val nullable : 'a encoder -> 'a option -> Js.Json.t +(** [nullable encoder option] returns either the encoded value or [null] *) + +val withDefault : Js.Json.t -> 'a encoder -> 'a option -> Js.Json.t +(** [withDefault default encoder option] returns the encoded value if present, oterwise [default] *) + +val pair : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t +(** [pair encoder encoder tuple] creates a JSON array from a tuple of size 2 *) + +val tuple2 : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t +(** [tuple2 encoder encoder tuple] creates a JSON array from a tuple of size 2. Alias of [pair] *) + +val tuple3 : 'a encoder -> 'b encoder -> 'c encoder -> 'a * 'b * 'c -> Js.Json.t +(** [tuple3 enc enc enc tuple] creates a JSON array from a tuple of size 3 *) + +val tuple4 : + 'a encoder -> + 'b encoder -> + 'c encoder -> + 'd encoder -> + 'a * 'b * 'c * 'd -> + Js.Json.t +(** [tuple4 enc enc enc enc tuple] creates a JSON array from a tuple of size 4 *) + +external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" +(** [jsonDict d] makes a JSON object of the [Js.Dict.t] [d] *) + +val dict : 'a encoder -> 'a Js.Dict.t encoder +(** [dict encoder d] makes a JSON object of the [Js.Dict.t] [d] with the given [encoder] *) + +val object_ : (string * Js.Json.t) list -> Js.Json.t +(** [object_ props] makes a JSON object of the [props] list of properties *) + +val array : 'a encoder -> 'a array encoder +(** [array encoder l] makes a JSON array of the [list] [l] using the given [encoder] + * NOTE: This will be renamed `array` once the existing and deprecated `array` function + * has been removed. + *) + +val list : 'a encoder -> 'a list encoder +(** [list encoder a] makes a JSON array of the [array] [a] using the given [encoder] *) + +(** The functions below are specialized for specific array type which + happened to be already JSON object in the BuckleScript runtime. Therefore + they are more efficient (constant time rather than linear conversion). *) + +external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" +(** [jsonArray a] makes a JSON array of the [Js.Json.t array] [a] *) + +external stringArray : string array -> Js.Json.t = "%identity" +(** [stringArray a] makes a JSON array of the [string array] [a] *) + +external numberArray : float array -> Js.Json.t = "%identity" +(** [numberArray a] makes a JSON array of the [float array] [a] *) + +external boolArray : bool array -> Js.Json.t = "%identity" +(** [boolArray] makes a JSON array of the [bool array] [a] *) +end exception ParseError of string diff --git a/src/Json_decode.mli b/src/Json_decode.mli deleted file mode 100644 index e2dc3e1..0000000 --- a/src/Json_decode.mli +++ /dev/null @@ -1,499 +0,0 @@ -(** Provides a set of low level combinator primitives to decode Js.Json.t data -structures -A decoder combinator will return the decoded value if successful, or raise a -[DecodeError of string] if unsuccessful, where the string argument contains the -error message. -Decoders are designed to be combined to produce more complex decoders that can -decode arbitrary data structures, though the emphasis for this library is for -it to be {i possible} to decode any given data structure, not necessarily for -it to be {i convenient}. For convenience you should look towards opinionated -third-party libraries. -*) - -type 'a decoder = Js.Json.t -> 'a -(** The type of a decoder combinator *) - -type error = Json_error of string | Unexpected_variant of string - -val error_to_string : error -> string - -exception DecodeError of error - -val id : Js.Json.t decoder -(** Identity decoder. - - {b Returns} the input JSON value. - - Always succeeds. You would use this if you wanted to partially decode - some JSON in stages; in the first stage you could decode some portion - of the input, while using [id] to keep the rest as JSON and decoding - that in subsequent stages. - - @example {[ - open Json - (* returns [(1 : int, {"a": true} : Js.Json.t)] *) - let json = parseOrRaise {|{"id": 1, {"a": true}}|} - let _ = Decode.(int json, id json) - ]} *) - -val bool : bool decoder -(** Decodes a JSON value into a [bool] - -{b Returns} a [bool] if the JSON value is a [true] or [false]. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns true *) - let _ = Json.parseOrRaise "true" |> Decode.bool - (* returns false *) - let _ = Json.parseOrRaise "false" |> Decode.bool - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.bool - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.bool -]} -*) - -val float : float decoder -(** Decodes a JSON value into a [float] - -{b Returns} a [float] if the JSON value is a number. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 1.23 *) - let _ = Json.parseOrRaise "1.23" |> Decode.float - (* returns 23. *) - let _ = Json.parseOrRaise "23" |> Decode.float - (* raises DecodeError *) - let _ = Json.parseOrRaise "true" |> Decode.float - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.float -]} -*) - -val int : int decoder -(** Decodes a JSON value into an [int] - -{b Returns} an [int] if the JSON value is a number. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "true" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.int -]} -*) - -val string : string decoder -(** Decodes a JSON value into a [string] - -{b Returns} a [string] if the JSON value is a string. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns "foo" *) - let _ = Json.parseOrRaise "\"foo\"" |> Decode.string - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.string - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.string -]} -*) - -val char : char decoder -(** Decodes a JSON value into a [char] - -{b Returns} a [char] if the JSON value is a single-character string. - -@raise [DecodeError] if unsuccessful. - -@example {[ - open Json - (* returns 'a' *) - let _ = Json.parseOrRaise "\"a\"" |> Decode.char - (* raises DecodeError *) - let _ = Json.parseOrRaise "\"abc\"" |> Decode.char - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.char -]} -*) - -val date : Js.Date.t decoder -(** Decodes an ISO8601-formatted JSON string into a [Js.Date.t] - -{b Returns} a [Js.Date.t] if the JSON value is an IS8601-formatted string. - -@raise [DecodeError] if unsuccessful -*) - -val nullable : 'a decoder -> 'a Js.null decoder -(** Decodes a JSON value into an ['a Js.null] - -{b Returns} [Js.null] if the JSON value is [null], or an ['a Js.null] if the -given decoder succeeds, - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (Js.Null.return 23) *) - let _ = Json.parseOrRaise "23" |> Decode.(nullable int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.(nullable int) - (* returns Js.null *) - let _ = Json.parseOrRaise "null" |> Decode.(nullable int) -]} -*) - -val nullAs : 'a -> 'a decoder -(** Returns the given value if the JSON value is [null] - -{b Returns} an ['a] if the JSON value is [null]. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* raises DecodeError *) - let _ = Json.parseOrRaise "\"x\"" |> Decode.nullAs "x" - (* returns "x" *) - let _ = Json.parseOrRaise "null" |> Decode.nullAs "x" - (* returns None *) - let _ = Json.parseOrRaise "null" |> Decode.nullAs None -]} -*) - -val array : 'a decoder -> 'a array decoder -(** Decodes a JSON array into an ['a array] using the given decoder on each element - -{b Returns} an ['a array] if the JSON value is a JSON array and all its -elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns [| 1; 2; 3 |] *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(array int) -]} -*) - -val list : 'a decoder -> 'a list decoder -(** Decodes a JSON array into an ['a list] using the given decoder on each element - -{b Returns} an ['a list] if the JSON value is a JSON array and all its -elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns [1; 2; 3] *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(list int) -]} -*) - -val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder -(** Decodes a JSON array with two elements into an ['a * 'b] tuple using - each of the given decoders in order. - -{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both - its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (1, "bar") *) - let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(pair int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2]" |> Decode.(pair int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(pair int int) -]} -*) - -val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder -(** Decodes a JSON array with two elements into an ['a * 'b] tuple using - each of the given decoders in order. - -{b Alias of [pair]} - -{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both - its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (1, "bar") *) - let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(tuple2 int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2]" |> Decode.(tuple2 int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(tuple2 int int) -]} -*) - -val tuple3 : 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder -(** Decodes a JSON array with three elements into an ['a * 'b * 'c] tuple using - each of the given decoders in order. - -{b Returns} an ['a * 'b * 'c] if the JSON value is a JSON array of length 3 and - all its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful -*) - -val tuple4 : 'a decoder -> 'b decoder -> 'c decoder -> 'd decoder -> ('a * 'b * 'c * 'd) decoder -(** Decodes a JSON array with four elements into an ['a * 'b * 'c * 'd] tuple - using each of the given decoders in order. - -{b Returns} an ['a * 'b * 'c * 'd] if the JSON value is a JSON array of length 4 - and all its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful -*) - -val dict : 'a decoder -> 'a Js.Dict.t decoder -(** Decodes a JSON object into a dict using the given decoder on each of its values - -{b Returns} an ['a Js.Dict.t] if the JSON value is a JSON object and all its -values are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (Js.Dict.fromList [("x", 23); ("y", 42)]) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(dict int) -]} -*) - -val field : string -> 'a decoder -> 'a decoder -(** Decodes a JSON object with a specific field into the value of that field - -{b Returns} an ['a] if the JSON value is a JSON object with the given field -and a value that is successfully decoded with the given decoder. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(field "x" int) - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(field "x" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(field "x" int) -]} -*) - -val at : string list -> 'a decoder -> 'a decoder -(** Same as [field] but takes a top level field and a list of nested fields for decoding nested values. - -{b Returns} an ['a] if the JSON value is a JSON object with the given field -and a value that is successfully decoded with the given decoder. - -@raise [DecodeError] if unsuccessful -@raise [Invalid_argument] if list of fields is empty - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": {"foo": 23}, "y": 42 } |} |> Decode.(at ["x"; "foo"] int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": null, "y": "b" } |} |> Decode.(at ["x"; "foo"] int) -]} -*) - -val optional : 'a decoder -> 'a option decoder -(** Maps a decoder [result] to an option - -{b Returns} [Some of 'a] if the given decoder is successful, [None] if -it is not. - -This decoder will never raise a [DecodeError]. Its purpose is to catch and -transform [DecodeError]'s of a given decoder into [None]s by mapping its -[result] into an [option]. This prevents a decoder error from terminating -a composite decoder, and is useful to decode optional JSON object fields. - -@example {[ - open Json - (* returns (Some 23) *) - let _ = Json.parseOrRaise "23" |> Decode.(optional int) - (* returns None *) - let _ = Json.parseOrRaise 1.23 |> Decode.(optional int) - (* returns None *) - let _ = Json.parseOrRaise "null" |> Decode.(optional int) - (* returns (Some 23) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "x" int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "y" int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "z" int)) - (* returns (Some 23) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" (optional int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" (optional int)) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "z" (optional int)) -]} -*) - -val oneOf : 'a decoder list -> 'a decoder -(** Tries each [decoder] in order, retunring the result of the first that succeeds - -{b Returns} an ['a] if one of the decoders succeed. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.(oneOf [int; field "x" int]) - (* returns 42 *) - let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(oneOf [int; field "x" int]) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(oneOf [int; field "x" int] -]} -*) - -val either : 'a decoder -> 'a decoder -> 'a decoder -(** Tries each [decoder] in order, retunring the result of the first that succeeds - -{b Returns} an ['a] if one of the decoders succeed. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.(either int (field "x" int)) - (* returns 42 *) - let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(either int (field "x" int)) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(either int (field "x" int)) -]} -*) - -val withDefault : 'a -> 'a decoder -> 'a decoder -(** Tries the given [decoder] and returns its result if it succeeds, or the -given default value if it fails. - -{b Returns} an ['a]. - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.withDefault 0 int - (* returns 0 *) - let _ = Json.parseOrRaise "\"x\"" |> Decode.withDefault 0 int - (* returns 0 *) - let _ = Json.parseOrRaise "null" |> Decode.withDefault 0 int -]} -*) - -val map : ('a -> 'b) -> 'a decoder -> 'b decoder -(** Returns a decoder that maps the result of the given decoder if successful - -{b Returns} a ['b] if the given decoder succeeds. - -@example {[ - open Json - (* returns 46 *) - let _ = Json.parseOrRaise "23" |> Decode.map (fun x -> x + x) int -]} -*) - -val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder -(** Returns a decoder that maps the result of the given decoder if successful - -{b Returns} an ['a] if both decoders succeed. - -@example {[ - (* Decode a JSON tree structure *) - type 'a tree = - | Node of 'a * 'a tree list - | Leaf of 'a - - module Decode = struct - open Json.Decode - - let rec tree decoder = - field "type" string |> andThen ( - function | "node" -> node decoder - | "leaf" -> leaf decoder - | _ -> failwith "unknown node type" - ) - - and node decoder json = - Node ( - (json |> field "value" decoder), - (json |> field "children" (array (tree decoder) |> map Array.to_list)) - ) - - and leaf decoder json = - Leaf (json |> field "value" decoder) - end - - let json = {| { - "type": "node", - "value": 9, - "children": [{ - "type": "node", - "value": 5, - "children": [{ - "type": "leaf", - "value": 3 - }, { - "type": "leaf", - "value": 2 - }] - }, { - "type": "leaf", - "value": 4 - }] - } |} - - let myTree = - json |> Json.parseOrRaise - |> Decode.tree Json.Decode.int -]} -*) diff --git a/src/Json_encode.mli b/src/Json_encode.mli deleted file mode 100644 index a4ec3fb..0000000 --- a/src/Json_encode.mli +++ /dev/null @@ -1,84 +0,0 @@ -(** Provides functions for encoding a JSON data structure *) - -type 'a encoder = 'a -> Js.Json.t -(** The type of a encoder combinator *) - -external null : Js.Json.t = "null" - -(** [null] is the singleton null JSON value *) - -external string : string -> Js.Json.t = "%identity" -(** [string s] makes a JSON string of the [string] [s] *) - -external float : float -> Js.Json.t = "%identity" -(** [float n] makes a JSON number of the [float] [n] *) - -external int : int -> Js.Json.t = "%identity" -(** [int n] makes a JSON number of the [int] [n] *) - -external bool : bool -> Js.Json.t = "%identity" -(** [bool b] makes a JSON boolean of the [bool] [b] *) - -val char : char -> Js.Json.t -(** [char c] makes a JSON string of the [char] [c] *) - -val date : Js.Date.t -> Js.Json.t -(** [date d] makes an ISO 8601 JSON string of the [Js.Date.t] [d] *) - -val nullable : 'a encoder -> 'a option -> Js.Json.t -(** [nullable encoder option] returns either the encoded value or [null] *) - -val withDefault : Js.Json.t -> 'a encoder -> 'a option -> Js.Json.t -(** [withDefault default encoder option] returns the encoded value if present, oterwise [default] *) - -val pair : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t -(** [pair encoder encoder tuple] creates a JSON array from a tuple of size 2 *) - -val tuple2 : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t -(** [tuple2 encoder encoder tuple] creates a JSON array from a tuple of size 2. Alias of [pair] *) - -val tuple3 : 'a encoder -> 'b encoder -> 'c encoder -> 'a * 'b * 'c -> Js.Json.t -(** [tuple3 enc enc enc tuple] creates a JSON array from a tuple of size 3 *) - -val tuple4 : - 'a encoder -> - 'b encoder -> - 'c encoder -> - 'd encoder -> - 'a * 'b * 'c * 'd -> - Js.Json.t -(** [tuple4 enc enc enc enc tuple] creates a JSON array from a tuple of size 4 *) - -external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" -(** [jsonDict d] makes a JSON object of the [Js.Dict.t] [d] *) - -val dict : 'a encoder -> 'a Js.Dict.t encoder -(** [dict encoder d] makes a JSON object of the [Js.Dict.t] [d] with the given [encoder] *) - -val object_ : (string * Js.Json.t) list -> Js.Json.t -(** [object_ props] makes a JSON object of the [props] list of properties *) - -val array : 'a encoder -> 'a array encoder -(** [array encoder l] makes a JSON array of the [list] [l] using the given [encoder] - * NOTE: This will be renamed `array` once the existing and deprecated `array` function - * has been removed. - *) - -val list : 'a encoder -> 'a list encoder -(** [list encoder a] makes a JSON array of the [array] [a] using the given [encoder] *) - -(** The functions below are specialized for specific array type which - happened to be already JSON object in the BuckleScript runtime. Therefore - they are more efficient (constant time rather than linear conversion). *) - -external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" -(** [jsonArray a] makes a JSON array of the [Js.Json.t array] [a] *) - -external stringArray : string array -> Js.Json.t = "%identity" -(** [stringArray a] makes a JSON array of the [string array] [a] *) - -external numberArray : float array -> Js.Json.t = "%identity" -(** [numberArray a] makes a JSON array of the [float array] [a] *) - -external boolArray : bool array -> Js.Json.t = "%identity" -(** [boolArray] makes a JSON array of the [bool array] [a] *) From 74c442cc9b1cf5fdd68b3c38745430daf814d2e5 Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Thu, 5 Dec 2024 10:39:31 +0400 Subject: [PATCH 02/20] Inline Json_decode/Json_encode into Json --- src/Json.ml | 254 ++++++++++++++++++++++++++++++++++++++++++++- src/Json_decode.ml | 197 ----------------------------------- src/Json_encode.ml | 50 --------- 3 files changed, 252 insertions(+), 249 deletions(-) delete mode 100644 src/Json_decode.ml delete mode 100644 src/Json_encode.ml diff --git a/src/Json.ml b/src/Json.ml index c1dea7c..ca68819 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -1,5 +1,255 @@ -module Decode = Json_decode -module Encode = Json_encode +module Decode = struct +external _unsafeCreateUninitializedArray : int -> 'a array = "Array" +[@@mel.new] + +external _stringify : Js.Json.t -> string = "JSON.stringify" + +let _isInteger value = + Js.Float.isFinite value && Js.Math.floor_float value == value + +type 'a decoder = Js.Json.t -> 'a +type error = Json_error of string | Unexpected_variant of string + +let error_to_string = function + | Json_error msg -> msg + | Unexpected_variant tag -> "unexpected variant: " ^ tag + +exception DecodeError of error + +let error msg = raise (DecodeError (Json_error msg)) +let id json = json + +let bool json = + if Js.typeof json = "boolean" then (Obj.magic (json : Js.Json.t) : bool) + else error ("Expected boolean, got " ^ _stringify json) + +let float json = + if Js.typeof json = "number" then (Obj.magic (json : Js.Json.t) : float) + else error ("Expected number, got " ^ _stringify json) + +let int json = + let f = float json in + if _isInteger f then (Obj.magic (f : float) : int) + else error ("Expected integer, got " ^ _stringify json) + +let string json = + if Js.typeof json = "string" then + (Obj.magic (json : Js.Json.t) : string) + else error ("Expected string, got " ^ _stringify json) + +let char json = + let s = string json in + if String.length s = 1 then String.get s 0 + else error ("Expected single-character string, got " ^ _stringify json) + +let date json = json |> string |> Js.Date.fromString + +let nullable decode json = + if (Obj.magic json : 'a Js.null) == Js.null then Js.null + else Js.Null.return (decode json) + +(* TODO: remove this? *) +let nullAs value json = + if (Obj.magic json : 'a Js.null) == Js.null then value + else error ("Expected null, got " ^ _stringify json) + +let array decode json = + if Js.Array.isArray json then ( + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + let target = _unsafeCreateUninitializedArray length in + for i = 0 to length - 1 do + let value = + try decode (Array.unsafe_get source i) + with DecodeError err -> + error + (error_to_string err + ^ "\n\tin array at index " + ^ string_of_int i) + in + Array.unsafe_set target i value + done; + target) + else error ("Expected array, got " ^ _stringify json) + +let list decode json = json |> array decode |> Array.to_list + +let pair decodeA decodeB json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 2 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1) ) + with DecodeError err -> + error (error_to_string err ^ "\n\tin pair/tuple2") + else + let length = Js.String.make length in + error {j|Expected array of length 2, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + +let tuple2 = pair + +let tuple3 decodeA decodeB decodeC json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 3 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1), + decodeC (Array.unsafe_get source 2) ) + with DecodeError err -> + error (error_to_string err ^ "\n\tin tuple3") + else + let length = Js.String.make length in + error {j|Expected array of length 3, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + +let tuple4 decodeA decodeB decodeC decodeD json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 4 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1), + decodeC (Array.unsafe_get source 2), + decodeD (Array.unsafe_get source 3) ) + with DecodeError err -> + error (error_to_string err ^ "\n\tin tuple4") + else + let length = Js.String.make length in + error {j|Expected array of length 4, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + +let dict decode json = + if + Js.typeof json = "object" + && (not (Js.Array.isArray json)) + && not ((Obj.magic json : 'a Js.null) == Js.null) + then ( + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in + let keys = Js.Dict.keys source in + let l = Js.Array.length keys in + let target = Js.Dict.empty () in + for i = 0 to l - 1 do + let key = Array.unsafe_get keys i in + let value = + try decode (Js.Dict.unsafeGet source key) + with DecodeError err -> + error (error_to_string err ^ "\n\tin dict") + in + Js.Dict.set target key value + done; + target) + else error ("Expected object, got " ^ _stringify json) + +let field key decode json = + if + Js.typeof json = "object" + && (not (Js.Array.isArray json)) + && not ((Obj.magic json : 'a Js.null) == Js.null) + then + let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in + match Js.Dict.get dict key with + | Some value -> ( + try decode value + with DecodeError err -> + error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) + | None -> error {j|Expected field '$(key)'|j} + else error ("Expected object, got " ^ _stringify json) + +let rec at key_path decoder = + match key_path with + | [ key ] -> field key decoder + | first :: rest -> field first (at rest decoder) + | [] -> + raise + @@ Invalid_argument + "Expected key_path to contain at least one element" + +let optional decode json = + try Some (decode json) with DecodeError _ -> None + +let oneOf decoders json = + let rec inner decoders errors = + match decoders with + | [] -> + let formattedErrors = + "\n- " + ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) + in + error + ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} + ^ _stringify json) + | decode :: rest -> ( + try decode json with DecodeError e -> inner rest (e :: errors)) + in + inner decoders [] + +let either a b = oneOf [ a; b ] + +let withDefault default decode json = + try decode json with DecodeError _ -> default + +let map f decode json = f (decode json) +let andThen b a json = b (a json) json +end + +module Encode = struct +type 'a encoder = 'a -> Js.Json.t + +external null : Js.Json.t = "null" +external string : string -> Js.Json.t = "%identity" +external float : float -> Js.Json.t = "%identity" +external int : int -> Js.Json.t = "%identity" +external bool : bool -> Js.Json.t = "%identity" + +let char c = c |> String.make 1 |> string +let date d = d |> Js.Date.toJSONUnsafe |> string +let nullable encode = function None -> null | Some v -> encode v +let withDefault d encode = function None -> d | Some v -> encode v + +external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" + +let dict encode d = + let pairs = Js.Dict.entries d in + let encodedPairs = Array.map (fun (k, v) -> (k, encode v)) pairs in + jsonDict (Js.Dict.fromArray encodedPairs) + +let object_ props : Js.Json.t = props |> Js.Dict.fromList |> jsonDict + +external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" + +let array encode l = l |> Array.map encode |> jsonArray + +let list encode = function + | [] -> jsonArray [||] + | hd :: tl as l -> + let a = Array.make (List.length l) (encode hd) in + let rec fill i = function + | [] -> a + | hd :: tl -> + Array.unsafe_set a i (encode hd); + fill (i + 1) tl + in + jsonArray (fill 1 tl) + +let pair encodeA encodeB (a, b) = jsonArray [| encodeA a; encodeB b |] +let tuple2 = pair + +let tuple3 encodeA encodeB encodeC (a, b, c) = + jsonArray [| encodeA a; encodeB b; encodeC c |] + +let tuple4 encodeA encodeB encodeC encodeD (a, b, c, d) = + jsonArray [| encodeA a; encodeB b; encodeC c; encodeD d |] + +external stringArray : string array -> Js.Json.t = "%identity" +external numberArray : float array -> Js.Json.t = "%identity" +external boolArray : bool array -> Js.Json.t = "%identity" +end exception ParseError of string diff --git a/src/Json_decode.ml b/src/Json_decode.ml deleted file mode 100644 index 5abdf9b..0000000 --- a/src/Json_decode.ml +++ /dev/null @@ -1,197 +0,0 @@ -external _unsafeCreateUninitializedArray : int -> 'a array = "Array" -[@@mel.new] - -external _stringify : Js.Json.t -> string = "JSON.stringify" - -let _isInteger value = - Js.Float.isFinite value && Js.Math.floor_float value == value - -type 'a decoder = Js.Json.t -> 'a -type error = Json_error of string | Unexpected_variant of string - -let error_to_string = function - | Json_error msg -> msg - | Unexpected_variant tag -> "unexpected variant: " ^ tag - -exception DecodeError of error - -let error msg = raise (DecodeError (Json_error msg)) -let id json = json - -let bool json = - if Js.typeof json = "boolean" then (Obj.magic (json : Js.Json.t) : bool) - else error ("Expected boolean, got " ^ _stringify json) - -let float json = - if Js.typeof json = "number" then (Obj.magic (json : Js.Json.t) : float) - else error ("Expected number, got " ^ _stringify json) - -let int json = - let f = float json in - if _isInteger f then (Obj.magic (f : float) : int) - else error ("Expected integer, got " ^ _stringify json) - -let string json = - if Js.typeof json = "string" then - (Obj.magic (json : Js.Json.t) : string) - else error ("Expected string, got " ^ _stringify json) - -let char json = - let s = string json in - if String.length s = 1 then String.get s 0 - else error ("Expected single-character string, got " ^ _stringify json) - -let date json = json |> string |> Js.Date.fromString - -let nullable decode json = - if (Obj.magic json : 'a Js.null) == Js.null then Js.null - else Js.Null.return (decode json) - -(* TODO: remove this? *) -let nullAs value json = - if (Obj.magic json : 'a Js.null) == Js.null then value - else error ("Expected null, got " ^ _stringify json) - -let array decode json = - if Js.Array.isArray json then ( - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - let target = _unsafeCreateUninitializedArray length in - for i = 0 to length - 1 do - let value = - try decode (Array.unsafe_get source i) - with DecodeError err -> - error - (error_to_string err - ^ "\n\tin array at index " - ^ string_of_int i) - in - Array.unsafe_set target i value - done; - target) - else error ("Expected array, got " ^ _stringify json) - -let list decode json = json |> array decode |> Array.to_list - -let pair decodeA decodeB json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 2 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin pair/tuple2") - else - let length = Js.String.make length in - error {j|Expected array of length 2, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let tuple2 = pair - -let tuple3 decodeA decodeB decodeC json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 3 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1), - decodeC (Array.unsafe_get source 2) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple3") - else - let length = Js.String.make length in - error {j|Expected array of length 3, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let tuple4 decodeA decodeB decodeC decodeD json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 4 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1), - decodeC (Array.unsafe_get source 2), - decodeD (Array.unsafe_get source 3) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple4") - else - let length = Js.String.make length in - error {j|Expected array of length 4, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let dict decode json = - if - Js.typeof json = "object" - && (not (Js.Array.isArray json)) - && not ((Obj.magic json : 'a Js.null) == Js.null) - then ( - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in - let keys = Js.Dict.keys source in - let l = Js.Array.length keys in - let target = Js.Dict.empty () in - for i = 0 to l - 1 do - let key = Array.unsafe_get keys i in - let value = - try decode (Js.Dict.unsafeGet source key) - with DecodeError err -> - error (error_to_string err ^ "\n\tin dict") - in - Js.Dict.set target key value - done; - target) - else error ("Expected object, got " ^ _stringify json) - -let field key decode json = - if - Js.typeof json = "object" - && (not (Js.Array.isArray json)) - && not ((Obj.magic json : 'a Js.null) == Js.null) - then - let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in - match Js.Dict.get dict key with - | Some value -> ( - try decode value - with DecodeError err -> - error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) - | None -> error {j|Expected field '$(key)'|j} - else error ("Expected object, got " ^ _stringify json) - -let rec at key_path decoder = - match key_path with - | [ key ] -> field key decoder - | first :: rest -> field first (at rest decoder) - | [] -> - raise - @@ Invalid_argument - "Expected key_path to contain at least one element" - -let optional decode json = - try Some (decode json) with DecodeError _ -> None - -let oneOf decoders json = - let rec inner decoders errors = - match decoders with - | [] -> - let formattedErrors = - "\n- " - ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) - in - error - ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} - ^ _stringify json) - | decode :: rest -> ( - try decode json with DecodeError e -> inner rest (e :: errors)) - in - inner decoders [] - -let either a b = oneOf [ a; b ] - -let withDefault default decode json = - try decode json with DecodeError _ -> default - -let map f decode json = f (decode json) -let andThen b a json = b (a json) json diff --git a/src/Json_encode.ml b/src/Json_encode.ml deleted file mode 100644 index a91c3ff..0000000 --- a/src/Json_encode.ml +++ /dev/null @@ -1,50 +0,0 @@ -type 'a encoder = 'a -> Js.Json.t - -external null : Js.Json.t = "null" -external string : string -> Js.Json.t = "%identity" -external float : float -> Js.Json.t = "%identity" -external int : int -> Js.Json.t = "%identity" -external bool : bool -> Js.Json.t = "%identity" - -let char c = c |> String.make 1 |> string -let date d = d |> Js.Date.toJSONUnsafe |> string -let nullable encode = function None -> null | Some v -> encode v -let withDefault d encode = function None -> d | Some v -> encode v - -external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" - -let dict encode d = - let pairs = Js.Dict.entries d in - let encodedPairs = Array.map (fun (k, v) -> (k, encode v)) pairs in - jsonDict (Js.Dict.fromArray encodedPairs) - -let object_ props : Js.Json.t = props |> Js.Dict.fromList |> jsonDict - -external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" - -let array encode l = l |> Array.map encode |> jsonArray - -let list encode = function - | [] -> jsonArray [||] - | hd :: tl as l -> - let a = Array.make (List.length l) (encode hd) in - let rec fill i = function - | [] -> a - | hd :: tl -> - Array.unsafe_set a i (encode hd); - fill (i + 1) tl - in - jsonArray (fill 1 tl) - -let pair encodeA encodeB (a, b) = jsonArray [| encodeA a; encodeB b |] -let tuple2 = pair - -let tuple3 encodeA encodeB encodeC (a, b, c) = - jsonArray [| encodeA a; encodeB b; encodeC c |] - -let tuple4 encodeA encodeB encodeC encodeD (a, b, c, d) = - jsonArray [| encodeA a; encodeB b; encodeC c; encodeD d |] - -external stringArray : string array -> Js.Json.t = "%identity" -external numberArray : float array -> Js.Json.t = "%identity" -external boolArray : bool array -> Js.Json.t = "%identity" From 881fe798bd6eac221ad97f428113971f0a3ee427 Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Thu, 5 Dec 2024 10:41:28 +0400 Subject: [PATCH 03/20] fmt --- examples/complex.ml | 35 +-- examples/decode.ml | 6 +- examples/dune | 3 +- examples/dynamicDict_Ocaml.ml | 37 +-- examples/dynamicDict_Reason.re | 49 ++- examples/encode.ml | 22 +- examples/parse.ml | 2 +- examples/tree.ml | 62 ++-- ppx/browser/ppx_deriving_json_js.ml | 10 +- ppx/native/ppx_deriving_tools.ml | 58 ++-- ppx/native/ppx_deriving_tools.mli | 51 +-- src/Json.ml | 461 ++++++++++++++-------------- src/Json.mli | 304 +++++++++--------- src/__tests__/Json_decode_test.ml | 300 +++++++++++++----- src/__tests__/Json_encode_test.ml | 238 ++++++-------- src/__tests__/Json_test.ml | 10 +- 16 files changed, 869 insertions(+), 779 deletions(-) diff --git a/examples/complex.ml b/examples/complex.ml index 03fc4e2..2b7a2fb 100644 --- a/examples/complex.ml +++ b/examples/complex.ml @@ -1,34 +1,23 @@ -type line = { - start: point; - end_: point; - thickness: int option -} -and point = { - x: int; - y: int -} +type line = { start : point; end_ : point; thickness : int option } +and point = { x : int; y : int } module Decode = struct let point json = - Json.Decode.{ - x = json |> field "x" int; - y = json |> field "y" int - } + Json.Decode.{ x = json |> field "x" int; y = json |> field "y" int } let line json = - Json.Decode.{ - start = json |> field "start" point; - end_ = json |> field "end" point; - thickness = json |> optional (field "thickness" int) - } + Json.Decode. + { + start = json |> field "start" point; + end_ = json |> field "end" point; + thickness = json |> optional (field "thickness" int); + } end -let data = {| { +let data = + {| { "start": { "x": 1, "y": -4 }, "end": { "x": 5, "y": 8 } } |} -let _ = - data |> Json.parseOrRaise - |> Decode.line - |> Js.log \ No newline at end of file +let _ = data |> Json.parseOrRaise |> Decode.line |> Js.log diff --git a/examples/decode.ml b/examples/decode.ml index d8024d1..250c9b0 100644 --- a/examples/decode.ml +++ b/examples/decode.ml @@ -3,7 +3,8 @@ let mapJsonObjectString f decoder (encoder : int -> Js.Json.t) str = let json = Json.parseOrRaise str in Json.Decode.(dict decoder json) |> Js.Dict.map ~f:(fun [@u] v -> f v) - |> Json.Encode.dict encoder |> Json.stringify + |> Json.Encode.dict encoder + |> Json.stringify let sum = Array.fold_left ( + ) 0 @@ -25,4 +26,5 @@ let _ = let json = {|{ "y": 42 } |} |> Json.parseOrRaise in match Json.Decode.(field "x" int json) with | x -> Js.log x - | exception Json.Decode.DecodeError err -> Js.log ("Error:" ^ Json.Decode.error_to_string err) + | exception Json.Decode.DecodeError err -> + Js.log ("Error:" ^ Json.Decode.error_to_string err) diff --git a/examples/dune b/examples/dune index 36afaf2..d601f1a 100644 --- a/examples/dune +++ b/examples/dune @@ -2,4 +2,5 @@ (target examples) (alias examples) (libraries melange-json) - (preprocess (pps melange.ppx))) + (preprocess + (pps melange.ppx))) diff --git a/examples/dynamicDict_Ocaml.ml b/examples/dynamicDict_Ocaml.ml index 721174e..a80050d 100644 --- a/examples/dynamicDict_Ocaml.ml +++ b/examples/dynamicDict_Ocaml.ml @@ -13,47 +13,40 @@ Could be dynamic JS keys generated by user or generally at run time. *) -type obj = { - static: string; - dynamics: int Js.Dict.t; -} +type obj = { static : string; dynamics : int Js.Dict.t } module Decode = struct let obj json = - Json.Decode.{ - static = json |> field "static" string; - dynamics = json |> field "dynamics" (dict int) - } + Json.Decode. + { + static = json |> field "static" string; + dynamics = json |> field "dynamics" (dict int); + } end module Encode = struct let obj c = Json.Encode.( - object_ [ - "static", c.static |> string; - "dynamics", c.dynamics |> dict int - ] - ) + object_ + [ + "static", c.static |> string; "dynamics", c.dynamics |> dict int; + ]) end -let data = {| { +let data = + {| { "static": "hi", "dynamics": { "hello": 5, "random": 8 } } |} -let decodedData = - data |> Json.parseOrRaise - |> Decode.obj +let decodedData = data |> Json.parseOrRaise |> Decode.obj (* Will log [ 'hi', { hello: 5, random: 8 } ] *) -let _ = - decodedData |> Js.log +let _ = decodedData |> Js.log (* Will log { static: 'hi', dynamics: { hello: 5, random: 8 } } *) -let encodedDataBack = - decodedData |> Encode.obj - |> Js.log \ No newline at end of file +let encodedDataBack = decodedData |> Encode.obj |> Js.log diff --git a/examples/dynamicDict_Reason.re b/examples/dynamicDict_Reason.re index 98e454a..be3e76c 100644 --- a/examples/dynamicDict_Reason.re +++ b/examples/dynamicDict_Reason.re @@ -1,21 +1,21 @@ /* - Handling an object with dynamic keys for sub-objects. - example: - { - static: "hello", - dynamics: { - "undetermined1": 2 - "undetermined2": 6 - } - } - - Where the "undetermined" keys, are unknown at compile time. - Could be dynamic JS keys generated by user or generally at run time. -*/ + Handling an object with dynamic keys for sub-objects. + example: + { + static: "hello", + dynamics: { + "undetermined1": 2 + "undetermined2": 6 + } + } + + Where the "undetermined" keys, are unknown at compile time. + Could be dynamic JS keys generated by user or generally at run time. + */ type obj = { static: string, - dynamics: Js.Dict.t(int) + dynamics: Js.Dict.t(int), }; module Decode = { @@ -27,7 +27,7 @@ module Decode = { }; module Encode = { - let obj = (c) => { + let obj = c => { Json.Encode.( object_([ ("static", string(c.static)), @@ -42,19 +42,14 @@ let data = {| { "dynamics": { "hello": 5, "random": 8 } } |}; -let decodedData = - data |> Json.parseOrRaise - |> Decode.obj; +let decodedData = data |> Json.parseOrRaise |> Decode.obj; /* -Will log [ 'hi', { hello: 5, random: 8 } ] -*/ -let _ = - decodedData |> Js.log; + Will log [ 'hi', { hello: 5, random: 8 } ] + */ +let _ = decodedData |> Js.log; /* -Will log { static: 'hi', dynamics: { hello: 5, random: 8 } } -*/ -let encodedDataBack = - decodedData |> Encode.obj - |> Js.log; \ No newline at end of file + Will log { static: 'hi', dynamics: { hello: 5, random: 8 } } + */ +let encodedDataBack = decodedData |> Encode.obj |> Js.log; diff --git a/examples/encode.ml b/examples/encode.ml index bfd6a01..7ef86b8 100644 --- a/examples/encode.ml +++ b/examples/encode.ml @@ -2,7 +2,10 @@ (* prints ["foo", "bar"] *) let _ = - [| "foo"; "bar" |] |> Json.Encode.stringArray |> Json.stringify |> Js.log + [| "foo"; "bar" |] + |> Json.Encode.stringArray + |> Json.stringify + |> Js.log (* prints ["foo", "bar"] *) let _ = @@ -13,7 +16,8 @@ let _ = |> Js.log (* prints { x: 42, foo: 'bar' } *) -let _ = Json.Encode.(object_ [ ("x", int 42); ("foo", string "bar") ] |> Js.log) +let _ = + Json.Encode.(object_ [ "x", int 42; "foo", string "bar" ] |> Js.log) (* Advanced example: encode a record *) type line = { start : point; end_ : point; thickness : int option } @@ -22,15 +26,16 @@ and point = { x : float; y : float } module Encode = struct let point r = let open! Json.Encode in - object_ [ ("x", float r.x); ("y", float r.y) ] + object_ [ "x", float r.x; "y", float r.y ] let line r = Json.Encode.( object_ [ - ("start", point r.start); - ("end", point r.end_); - ("thickness", match r.thickness with Some x -> int x | None -> null); + "start", point r.start; + "end", point r.end_; + ( "thickness", + match r.thickness with Some x -> int x | None -> null ); ]) end @@ -41,7 +46,4 @@ let data = thickness = Some 2; } -let _ = - data - |> Encode.line - |> Js.log +let _ = data |> Encode.line |> Js.log diff --git a/examples/parse.ml b/examples/parse.ml index 1ae4dad..8582c14 100644 --- a/examples/parse.ml +++ b/examples/parse.ml @@ -5,4 +5,4 @@ let arrayOfInts str = Json.Decode.(array int json) (* prints `[3, 2, 1]` *) -let _ = Js.log (arrayOfInts "[1, 2, 3]" |> Js.Array.reverseInPlace) \ No newline at end of file +let _ = Js.log (arrayOfInts "[1, 2, 3]" |> Js.Array.reverseInPlace) diff --git a/examples/tree.ml b/examples/tree.ml index f8fe1d2..e46b19e 100644 --- a/examples/tree.ml +++ b/examples/tree.ml @@ -1,45 +1,45 @@ (* Decode a JSON tree structure *) -type 'a tree = -| Node of 'a * 'a tree list -| Leaf of 'a +type 'a tree = Node of 'a * 'a tree list | Leaf of 'a module Decode = struct open Json.Decode let rec tree decoder = - field "type" string |> andThen ( - function | "node" -> node decoder - | "leaf" -> leaf decoder - | _ -> failwith "unknown node type" - ) + field "type" string + |> andThen (function + | "node" -> node decoder + | "leaf" -> leaf decoder + | _ -> failwith "unknown node type") and node decoder json = - Node ( - (json |> field "value" decoder), - (json |> field "children" (array (tree decoder) |> map Array.to_list)) - ) + Node + ( json |> field "value" decoder, + json + |> field "children" (array (tree decoder) |> map Array.to_list) ) - and leaf decoder json = - Leaf (json |> field "value" decoder) + and leaf decoder json = Leaf (json |> field "value" decoder) end -let rec indent = - function | n when n <= 0 -> () - | n -> print_string " "; indent (n - 1) +let rec indent = function + | n when n <= 0 -> () + | n -> + print_string " "; + indent (n - 1) let print = - let rec aux level = - function | Node (value, children) -> - indent level; - Js.log value; - children |> List.iter (fun child -> aux (level + 1) child) - | Leaf value -> - indent level; - Js.log value - in - aux 0 - -let json = {| { + let rec aux level = function + | Node (value, children) -> + indent level; + Js.log value; + children |> List.iter (fun child -> aux (level + 1) child) + | Leaf value -> + indent level; + Js.log value + in + aux 0 + +let json = + {| { "type": "node", "value": 9, "children": [{ @@ -59,6 +59,4 @@ let json = {| { } |} let myTree = - json |> Json.parseOrRaise - |> Decode.tree Json.Decode.int - |> print \ No newline at end of file + json |> Json.parseOrRaise |> Decode.tree Json.Decode.int |> print diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 5437daf..5afcb83 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -31,7 +31,7 @@ module Of_json = struct [%expr match Js.Undefined.toOption - [%e fs] ## [%e pexp_ident ~loc:n.loc (map_loc lident n)] + [%e fs]##[%e pexp_ident ~loc:n.loc (map_loc lident n)] with | Stdlib.Option.Some v -> [%e derive ld.pld_type [%expr v]] | Stdlib.Option.None -> @@ -194,13 +194,17 @@ module To_json = struct | Vcs_record (n, r) -> let loc = n.loc in let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in - let tag = [%expr (Obj.magic [%e estring ~loc:n.loc n.txt]: Js.Json.t)] in + let tag = + [%expr (Obj.magic [%e estring ~loc:n.loc n.txt] : Js.Json.t)] + in let es = [ derive_of_record derive r es ] in as_json ~loc (pexp_array ~loc (tag :: es)) | Vcs_tuple (n, t) -> let loc = n.loc in let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in - let tag = [%expr (Obj.magic [%e estring ~loc:n.loc n.txt]: Js.Json.t)] in + let tag = + [%expr (Obj.magic [%e estring ~loc:n.loc n.txt] : Js.Json.t)] + in let es = List.map2 t.tpl_types es ~f:derive in as_json ~loc (pexp_array ~loc (tag :: es)) diff --git a/ppx/native/ppx_deriving_tools.ml b/ppx/native/ppx_deriving_tools.ml index 04215b1..0649f46 100644 --- a/ppx/native/ppx_deriving_tools.ml +++ b/ppx/native/ppx_deriving_tools.ml @@ -198,38 +198,38 @@ module Schema = struct method virtual t : loc:location -> label loc -> core_type -> core_type - method derive_of_tuple - : core_type -> core_type list -> expression -> expression = + method derive_of_tuple : + core_type -> core_type list -> expression -> expression = fun t _ _ -> let loc = t.ptyp_loc in not_supported "tuple types" ~loc - method derive_of_record - : type_declaration -> - label_declaration list -> - expression -> - expression = + method derive_of_record : + type_declaration -> + label_declaration list -> + expression -> + expression = fun td _ _ -> let loc = td.ptype_loc in not_supported "record types" ~loc - method derive_of_variant - : type_declaration -> - constructor_declaration list -> - expression -> - expression = + method derive_of_variant : + type_declaration -> + constructor_declaration list -> + expression -> + expression = fun td _ _ -> let loc = td.ptype_loc in not_supported "variant types" ~loc - method derive_of_polyvariant - : core_type -> row_field list -> expression -> expression = + method derive_of_polyvariant : + core_type -> row_field list -> expression -> expression = fun t _ _ -> let loc = t.ptyp_loc in not_supported "polyvariant types" ~loc - method private derive_type_ref_name - : label -> longident loc -> expression = + method private derive_type_ref_name : + label -> longident loc -> expression = fun name n -> ederiver name n method private derive_type_ref' ~loc name n ts = @@ -299,16 +299,16 @@ module Schema = struct ~expr; ] - method extension - : loc:location -> path:label -> core_type -> expression = + method extension : + loc:location -> path:label -> core_type -> expression = fun ~loc:_ ~path:_ ty -> let loc = ty.ptyp_loc in as_fun ~loc (self#derive_of_core_type' ty) - method str_type_decl - : ctxt:Expansion_context.Deriver.t -> - rec_flag * type_declaration list -> - structure = + method str_type_decl : + ctxt:Expansion_context.Deriver.t -> + rec_flag * type_declaration list -> + structure = fun ~ctxt (_rec_flag, tds) -> let loc = Expansion_context.Deriver.derived_item_loc ctxt in let bindings = @@ -319,10 +319,10 @@ module Schema = struct [%%i pstr_value ~loc Recursive bindings]] - method sig_type_decl - : ctxt:Expansion_context.Deriver.t -> - rec_flag * type_declaration list -> - signature = + method sig_type_decl : + ctxt:Expansion_context.Deriver.t -> + rec_flag * type_declaration list -> + signature = derive_sig_type_decl ~derive_t:self#t ~derive_label:self#derive_type_decl_label end @@ -468,7 +468,7 @@ module Conv = struct | exception Ppx_deriving_json_runtime.Of_json_error (Ppx_deriving_json_runtime.Unexpected_variant - _) -> + _) -> [%e next]] in next, cases) @@ -578,8 +578,8 @@ module Conv = struct | x -> (x :> [%t t]) | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - _) -> + (Ppx_deriving_json_runtime.Unexpected_variant _) + -> [%e next]]) in let cases = diff --git a/ppx/native/ppx_deriving_tools.mli b/ppx/native/ppx_deriving_tools.mli index 7dffca7..6467729 100644 --- a/ppx/native/ppx_deriving_tools.mli +++ b/ppx/native/ppx_deriving_tools.mli @@ -1,4 +1,5 @@ -(** A collection of tools to make it easy to build ppx deriving plugins. *) +(** A collection of tools to make it easy to build ppx deriving plugins. +*) open Ppxlib @@ -34,13 +35,12 @@ val register_combined : module Conv : sig (** A simplified parsetree representation. - We define a few types to represent the data we want to derive conversions - for. Such types are less verbose but less precise than the original - parsetree, though it is enough for conversion purposes. + We define a few types to represent the data we want to derive + conversions for. Such types are less verbose but less precise than + the original parsetree, though it is enough for conversion purposes. - The types still keep the original parsetree nodes as context (this is - also needed to play well with Ppxlib.Attributes API). - *) + The types still keep the original parsetree nodes as context (this + is also needed to play well with Ppxlib.Attributes API). *) type 'ctx tuple = { tpl_loc : location; @@ -142,17 +142,18 @@ module Conv : sig deriving (** Define a deserializer using pattern matching. - This is a less general but more compact variant of [deriving_of], for - cases where the serialized data can be inspected with pattern matching. - *) + This is a less general but more compact variant of [deriving_of], + for cases where the serialized data can be inspected with pattern + matching. *) end val not_supported : loc:location -> string -> 'a -(** [not_supported what] terminates ppx with an error message telling [what] unsupported. *) +(** [not_supported what] terminates ppx with an error message telling + [what] unsupported. *) val gen_tuple : loc:location -> label -> int -> pattern list * expression -(** [let patts, expr = gen_tuple label n in ...] creates a tuple expression - and a corresponding list of patterns. *) +(** [let patts, expr = gen_tuple label n in ...] creates a tuple + expression and a corresponding list of patterns. *) (** Auxiliary functions to generate record expressions and patterns. *) @@ -161,33 +162,33 @@ val gen_record : label -> (label loc * attributes * 'a) list -> pattern list * expression -(** [let patts, expr = gen_tuple label n in ...] creates a record expression - and a corresponding list of patterns. *) +(** [let patts, expr = gen_tuple label n in ...] creates a record + expression and a corresponding list of patterns. *) val gen_pat_tuple : loc:location -> string -> int -> pattern * expression list -(** [let patt, exprs = gen_pat_tuple ~loc prefix n in ...] - generates a pattern to match a tuple of size [n] and a list of expressions - [exprs] to refer to names bound in this pattern. *) +(** [let patt, exprs = gen_pat_tuple ~loc prefix n in ...] generates a + pattern to match a tuple of size [n] and a list of expressions [exprs] + to refer to names bound in this pattern. *) val gen_pat_record : loc:location -> string -> label loc list -> pattern * expression list -(** [let patt, exprs = gen_pat_record ~loc prefix fs in ...] - generates a pattern to match record with fields [fs] and a list of expressions - [exprs] to refer to names bound in this pattern. *) +(** [let patt, exprs = gen_pat_record ~loc prefix fs in ...] generates a + pattern to match record with fields [fs] and a list of expressions + [exprs] to refer to names bound in this pattern. *) val gen_pat_list : loc:location -> string -> int -> pattern * expression list -(** [let patt, exprs = gen_pat_list ~loc prefix n in ...] - generates a pattern to match a list of size [n] and a list of expressions - [exprs] to refer to names bound in this pattern. *) +(** [let patt, exprs = gen_pat_list ~loc prefix n in ...] generates a + pattern to match a list of size [n] and a list of expressions [exprs] + to refer to names bound in this pattern. *) val ( --> ) : pattern -> expression -> case (** A shortcut to define a pattern matching case. *) val map_loc : ('a -> 'b) -> 'a loc -> 'b loc (** Map over data with location, useful to lift derive_of_label, - derive_of_longident *) + derive_of_longident *) (** Low-level deriver classes. *) diff --git a/src/Json.ml b/src/Json.ml index ca68819..fc2a21f 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -1,254 +1,259 @@ module Decode = struct -external _unsafeCreateUninitializedArray : int -> 'a array = "Array" -[@@mel.new] - -external _stringify : Js.Json.t -> string = "JSON.stringify" - -let _isInteger value = - Js.Float.isFinite value && Js.Math.floor_float value == value - -type 'a decoder = Js.Json.t -> 'a -type error = Json_error of string | Unexpected_variant of string - -let error_to_string = function - | Json_error msg -> msg - | Unexpected_variant tag -> "unexpected variant: " ^ tag - -exception DecodeError of error - -let error msg = raise (DecodeError (Json_error msg)) -let id json = json - -let bool json = - if Js.typeof json = "boolean" then (Obj.magic (json : Js.Json.t) : bool) - else error ("Expected boolean, got " ^ _stringify json) - -let float json = - if Js.typeof json = "number" then (Obj.magic (json : Js.Json.t) : float) - else error ("Expected number, got " ^ _stringify json) - -let int json = - let f = float json in - if _isInteger f then (Obj.magic (f : float) : int) - else error ("Expected integer, got " ^ _stringify json) - -let string json = - if Js.typeof json = "string" then - (Obj.magic (json : Js.Json.t) : string) - else error ("Expected string, got " ^ _stringify json) - -let char json = - let s = string json in - if String.length s = 1 then String.get s 0 - else error ("Expected single-character string, got " ^ _stringify json) - -let date json = json |> string |> Js.Date.fromString - -let nullable decode json = - if (Obj.magic json : 'a Js.null) == Js.null then Js.null - else Js.Null.return (decode json) - -(* TODO: remove this? *) -let nullAs value json = - if (Obj.magic json : 'a Js.null) == Js.null then value - else error ("Expected null, got " ^ _stringify json) - -let array decode json = - if Js.Array.isArray json then ( - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - let target = _unsafeCreateUninitializedArray length in - for i = 0 to length - 1 do - let value = - try decode (Array.unsafe_get source i) + external _unsafeCreateUninitializedArray : int -> 'a array = "Array" + [@@mel.new] + + external _stringify : Js.Json.t -> string = "JSON.stringify" + + let _isInteger value = + Js.Float.isFinite value && Js.Math.floor_float value == value + + type 'a decoder = Js.Json.t -> 'a + type error = Json_error of string | Unexpected_variant of string + + let error_to_string = function + | Json_error msg -> msg + | Unexpected_variant tag -> "unexpected variant: " ^ tag + + exception DecodeError of error + + let error msg = raise (DecodeError (Json_error msg)) + let id json = json + + let bool json = + if Js.typeof json = "boolean" then + (Obj.magic (json : Js.Json.t) : bool) + else error ("Expected boolean, got " ^ _stringify json) + + let float json = + if Js.typeof json = "number" then + (Obj.magic (json : Js.Json.t) : float) + else error ("Expected number, got " ^ _stringify json) + + let int json = + let f = float json in + if _isInteger f then (Obj.magic (f : float) : int) + else error ("Expected integer, got " ^ _stringify json) + + let string json = + if Js.typeof json = "string" then + (Obj.magic (json : Js.Json.t) : string) + else error ("Expected string, got " ^ _stringify json) + + let char json = + let s = string json in + if String.length s = 1 then String.get s 0 + else error ("Expected single-character string, got " ^ _stringify json) + + let date json = json |> string |> Js.Date.fromString + + let nullable decode json = + if (Obj.magic json : 'a Js.null) == Js.null then Js.null + else Js.Null.return (decode json) + + (* TODO: remove this? *) + let nullAs value json = + if (Obj.magic json : 'a Js.null) == Js.null then value + else error ("Expected null, got " ^ _stringify json) + + let array decode json = + if Js.Array.isArray json then ( + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + let target = _unsafeCreateUninitializedArray length in + for i = 0 to length - 1 do + let value = + try decode (Array.unsafe_get source i) + with DecodeError err -> + error + (error_to_string err + ^ "\n\tin array at index " + ^ string_of_int i) + in + Array.unsafe_set target i value + done; + target) + else error ("Expected array, got " ^ _stringify json) + + let list decode json = json |> array decode |> Array.to_list + + let pair decodeA decodeB json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 2 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1) ) with DecodeError err -> - error - (error_to_string err - ^ "\n\tin array at index " - ^ string_of_int i) - in - Array.unsafe_set target i value - done; - target) - else error ("Expected array, got " ^ _stringify json) - -let list decode json = json |> array decode |> Array.to_list - -let pair decodeA decodeB json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 2 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin pair/tuple2") - else - let length = Js.String.make length in - error {j|Expected array of length 2, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let tuple2 = pair - -let tuple3 decodeA decodeB decodeC json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 3 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1), - decodeC (Array.unsafe_get source 2) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple3") - else - let length = Js.String.make length in - error {j|Expected array of length 3, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let tuple4 decodeA decodeB decodeC decodeD json = - if Js.Array.isArray json then - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - if length = 4 then - try - ( decodeA (Array.unsafe_get source 0), - decodeB (Array.unsafe_get source 1), - decodeC (Array.unsafe_get source 2), - decodeD (Array.unsafe_get source 3) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple4") - else - let length = Js.String.make length in - error {j|Expected array of length 4, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - -let dict decode json = - if - Js.typeof json = "object" - && (not (Js.Array.isArray json)) - && not ((Obj.magic json : 'a Js.null) == Js.null) - then ( - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in - let keys = Js.Dict.keys source in - let l = Js.Array.length keys in - let target = Js.Dict.empty () in - for i = 0 to l - 1 do - let key = Array.unsafe_get keys i in - let value = - try decode (Js.Dict.unsafeGet source key) + error (error_to_string err ^ "\n\tin pair/tuple2") + else + let length = Js.String.make length in + error + {j|Expected array of length 2, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + + let tuple2 = pair + + let tuple3 decodeA decodeB decodeC json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 3 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1), + decodeC (Array.unsafe_get source 2) ) with DecodeError err -> - error (error_to_string err ^ "\n\tin dict") - in - Js.Dict.set target key value - done; - target) - else error ("Expected object, got " ^ _stringify json) - -let field key decode json = - if - Js.typeof json = "object" - && (not (Js.Array.isArray json)) - && not ((Obj.magic json : 'a Js.null) == Js.null) - then - let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in - match Js.Dict.get dict key with - | Some value -> ( - try decode value + error (error_to_string err ^ "\n\tin tuple3") + else + let length = Js.String.make length in + error + {j|Expected array of length 3, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + + let tuple4 decodeA decodeB decodeC decodeD json = + if Js.Array.isArray json then + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + if length = 4 then + try + ( decodeA (Array.unsafe_get source 0), + decodeB (Array.unsafe_get source 1), + decodeC (Array.unsafe_get source 2), + decodeD (Array.unsafe_get source 3) ) with DecodeError err -> - error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) - | None -> error {j|Expected field '$(key)'|j} - else error ("Expected object, got " ^ _stringify json) - -let rec at key_path decoder = - match key_path with - | [ key ] -> field key decoder - | first :: rest -> field first (at rest decoder) - | [] -> - raise - @@ Invalid_argument - "Expected key_path to contain at least one element" - -let optional decode json = - try Some (decode json) with DecodeError _ -> None - -let oneOf decoders json = - let rec inner decoders errors = - match decoders with - | [] -> - let formattedErrors = - "\n- " - ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) - in + error (error_to_string err ^ "\n\tin tuple4") + else + let length = Js.String.make length in error - ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} - ^ _stringify json) - | decode :: rest -> ( - try decode json with DecodeError e -> inner rest (e :: errors)) - in - inner decoders [] + {j|Expected array of length 4, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) + + let dict decode json = + if + Js.typeof json = "object" + && (not (Js.Array.isArray json)) + && not ((Obj.magic json : 'a Js.null) == Js.null) + then ( + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in + let keys = Js.Dict.keys source in + let l = Js.Array.length keys in + let target = Js.Dict.empty () in + for i = 0 to l - 1 do + let key = Array.unsafe_get keys i in + let value = + try decode (Js.Dict.unsafeGet source key) + with DecodeError err -> + error (error_to_string err ^ "\n\tin dict") + in + Js.Dict.set target key value + done; + target) + else error ("Expected object, got " ^ _stringify json) + + let field key decode json = + if + Js.typeof json = "object" + && (not (Js.Array.isArray json)) + && not ((Obj.magic json : 'a Js.null) == Js.null) + then + let dict = (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t) in + match Js.Dict.get dict key with + | Some value -> ( + try decode value + with DecodeError err -> + error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) + | None -> error {j|Expected field '$(key)'|j} + else error ("Expected object, got " ^ _stringify json) + + let rec at key_path decoder = + match key_path with + | [ key ] -> field key decoder + | first :: rest -> field first (at rest decoder) + | [] -> + raise + @@ Invalid_argument + "Expected key_path to contain at least one element" + + let optional decode json = + try Some (decode json) with DecodeError _ -> None + + let oneOf decoders json = + let rec inner decoders errors = + match decoders with + | [] -> + let formattedErrors = + "\n- " + ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) + in + error + ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} + ^ _stringify json) + | decode :: rest -> ( + try decode json with DecodeError e -> inner rest (e :: errors)) + in + inner decoders [] -let either a b = oneOf [ a; b ] + let either a b = oneOf [ a; b ] -let withDefault default decode json = - try decode json with DecodeError _ -> default + let withDefault default decode json = + try decode json with DecodeError _ -> default -let map f decode json = f (decode json) -let andThen b a json = b (a json) json + let map f decode json = f (decode json) + let andThen b a json = b (a json) json end module Encode = struct -type 'a encoder = 'a -> Js.Json.t + type 'a encoder = 'a -> Js.Json.t -external null : Js.Json.t = "null" -external string : string -> Js.Json.t = "%identity" -external float : float -> Js.Json.t = "%identity" -external int : int -> Js.Json.t = "%identity" -external bool : bool -> Js.Json.t = "%identity" + external null : Js.Json.t = "null" + external string : string -> Js.Json.t = "%identity" + external float : float -> Js.Json.t = "%identity" + external int : int -> Js.Json.t = "%identity" + external bool : bool -> Js.Json.t = "%identity" -let char c = c |> String.make 1 |> string -let date d = d |> Js.Date.toJSONUnsafe |> string -let nullable encode = function None -> null | Some v -> encode v -let withDefault d encode = function None -> d | Some v -> encode v + let char c = c |> String.make 1 |> string + let date d = d |> Js.Date.toJSONUnsafe |> string + let nullable encode = function None -> null | Some v -> encode v + let withDefault d encode = function None -> d | Some v -> encode v -external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" + external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" -let dict encode d = - let pairs = Js.Dict.entries d in - let encodedPairs = Array.map (fun (k, v) -> (k, encode v)) pairs in - jsonDict (Js.Dict.fromArray encodedPairs) + let dict encode d = + let pairs = Js.Dict.entries d in + let encodedPairs = Array.map (fun (k, v) -> k, encode v) pairs in + jsonDict (Js.Dict.fromArray encodedPairs) -let object_ props : Js.Json.t = props |> Js.Dict.fromList |> jsonDict + let object_ props : Js.Json.t = props |> Js.Dict.fromList |> jsonDict -external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" + external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" -let array encode l = l |> Array.map encode |> jsonArray + let array encode l = l |> Array.map encode |> jsonArray -let list encode = function - | [] -> jsonArray [||] - | hd :: tl as l -> - let a = Array.make (List.length l) (encode hd) in - let rec fill i = function - | [] -> a - | hd :: tl -> - Array.unsafe_set a i (encode hd); - fill (i + 1) tl - in - jsonArray (fill 1 tl) + let list encode = function + | [] -> jsonArray [||] + | hd :: tl as l -> + let a = Array.make (List.length l) (encode hd) in + let rec fill i = function + | [] -> a + | hd :: tl -> + Array.unsafe_set a i (encode hd); + fill (i + 1) tl + in + jsonArray (fill 1 tl) -let pair encodeA encodeB (a, b) = jsonArray [| encodeA a; encodeB b |] -let tuple2 = pair + let pair encodeA encodeB (a, b) = jsonArray [| encodeA a; encodeB b |] + let tuple2 = pair -let tuple3 encodeA encodeB encodeC (a, b, c) = - jsonArray [| encodeA a; encodeB b; encodeC c |] + let tuple3 encodeA encodeB encodeC (a, b, c) = + jsonArray [| encodeA a; encodeB b; encodeC c |] -let tuple4 encodeA encodeB encodeC encodeD (a, b, c, d) = - jsonArray [| encodeA a; encodeB b; encodeC c; encodeD d |] + let tuple4 encodeA encodeB encodeC encodeD (a, b, c, d) = + jsonArray [| encodeA a; encodeB b; encodeC c; encodeD d |] -external stringArray : string array -> Js.Json.t = "%identity" -external numberArray : float array -> Js.Json.t = "%identity" -external boolArray : bool array -> Js.Json.t = "%identity" + external stringArray : string array -> Js.Json.t = "%identity" + external numberArray : float array -> Js.Json.t = "%identity" + external boolArray : bool array -> Js.Json.t = "%identity" end exception ParseError of string diff --git a/src/Json.mli b/src/Json.mli index 4568dfc..5be9684 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -99,32 +99,31 @@ let _ = |} ) ]} -*) +*) module Decode : sig -(** Provides a set of low level combinator primitives to decode Js.Json.t data -structures -A decoder combinator will return the decoded value if successful, or raise a -[DecodeError of string] if unsuccessful, where the string argument contains the -error message. -Decoders are designed to be combined to produce more complex decoders that can -decode arbitrary data structures, though the emphasis for this library is for -it to be {i possible} to decode any given data structure, not necessarily for -it to be {i convenient}. For convenience you should look towards opinionated -third-party libraries. -*) + (** Provides a set of low level combinator primitives to decode + Js.Json.t data structures A decoder combinator will return the + decoded value if successful, or raise a [DecodeError of string] if + unsuccessful, where the string argument contains the error message. + Decoders are designed to be combined to produce more complex + decoders that can decode arbitrary data structures, though the + emphasis for this library is for it to be {i possible} to decode any + given data structure, not necessarily for it to be {i convenient}. + For convenience you should look towards opinionated third-party + libraries. *) -type 'a decoder = Js.Json.t -> 'a -(** The type of a decoder combinator *) + type 'a decoder = Js.Json.t -> 'a + (** The type of a decoder combinator *) -type error = Json_error of string | Unexpected_variant of string + type error = Json_error of string | Unexpected_variant of string -val error_to_string : error -> string + val error_to_string : error -> string -exception DecodeError of error + exception DecodeError of error -val id : Js.Json.t decoder -(** Identity decoder. + val id : Js.Json.t decoder + (** Identity decoder. {b Returns} the input JSON value. @@ -140,8 +139,8 @@ val id : Js.Json.t decoder let _ = Decode.(int json, id json) ]} *) -val bool : bool decoder -(** Decodes a JSON value into a [bool] + val bool : bool decoder + (** Decodes a JSON value into a [bool] {b Returns} a [bool] if the JSON value is a [true] or [false]. @@ -160,8 +159,8 @@ val bool : bool decoder ]} *) -val float : float decoder -(** Decodes a JSON value into a [float] + val float : float decoder + (** Decodes a JSON value into a [float] {b Returns} a [float] if the JSON value is a number. @@ -180,8 +179,8 @@ val float : float decoder ]} *) -val int : int decoder -(** Decodes a JSON value into an [int] + val int : int decoder + (** Decodes a JSON value into an [int] {b Returns} an [int] if the JSON value is a number. @@ -200,8 +199,8 @@ val int : int decoder ]} *) -val string : string decoder -(** Decodes a JSON value into a [string] + val string : string decoder + (** Decodes a JSON value into a [string] {b Returns} a [string] if the JSON value is a string. @@ -218,8 +217,8 @@ val string : string decoder ]} *) -val char : char decoder -(** Decodes a JSON value into a [char] + val char : char decoder + (** Decodes a JSON value into a [char] {b Returns} a [char] if the JSON value is a single-character string. @@ -236,16 +235,16 @@ val char : char decoder ]} *) -val date : Js.Date.t decoder -(** Decodes an ISO8601-formatted JSON string into a [Js.Date.t] - -{b Returns} a [Js.Date.t] if the JSON value is an IS8601-formatted string. + val date : Js.Date.t decoder + (** Decodes an ISO8601-formatted JSON string into a [Js.Date.t] -@raise [DecodeError] if unsuccessful -*) + {b Returns} a [Js.Date.t] if the JSON value is an IS8601-formatted + string. + + @raise [DecodeError] if unsuccessful *) -val nullable : 'a decoder -> 'a Js.null decoder -(** Decodes a JSON value into an ['a Js.null] + val nullable : 'a decoder -> 'a Js.null decoder + (** Decodes a JSON value into an ['a Js.null] {b Returns} [Js.null] if the JSON value is [null], or an ['a Js.null] if the given decoder succeeds, @@ -263,8 +262,8 @@ given decoder succeeds, ]} *) -val nullAs : 'a -> 'a decoder -(** Returns the given value if the JSON value is [null] + val nullAs : 'a -> 'a decoder + (** Returns the given value if the JSON value is [null] {b Returns} an ['a] if the JSON value is [null]. @@ -281,8 +280,8 @@ val nullAs : 'a -> 'a decoder ]} *) -val array : 'a decoder -> 'a array decoder -(** Decodes a JSON array into an ['a array] using the given decoder on each element + val array : 'a decoder -> 'a array decoder + (** Decodes a JSON array into an ['a array] using the given decoder on each element {b Returns} an ['a array] if the JSON value is a JSON array and all its elements are successfully decoded. @@ -302,8 +301,8 @@ elements are successfully decoded. ]} *) -val list : 'a decoder -> 'a list decoder -(** Decodes a JSON array into an ['a list] using the given decoder on each element + val list : 'a decoder -> 'a list decoder + (** Decodes a JSON array into an ['a list] using the given decoder on each element {b Returns} an ['a list] if the JSON value is a JSON array and all its elements are successfully decoded. @@ -323,8 +322,8 @@ elements are successfully decoded. ]} *) -val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder -(** Decodes a JSON array with two elements into an ['a * 'b] tuple using + val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder + (** Decodes a JSON array with two elements into an ['a * 'b] tuple using each of the given decoders in order. {b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both @@ -343,8 +342,8 @@ val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder ]} *) -val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder -(** Decodes a JSON array with two elements into an ['a * 'b] tuple using + val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder + (** Decodes a JSON array with two elements into an ['a * 'b] tuple using each of the given decoders in order. {b Alias of [pair]} @@ -365,28 +364,32 @@ val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder ]} *) -val tuple3 : 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder -(** Decodes a JSON array with three elements into an ['a * 'b * 'c] tuple using - each of the given decoders in order. + val tuple3 : + 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder + (** Decodes a JSON array with three elements into an ['a * 'b * 'c] + tuple using each of the given decoders in order. -{b Returns} an ['a * 'b * 'c] if the JSON value is a JSON array of length 3 and - all its elements are successfully decoded. + {b Returns} an ['a * 'b * 'c] if the JSON value is a JSON array of + length 3 and all its elements are successfully decoded. -@raise [DecodeError] if unsuccessful -*) + @raise [DecodeError] if unsuccessful *) -val tuple4 : 'a decoder -> 'b decoder -> 'c decoder -> 'd decoder -> ('a * 'b * 'c * 'd) decoder -(** Decodes a JSON array with four elements into an ['a * 'b * 'c * 'd] tuple - using each of the given decoders in order. + val tuple4 : + 'a decoder -> + 'b decoder -> + 'c decoder -> + 'd decoder -> + ('a * 'b * 'c * 'd) decoder + (** Decodes a JSON array with four elements into an ['a * 'b * 'c * 'd] + tuple using each of the given decoders in order. -{b Returns} an ['a * 'b * 'c * 'd] if the JSON value is a JSON array of length 4 - and all its elements are successfully decoded. + {b Returns} an ['a * 'b * 'c * 'd] if the JSON value is a JSON array + of length 4 and all its elements are successfully decoded. -@raise [DecodeError] if unsuccessful -*) + @raise [DecodeError] if unsuccessful *) -val dict : 'a decoder -> 'a Js.Dict.t decoder -(** Decodes a JSON object into a dict using the given decoder on each of its values + val dict : 'a decoder -> 'a Js.Dict.t decoder + (** Decodes a JSON object into a dict using the given decoder on each of its values {b Returns} an ['a Js.Dict.t] if the JSON value is a JSON object and all its values are successfully decoded. @@ -406,8 +409,8 @@ values are successfully decoded. ]} *) -val field : string -> 'a decoder -> 'a decoder -(** Decodes a JSON object with a specific field into the value of that field + val field : string -> 'a decoder -> 'a decoder + (** Decodes a JSON object with a specific field into the value of that field {b Returns} an ['a] if the JSON value is a JSON object with the given field and a value that is successfully decoded with the given decoder. @@ -429,8 +432,8 @@ and a value that is successfully decoded with the given decoder. ]} *) -val at : string list -> 'a decoder -> 'a decoder -(** Same as [field] but takes a top level field and a list of nested fields for decoding nested values. + val at : string list -> 'a decoder -> 'a decoder + (** Same as [field] but takes a top level field and a list of nested fields for decoding nested values. {b Returns} an ['a] if the JSON value is a JSON object with the given field and a value that is successfully decoded with the given decoder. @@ -447,8 +450,8 @@ and a value that is successfully decoded with the given decoder. ]} *) -val optional : 'a decoder -> 'a option decoder -(** Maps a decoder [result] to an option + val optional : 'a decoder -> 'a option decoder + (** Maps a decoder [result] to an option {b Returns} [Some of 'a] if the given decoder is successful, [None] if it is not. @@ -481,8 +484,8 @@ a composite decoder, and is useful to decode optional JSON object fields. ]} *) -val oneOf : 'a decoder list -> 'a decoder -(** Tries each [decoder] in order, retunring the result of the first that succeeds + val oneOf : 'a decoder list -> 'a decoder + (** Tries each [decoder] in order, retunring the result of the first that succeeds {b Returns} an ['a] if one of the decoders succeed. @@ -499,8 +502,8 @@ val oneOf : 'a decoder list -> 'a decoder ]} *) -val either : 'a decoder -> 'a decoder -> 'a decoder -(** Tries each [decoder] in order, retunring the result of the first that succeeds + val either : 'a decoder -> 'a decoder -> 'a decoder + (** Tries each [decoder] in order, retunring the result of the first that succeeds {b Returns} an ['a] if one of the decoders succeed. @@ -517,8 +520,8 @@ val either : 'a decoder -> 'a decoder -> 'a decoder ]} *) -val withDefault : 'a -> 'a decoder -> 'a decoder -(** Tries the given [decoder] and returns its result if it succeeds, or the + val withDefault : 'a -> 'a decoder -> 'a decoder + (** Tries the given [decoder] and returns its result if it succeeds, or the given default value if it fails. {b Returns} an ['a]. @@ -534,8 +537,8 @@ given default value if it fails. ]} *) -val map : ('a -> 'b) -> 'a decoder -> 'b decoder -(** Returns a decoder that maps the result of the given decoder if successful + val map : ('a -> 'b) -> 'a decoder -> 'b decoder + (** Returns a decoder that maps the result of the given decoder if successful {b Returns} a ['b] if the given decoder succeeds. @@ -546,8 +549,8 @@ val map : ('a -> 'b) -> 'a decoder -> 'b decoder ]} *) -val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder -(** Returns a decoder that maps the result of the given decoder if successful + val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder + (** Returns a decoder that maps the result of the given decoder if successful {b Returns} an ['a] if both decoders succeed. @@ -604,99 +607,112 @@ val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder end module Encode : sig -(** Provides functions for encoding a JSON data structure *) + (** Provides functions for encoding a JSON data structure *) -type 'a encoder = 'a -> Js.Json.t -(** The type of a encoder combinator *) + type 'a encoder = 'a -> Js.Json.t + (** The type of a encoder combinator *) -external null : Js.Json.t = "null" + external null : Js.Json.t = "null" -(** [null] is the singleton null JSON value *) + (** [null] is the singleton null JSON value *) -external string : string -> Js.Json.t = "%identity" -(** [string s] makes a JSON string of the [string] [s] *) + external string : string -> Js.Json.t = "%identity" + (** [string s] makes a JSON string of the [string] [s] *) -external float : float -> Js.Json.t = "%identity" -(** [float n] makes a JSON number of the [float] [n] *) + external float : float -> Js.Json.t = "%identity" + (** [float n] makes a JSON number of the [float] [n] *) -external int : int -> Js.Json.t = "%identity" -(** [int n] makes a JSON number of the [int] [n] *) + external int : int -> Js.Json.t = "%identity" + (** [int n] makes a JSON number of the [int] [n] *) -external bool : bool -> Js.Json.t = "%identity" -(** [bool b] makes a JSON boolean of the [bool] [b] *) + external bool : bool -> Js.Json.t = "%identity" + (** [bool b] makes a JSON boolean of the [bool] [b] *) -val char : char -> Js.Json.t -(** [char c] makes a JSON string of the [char] [c] *) + val char : char -> Js.Json.t + (** [char c] makes a JSON string of the [char] [c] *) -val date : Js.Date.t -> Js.Json.t -(** [date d] makes an ISO 8601 JSON string of the [Js.Date.t] [d] *) + val date : Js.Date.t -> Js.Json.t + (** [date d] makes an ISO 8601 JSON string of the [Js.Date.t] [d] *) -val nullable : 'a encoder -> 'a option -> Js.Json.t -(** [nullable encoder option] returns either the encoded value or [null] *) + val nullable : 'a encoder -> 'a option -> Js.Json.t + (** [nullable encoder option] returns either the encoded value or [null] + *) -val withDefault : Js.Json.t -> 'a encoder -> 'a option -> Js.Json.t -(** [withDefault default encoder option] returns the encoded value if present, oterwise [default] *) + val withDefault : Js.Json.t -> 'a encoder -> 'a option -> Js.Json.t + (** [withDefault default encoder option] returns the encoded value if + present, oterwise [default] *) -val pair : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t -(** [pair encoder encoder tuple] creates a JSON array from a tuple of size 2 *) + val pair : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t + (** [pair encoder encoder tuple] creates a JSON array from a tuple of + size 2 *) -val tuple2 : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t -(** [tuple2 encoder encoder tuple] creates a JSON array from a tuple of size 2. Alias of [pair] *) + val tuple2 : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t + (** [tuple2 encoder encoder tuple] creates a JSON array from a tuple of + size 2. Alias of [pair] *) -val tuple3 : 'a encoder -> 'b encoder -> 'c encoder -> 'a * 'b * 'c -> Js.Json.t -(** [tuple3 enc enc enc tuple] creates a JSON array from a tuple of size 3 *) + val tuple3 : + 'a encoder -> 'b encoder -> 'c encoder -> 'a * 'b * 'c -> Js.Json.t + (** [tuple3 enc enc enc tuple] creates a JSON array from a tuple of size + 3 *) -val tuple4 : - 'a encoder -> - 'b encoder -> - 'c encoder -> - 'd encoder -> - 'a * 'b * 'c * 'd -> - Js.Json.t -(** [tuple4 enc enc enc enc tuple] creates a JSON array from a tuple of size 4 *) + val tuple4 : + 'a encoder -> + 'b encoder -> + 'c encoder -> + 'd encoder -> + 'a * 'b * 'c * 'd -> + Js.Json.t + (** [tuple4 enc enc enc enc tuple] creates a JSON array from a tuple of + size 4 *) -external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" -(** [jsonDict d] makes a JSON object of the [Js.Dict.t] [d] *) + external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" + (** [jsonDict d] makes a JSON object of the [Js.Dict.t] [d] *) -val dict : 'a encoder -> 'a Js.Dict.t encoder -(** [dict encoder d] makes a JSON object of the [Js.Dict.t] [d] with the given [encoder] *) + val dict : 'a encoder -> 'a Js.Dict.t encoder + (** [dict encoder d] makes a JSON object of the [Js.Dict.t] [d] with the + given [encoder] *) -val object_ : (string * Js.Json.t) list -> Js.Json.t -(** [object_ props] makes a JSON object of the [props] list of properties *) + val object_ : (string * Js.Json.t) list -> Js.Json.t + (** [object_ props] makes a JSON object of the [props] list of + properties *) -val array : 'a encoder -> 'a array encoder -(** [array encoder l] makes a JSON array of the [list] [l] using the given [encoder] - * NOTE: This will be renamed `array` once the existing and deprecated `array` function - * has been removed. - *) + val array : 'a encoder -> 'a array encoder + (** [array encoder l] makes a JSON array of the [list] [l] using the + given [encoder] * NOTE: This will be renamed `array` once the + existing and deprecated `array` function * has been removed. *) -val list : 'a encoder -> 'a list encoder -(** [list encoder a] makes a JSON array of the [array] [a] using the given [encoder] *) + val list : 'a encoder -> 'a list encoder + (** [list encoder a] makes a JSON array of the [array] [a] using the + given [encoder] *) -(** The functions below are specialized for specific array type which - happened to be already JSON object in the BuckleScript runtime. Therefore - they are more efficient (constant time rather than linear conversion). *) + (** The functions below are specialized for specific array type which + happened to be already JSON object in the BuckleScript runtime. + Therefore they are more efficient (constant time rather than linear + conversion). *) -external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" -(** [jsonArray a] makes a JSON array of the [Js.Json.t array] [a] *) + external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" + (** [jsonArray a] makes a JSON array of the [Js.Json.t array] [a] *) -external stringArray : string array -> Js.Json.t = "%identity" -(** [stringArray a] makes a JSON array of the [string array] [a] *) + external stringArray : string array -> Js.Json.t = "%identity" + (** [stringArray a] makes a JSON array of the [string array] [a] *) -external numberArray : float array -> Js.Json.t = "%identity" -(** [numberArray a] makes a JSON array of the [float array] [a] *) + external numberArray : float array -> Js.Json.t = "%identity" + (** [numberArray a] makes a JSON array of the [float array] [a] *) -external boolArray : bool array -> Js.Json.t = "%identity" -(** [boolArray] makes a JSON array of the [bool array] [a] *) + external boolArray : bool array -> Js.Json.t = "%identity" + (** [boolArray] makes a JSON array of the [bool array] [a] *) end exception ParseError of string -val parse: string -> Js.Json.t option -(** [parse s] returns [Some json] if s is a valid json string, [None] otherwise *) +val parse : string -> Js.Json.t option +(** [parse s] returns [Some json] if s is a valid json string, [None] + otherwise *) -val parseOrRaise: string -> Js.Json.t -(** [parse s] returns a [Js.Json.t] if s is a valid json string, raises [ParseError] otherwise *) +val parseOrRaise : string -> Js.Json.t +(** [parse s] returns a [Js.Json.t] if s is a valid json string, raises + [ParseError] otherwise *) -val stringify: Js.Json.t -> string -(** [stringify json] returns the [string] representation of the given [Js.Json.t] value *) +val stringify : Js.Json.t -> string +(** [stringify json] returns the [string] representation of the given + [Js.Json.t] value *) diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 88cca5a..19bccda 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -44,7 +44,8 @@ let () = describe "bool" (fun () -> let open Json in let open Decode in - test "bool" (fun () -> expect @@ bool (Encode.bool true) |> toEqual true); + test "bool" (fun () -> + expect @@ bool (Encode.bool true) |> toEqual true); test "bool - false" (fun () -> expect @@ bool (Encode.bool false) |> toEqual false); @@ -55,7 +56,8 @@ let () = let open! Decode in test "float" (fun () -> expect @@ float (Encode.float 1.23) |> toEqual 1.23); - test "int" (fun () -> expect @@ float (Encode.int 23) |> toEqual 23.); + test "int" (fun () -> + expect @@ float (Encode.int 23) |> toEqual 23.); Test.throws float [ Bool; String; Null; Array; Object; Char ]); @@ -73,7 +75,10 @@ let () = try let (_ : int) = int (Encode.int inf) in fail "should throw" - with Decode.DecodeError Json_error "Expected integer, got null" -> pass); + with + | Decode.DecodeError (Json_error "Expected integer, got null") + -> + pass); Test.throws int [ Bool; Float; String; Null; Array; Object; Char ]); @@ -111,7 +116,9 @@ let () = let (_ : char) = char (Encode.string "") in fail "should throw" with - | Decode.DecodeError Json_error "Expected single-character string, got \"\"" -> + | Decode.DecodeError + (Json_error "Expected single-character string, got \"\"") + -> pass); test "multiple-character string" (fun () -> @@ -119,7 +126,8 @@ let () = let (_ : char) = char (Encode.string "abc") in fail "should throw" with - | Decode.DecodeError Json_error "Expected single-character string, got \"abc\"" + | Decode.DecodeError + (Json_error "Expected single-character string, got \"abc\"") -> pass); @@ -144,9 +152,11 @@ let () = expect @@ nullable string (Encode.string "test") |> toEqual (Js.Null.return "test")); test "null -> null" (fun () -> - expect @@ nullable (nullAs Js.null) Encode.null |> toEqual Js.null); + expect @@ nullable (nullAs Js.null) Encode.null + |> toEqual Js.null); - Test.throws (nullable int) [ Bool; Float; String; Array; Object; Char ]; + Test.throws (nullable int) + [ Bool; Float; String; Array; Object; Char ]; Test.throws (nullable bool) [ Int ]); describe "nullAs" (fun () -> @@ -162,7 +172,8 @@ let () = test "as Some _" (fun () -> expect (nullAs (Some "foo") Encode.null) |> toEqual (Some "foo")); - Test.throws (nullAs 0) [ Bool; Float; Int; String; Array; Object; Char ]); + Test.throws (nullAs 0) + [ Bool; Float; Int; String; Array; Object; Char ]); describe "array" (fun () -> let open Json in @@ -184,7 +195,8 @@ let () = |> toEqual [| "a"; "b"; "c" |]); test "nullAs" (fun () -> expect - @@ array (nullAs Js.null) (parseOrRaise {| [null, null, null] |}) + @@ array (nullAs Js.null) + (parseOrRaise {| [null, null, null] |}) |> toEqual [| Js.null; Js.null; Js.null |]); test "array int -> array boolean" (fun () -> @@ -193,18 +205,23 @@ let () = (array bool) (parseOrRaise {| [1, 2, 3] |}) in fail "should throw" - with DecodeError Json_error "Expected boolean, got 1\n\tin array at index 0" -> + with + | DecodeError + (Json_error "Expected boolean, got 1\n\tin array at index 0") + -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try let (_ : _ array) = - (array (fun _ -> raise Foo)) (Encode.array Encode.int [| 1 |]) + (array (fun _ -> raise Foo)) + (Encode.array Encode.int [| 1 |]) in fail "should throw" with Foo -> pass); - Test.throws (array int) [ Bool; Float; Int; String; Null; Object; Char ]); + Test.throws (array int) + [ Bool; Float; Int; String; Null; Object; Char ]); describe "list" (fun () -> let open Json in @@ -231,9 +248,14 @@ let () = test "array int -> list boolean" (fun () -> try - let (_ : bool list) = (list bool) (parseOrRaise {| [1, 2, 3] |}) in + let (_ : bool list) = + (list bool) (parseOrRaise {| [1, 2, 3] |}) + in fail "should throw" - with DecodeError Json_error "Expected boolean, got 1\n\tin array at index 0" -> + with + | DecodeError + (Json_error "Expected boolean, got 1\n\tin array at index 0") + -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -244,7 +266,8 @@ let () = fail "should throw" with Foo -> pass); - Test.throws (list int) [ Bool; Float; Int; String; Null; Object; Char ]); + Test.throws (list int) + [ Bool; Float; Int; String; Null; Object; Char ]); describe "pair" (fun () -> let open Json in @@ -253,13 +276,19 @@ let () = expect @@ pair string int (parseOrRaise {| ["a", 3] |}) |> toEqual ("a", 3)); test "int int" (fun () -> - expect @@ pair int int (parseOrRaise {| [4, 3] |}) |> toEqual (4, 3)); + expect @@ pair int int (parseOrRaise {| [4, 3] |}) + |> toEqual (4, 3)); test "too small" (fun () -> try - let (_ : int * int) = (pair int int) (parseOrRaise {| [4] |}) in + let (_ : int * int) = + (pair int int) (parseOrRaise {| [4] |}) + in fail "should throw" with - | DecodeError Json_error "Expected array of length 2, got array of length 1" -> + | DecodeError + (Json_error + "Expected array of length 2, got array of length 1") + -> pass); test "too large" (fun () -> try @@ -268,7 +297,10 @@ let () = in fail "should throw" with - | DecodeError Json_error "Expected array of length 2, got array of length 3" -> + | DecodeError + (Json_error + "Expected array of length 2, got array of length 3") + -> pass); test "bad type a" (fun () -> try @@ -276,7 +308,10 @@ let () = (pair int int) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError Json_error "Expected number, got \"3\"\n\tin pair/tuple2" -> + with + | DecodeError + (Json_error "Expected number, got \"3\"\n\tin pair/tuple2") + -> pass); test "bad type b" (fun () -> try @@ -284,12 +319,16 @@ let () = (pair string string) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError Json_error "Expected string, got 4\n\tin pair/tuple2" -> pass); + with + | DecodeError + (Json_error "Expected string, got 4\n\tin pair/tuple2") + -> + pass); test "not array" (fun () -> try let (_ : int * int) = (pair int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError Json_error "Expected array, got 4" -> pass); + with DecodeError (Json_error "Expected array, got 4") -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -307,10 +346,15 @@ let () = |> toEqual ("a", 3)); test "too small" (fun () -> try - let (_ : int * int) = (tuple2 int int) (parseOrRaise {| [4] |}) in + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| [4] |}) + in fail "should throw" with - | DecodeError Json_error "Expected array of length 2, got array of length 1" -> + | DecodeError + (Json_error + "Expected array of length 2, got array of length 1") + -> pass); test "too large" (fun () -> try @@ -319,7 +363,10 @@ let () = in fail "should throw" with - | DecodeError Json_error "Expected array of length 2, got array of length 3" -> + | DecodeError + (Json_error + "Expected array of length 2, got array of length 3") + -> pass); test "bad type a" (fun () -> try @@ -327,7 +374,10 @@ let () = (tuple2 int int) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError Json_error "Expected number, got \"3\"\n\tin pair/tuple2" -> + with + | DecodeError + (Json_error "Expected number, got \"3\"\n\tin pair/tuple2") + -> pass); test "bad type b" (fun () -> try @@ -335,17 +385,24 @@ let () = (tuple2 string string) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError Json_error "Expected string, got 4\n\tin pair/tuple2" -> pass); + with + | DecodeError + (Json_error "Expected string, got 4\n\tin pair/tuple2") + -> + pass); test "not array" (fun () -> try - let (_ : int * int) = (tuple2 int int) (parseOrRaise {| 4 |}) in + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| 4 |}) + in fail "should throw" - with DecodeError Json_error "Expected array, got 4" -> pass); + with DecodeError (Json_error "Expected array, got 4") -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try let (_ : 'a * int) = - (tuple2 (fun _ -> raise Foo) int) (parseOrRaise {| [4, 3] |}) + (tuple2 (fun _ -> raise Foo) int) + (parseOrRaise {| [4, 3] |}) in fail "should throw" with Foo -> pass)); @@ -354,7 +411,8 @@ let () = let open Json in let open! Decode in test "heterogenous" (fun () -> - expect @@ tuple3 string int float (parseOrRaise {| ["a", 3, 4.5] |}) + expect + @@ tuple3 string int float (parseOrRaise {| ["a", 3, 4.5] |}) |> toEqual ("a", 3, 4.5)); test "too small" (fun () -> try @@ -363,7 +421,10 @@ let () = in fail "should throw" with - | DecodeError Json_error "Expected array of length 3, got array of length 1" -> + | DecodeError + (Json_error + "Expected array of length 3, got array of length 1") + -> pass); test "too large" (fun () -> try @@ -372,7 +433,10 @@ let () = in fail "should throw" with - | DecodeError Json_error "Expected array of length 3, got array of length 5" -> + | DecodeError + (Json_error + "Expected array of length 3, got array of length 5") + -> pass); test "bad type a" (fun () -> try @@ -380,21 +444,29 @@ let () = (tuple3 int int int) (parseOrRaise {| ["3", 4, 5] |}) in fail "should throw" - with DecodeError Json_error "Expected number, got \"3\"\n\tin tuple3" -> pass); + with + | DecodeError + (Json_error "Expected number, got \"3\"\n\tin tuple3") + -> + pass); test "bad type b" (fun () -> try let (_ : string * string * string) = - (tuple3 string string string) (parseOrRaise {| ["3", 4, "5"] |}) + (tuple3 string string string) + (parseOrRaise {| ["3", 4, "5"] |}) in fail "should throw" - with DecodeError Json_error "Expected string, got 4\n\tin tuple3" -> pass); + with + | DecodeError (Json_error "Expected string, got 4\n\tin tuple3") + -> + pass); test "not array" (fun () -> try let (_ : int * int * int) = (tuple3 int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError Json_error "Expected array, got 4" -> pass); + with DecodeError (Json_error "Expected array, got 4") -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -420,16 +492,23 @@ let () = in fail "should throw" with - | DecodeError Json_error "Expected array of length 4, got array of length 1" -> + | DecodeError + (Json_error + "Expected array of length 4, got array of length 1") + -> pass); test "too large" (fun () -> try let (_ : int * int * int * int) = - (tuple4 int int int int) (parseOrRaise {| [3, 4, 5, 6, 7, 8] |}) + (tuple4 int int int int) + (parseOrRaise {| [3, 4, 5, 6, 7, 8] |}) in fail "should throw" with - | DecodeError Json_error "Expected array of length 4, got array of length 6" -> + | DecodeError + (Json_error + "Expected array of length 4, got array of length 6") + -> pass); test "bad type a" (fun () -> try @@ -437,7 +516,11 @@ let () = (tuple4 int int int int) (parseOrRaise {| ["3", 4, 5, 6] |}) in fail "should throw" - with DecodeError Json_error "Expected number, got \"3\"\n\tin tuple4" -> pass); + with + | DecodeError + (Json_error "Expected number, got \"3\"\n\tin tuple4") + -> + pass); test "bad type b" (fun () -> try let (_ : string * string * string * string) = @@ -445,14 +528,17 @@ let () = (parseOrRaise {| ["3", 4, "5", "6"] |}) in fail "should throw" - with DecodeError Json_error "Expected string, got 4\n\tin tuple4" -> pass); + with + | DecodeError (Json_error "Expected string, got 4\n\tin tuple4") + -> + pass); test "not array" (fun () -> try let (_ : int * int * int * int) = (tuple4 int int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError Json_error "Expected array, got 4" -> pass); + with DecodeError (Json_error "Expected array, got 4") -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -467,10 +553,12 @@ let () = let open Json in let open! Decode in test "object" (fun () -> - expect @@ dict int (Encode.object_ []) |> toEqual (Js.Dict.empty ())); + expect @@ dict int (Encode.object_ []) + |> toEqual (Js.Dict.empty ())); test "boolean" (fun () -> - expect @@ dict bool (parseOrRaise {| { "a": true, "b": false } |}) + expect + @@ dict bool (parseOrRaise {| { "a": true, "b": false } |}) |> toEqual (Obj.magic [%obj { a = true; b = false }])); test "float" (fun () -> expect @@ dict float (parseOrRaise {| { "a": 1.2, "b": 2.3 } |}) @@ -479,11 +567,13 @@ let () = expect @@ dict int (parseOrRaise {| { "a": 1, "b": 2 } |}) |> toEqual (Obj.magic [%obj { a = 1; b = 2 }])); test "string" (fun () -> - expect @@ dict string (parseOrRaise {| { "a": "x", "b": "y" } |}) + expect + @@ dict string (parseOrRaise {| { "a": "x", "b": "y" } |}) |> toEqual (Obj.magic [%obj { a = "x"; b = "y" }])); test "nullAs" (fun () -> expect - @@ dict (nullAs Js.null) (parseOrRaise {| { "a": null, "b": null } |}) + @@ dict (nullAs Js.null) + (parseOrRaise {| { "a": null, "b": null } |}) |> toEqual (Obj.magic [%obj { a = Js.null; b = Js.null }])); test "null -> dict string" (fun () -> try @@ -491,7 +581,11 @@ let () = (dict string) (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError Json_error "Expected string, got null\n\tin dict" -> pass); + with + | DecodeError + (Json_error "Expected string, got null\n\tin dict") + -> + pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -501,7 +595,8 @@ let () = fail "should throw" with Foo -> pass); - Test.throws (dict int) [ Bool; Float; Int; String; Null; Array; Char ]); + Test.throws (dict int) + [ Bool; Float; Int; String; Null; Array; Char ]); describe "field" (fun () -> let open Json in @@ -511,13 +606,15 @@ let () = @@ field "b" bool (parseOrRaise {| { "a": true, "b": false } |}) |> toEqual false); test "float" (fun () -> - expect @@ field "b" float (parseOrRaise {| { "a": 1.2, "b": 2.3 } |}) + expect + @@ field "b" float (parseOrRaise {| { "a": 1.2, "b": 2.3 } |}) |> toEqual 2.3); test "int" (fun () -> expect @@ field "b" int (parseOrRaise {| { "a": 1, "b": 2 } |}) |> toEqual 2); test "string" (fun () -> - expect @@ field "b" string (parseOrRaise {| { "a": "x", "b": "y" } |}) + expect + @@ field "b" string (parseOrRaise {| { "a": "x", "b": "y" } |}) |> toEqual "y"); test "nullAs" (fun () -> expect @@ -527,23 +624,30 @@ let () = test "missing key" (fun () -> try let (_ : string) = - (field "c" string) (parseOrRaise {| { "a": null, "b": null } |}) + (field "c" string) + (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError Json_error "Expected field 'c'" -> pass); + with DecodeError (Json_error "Expected field 'c'") -> pass); test "decoder error" (fun () -> try let (_ : string) = - (field "b" string) (parseOrRaise {| { "a": null, "b": null } |}) + (field "b" string) + (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError Json_error "Expected string, got null\n\tat field 'b'" -> pass); + with + | DecodeError + (Json_error "Expected string, got null\n\tat field 'b'") + -> + pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try let _ = - (field "a" (fun _ -> raise Foo)) (parseOrRaise {| { "a": 0 } |}) + (field "a" (fun _ -> raise Foo)) + (parseOrRaise {| { "a": 0 } |}) in fail "should throw" with Foo -> pass); @@ -584,7 +688,10 @@ let () = } |}) in fail "should throw" - with DecodeError Json_error "Expected field 'y'\n\tat field 'a'" -> pass); + with + | DecodeError (Json_error "Expected field 'y'\n\tat field 'a'") + -> + pass); test "decoder error" (fun () -> try let (_ : 'a Js.null) = @@ -598,10 +705,11 @@ let () = fail "should throw" with | DecodeError - Json_error "Expected null, got \"foo\"\n\ - \tat field 'y'\n\ - \tat field 'x'\n\ - \tat field 'a'" + (Json_error + "Expected null, got \"foo\"\n\ + \tat field 'y'\n\ + \tat field 'x'\n\ + \tat field 'a'") -> pass); test "empty list of keys should raise Invalid_argument" (fun () -> @@ -637,9 +745,11 @@ let () = expect @@ (optional int) (Encode.object_ []) |> toEqual None); test "boolean -> boolean " (fun () -> - expect @@ optional bool (Encode.bool true) |> toEqual (Some true)); + expect @@ optional bool (Encode.bool true) + |> toEqual (Some true)); test "float -> float" (fun () -> - expect @@ optional float (Encode.float 1.23) |> toEqual (Some 1.23)); + expect @@ optional float (Encode.float 1.23) + |> toEqual (Some 1.23)); test "string -> string" (fun () -> expect @@ optional string (Encode.string "test") |> toEqual (Some "test")); @@ -650,19 +760,24 @@ let () = expect @@ (optional bool) (Encode.int 1) |> toEqual None); test "optional field" (fun () -> - expect @@ optional (field "x" int) (parseOrRaise {| { "x": 2} |}) + expect + @@ optional (field "x" int) (parseOrRaise {| { "x": 2} |}) |> toEqual (Some 2)); test "optional field - incorrect type" (fun () -> - expect @@ optional (field "x" int) (parseOrRaise {| { "x": 2.3} |}) + expect + @@ optional (field "x" int) (parseOrRaise {| { "x": 2.3} |}) |> toEqual None); test "optional field - no such field" (fun () -> - expect @@ optional (field "y" int) (parseOrRaise {| { "x": 2} |}) + expect + @@ optional (field "y" int) (parseOrRaise {| { "x": 2} |}) |> toEqual None); test "field optional" (fun () -> - expect @@ field "x" (optional int) (parseOrRaise {| { "x": 2} |}) + expect + @@ field "x" (optional int) (parseOrRaise {| { "x": 2} |}) |> toEqual (Some 2)); test "field optional - incorrect type" (fun () -> - expect @@ field "x" (optional int) (parseOrRaise {| { "x": 2.3} |}) + expect + @@ field "x" (optional int) (parseOrRaise {| { "x": 2.3} |}) |> toEqual None); test "field optional - no such field" (fun () -> try @@ -670,12 +785,14 @@ let () = (field "y" (optional int)) (parseOrRaise {| { "x": 2} |}) in fail "should throw" - with DecodeError Json_error "Expected field 'y'" -> pass); + with DecodeError (Json_error "Expected field 'y'") -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try - let (_ : 'a option) = (optional (fun _ -> raise Foo)) Encode.null in + let (_ : 'a option) = + (optional (fun _ -> raise Foo)) Encode.null + in fail "should throw" with Foo -> pass)); @@ -687,7 +804,8 @@ let () = @@ (oneOf [ int; field "x" int ]) (parseOrRaise {| { "x": 2} |}) |> toEqual 2); test "int" (fun () -> - expect @@ (oneOf [ int; field "x" int ]) (Encode.int 23) |> toEqual 23); + expect @@ (oneOf [ int; field "x" int ]) (Encode.int 23) + |> toEqual 23); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -704,10 +822,12 @@ let () = let open Json in let open! Decode in test "object with field" (fun () -> - expect @@ (either int (field "x" int)) (parseOrRaise {| { "x": 2} |}) + expect + @@ (either int (field "x" int)) (parseOrRaise {| { "x": 2} |}) |> toEqual 2); test "int" (fun () -> - expect @@ (either int (field "x" int)) (Encode.int 23) |> toEqual 23); + expect @@ (either int (field "x" int)) (Encode.int 23) + |> toEqual 23); Test.throws (either int (field "x" int)) @@ -723,11 +843,13 @@ let () = test "int" (fun () -> expect @@ (withDefault 0 int) (Encode.int 23) |> toEqual 23); test "string" (fun () -> - expect @@ (withDefault 0 int) (Encode.string "test") |> toEqual 0); + expect @@ (withDefault 0 int) (Encode.string "test") + |> toEqual 0); test "null" (fun () -> expect @@ (withDefault 0 int) Encode.null |> toEqual 0); test "array" (fun () -> - expect @@ (withDefault 0 int) (Encode.jsonArray [||]) |> toEqual 0); + expect @@ (withDefault 0 int) (Encode.jsonArray [||]) + |> toEqual 0); test "object" (fun () -> expect @@ (withDefault 0 int) (Encode.object_ []) |> toEqual 0); @@ -770,7 +892,9 @@ let () = Test.throws ~name:"float andThen int " (float |> andThen (fun _ -> int)) [ Float ]; - Test.throws ~name:"int to " (int |> andThen (fun _ -> float)) [ Float ]); + Test.throws ~name:"int to " + (int |> andThen (fun _ -> float)) + [ Float ]); describe "composite expressions" (fun () -> let open Json in @@ -779,7 +903,8 @@ let () = expect @@ dict (array (array int)) - (parseOrRaise {| { "a": [[1, 2], [3]], "b": [[4], [5, 6]] } |}) + (parseOrRaise + {| { "a": [[1, 2], [3]], "b": [[4], [5, 6]] } |}) |> toEqual (Obj.magic [%obj @@ -797,25 +922,32 @@ let () = fail "should throw" with | DecodeError - Json_error "Expected number, got true\n\ - \tin array at index 0\n\ - \tin array at index 1\n\ - \tin dict" + (Json_error + "Expected number, got true\n\ + \tin array at index 0\n\ + \tin array at index 1\n\ + \tin dict") -> pass); test "dict array array int - heterogenous structure 2" (fun () -> try let (_ : int array array Js.Dict.t) = (dict (array (array int))) - (parseOrRaise {| { "a": [[1, 2], "foo"], "b": [[4], [5, 6]] } |}) + (parseOrRaise + {| { "a": [[1, 2], "foo"], "b": [[4], [5, 6]] } |}) in fail "should throw" with | DecodeError - Json_error "Expected array, got \"foo\"\n\tin array at index 1\n\tin dict" + (Json_error + "Expected array, got \"foo\"\n\ + \tin array at index 1\n\ + \tin dict") -> pass); test "field" (fun () -> - let json = parseOrRaise {| { "foo": [1, 2, 3], "bar": "baz" } |} in + let json = + parseOrRaise {| { "foo": [1, 2, 3], "bar": "baz" } |} + in expect @@ (field "foo" (array int) json, field "bar" string json) |> toEqual ([| 1; 2; 3 |], "baz"))) diff --git a/src/__tests__/Json_encode_test.ml b/src/__tests__/Json_encode_test.ml index 97236e5..0eed75f 100644 --- a/src/__tests__/Json_encode_test.ml +++ b/src/__tests__/Json_encode_test.ml @@ -2,149 +2,99 @@ open Jest open Expect open! Json.Encode - let _ = + test "null" (fun () -> expect null |> toEqual @@ Obj.magic Js.null); + + test "string" (fun () -> + expect @@ string "foo" |> toEqual @@ Obj.magic "foo"); + + test "float" (fun () -> + expect @@ float 1.23 |> toEqual @@ Obj.magic 1.23); + + test "int" (fun () -> expect @@ int 23 |> toEqual @@ Obj.magic 23); + + test "bool" (fun () -> expect @@ bool true |> toEqual @@ Obj.magic true); + + test "date" (fun () -> + expect @@ date (Js.Date.fromString "2012-04-23T18:25:43.511Z") + |> toEqual @@ Obj.magic "2012-04-23T18:25:43.511Z"); + + test "char" (fun () -> expect @@ char 'a' |> toEqual @@ Obj.magic "a"); + + test "jsonDict - empty" (fun () -> + expect @@ jsonDict @@ Js.Dict.empty () + |> toEqual @@ Obj.magic @@ Js.Dict.empty ()); + + test "jsonDict - simple" (fun () -> + let o = Js.Dict.empty () in + Js.Dict.set o "x" (int 42); + + expect @@ jsonDict o |> toEqual @@ Obj.magic o); + + test "dict - simple" (fun () -> + let o = Js.Dict.empty () in + Js.Dict.set o "x" 42; + + expect @@ dict int o |> toEqual @@ Obj.magic o); + + test "object_ - empty" (fun () -> + expect @@ object_ @@ [] |> toEqual @@ Obj.magic @@ Js.Dict.empty ()); + + test "object_ - simple" (fun () -> + expect @@ object_ [ "x", int 42 ] + |> toEqual @@ Obj.magic (Js.Dict.fromList [ "x", 42 ])); + + test "array int" (fun () -> + expect @@ array int [| 1; 2; 3 |] + |> toEqual @@ Obj.magic [| 1; 2; 3 |]); + + test "list int" (fun () -> + expect @@ list int [ 1; 2; 3 ] |> toEqual @@ Obj.magic [| 1; 2; 3 |]); + + test "jsonArray int" (fun () -> + expect @@ jsonArray ([| 1; 2; 3 |] |> Array.map int) + |> toEqual @@ Obj.magic [| 1; 2; 3 |]); + + test "stringArray" (fun () -> + expect @@ stringArray [| "a"; "b" |] + |> toEqual @@ Obj.magic [| "a"; "b" |]); + + test "numberArray" (fun () -> + expect @@ numberArray [| 0.; 4. |] + |> toEqual @@ Obj.magic [| 0; 4 |]); + + test "boolArray" (fun () -> + expect @@ boolArray [| true; false |] + |> toEqual @@ Obj.magic [| true; false |]); + + test "nullable (None)" (fun () -> + expect @@ nullable string None |> toEqual @@ null); + + test "nullable (Some)" (fun () -> + expect @@ nullable string (Some "success") + |> toEqual @@ string "success"); + + test "withDefault (None)" (fun () -> + expect @@ withDefault (string "default") string None + |> toEqual @@ string "default"); + + test "withDefault (Some)" (fun () -> + expect @@ withDefault (string "default") string (Some "success") + |> toEqual @@ string "success"); + + test "pair" (fun () -> + expect @@ pair string float ("hello", 1.2) + |> toEqual @@ jsonArray [| string "hello"; float 1.2 |]); + + test "tuple2" (fun () -> + expect @@ tuple2 string float ("hello", 1.2) + |> toEqual @@ jsonArray [| string "hello"; float 1.2 |]); + + test "tuple3" (fun () -> + expect @@ tuple3 string float int ("hello", 1.2, 4) + |> toEqual @@ jsonArray [| string "hello"; float 1.2; int 4 |]); -test "null" (fun () -> - expect - null - |> toEqual @@ Obj.magic Js.null); - -test "string" (fun () -> - expect @@ - string "foo" - |> toEqual @@ Obj.magic "foo"); - -test "float" (fun () -> - expect @@ - float 1.23 - |> toEqual @@ Obj.magic 1.23); - -test "int" (fun () -> - expect @@ - int 23 - |> toEqual @@ Obj.magic 23); - -test "bool" (fun () -> - expect @@ - bool true - |> toEqual @@ Obj.magic true); - -test "date" (fun () -> - expect @@ - date (Js.Date.fromString "2012-04-23T18:25:43.511Z") - |> toEqual @@ Obj.magic "2012-04-23T18:25:43.511Z"); - -test "char" (fun () -> - expect @@ - char 'a' - |> toEqual @@ Obj.magic "a"); - -test "jsonDict - empty" (fun () -> - expect @@ - jsonDict @@ Js.Dict.empty () - |> toEqual @@ Obj.magic @@ Js.Dict.empty ()); - -test "jsonDict - simple" (fun () -> - let o = Js.Dict.empty () in - Js.Dict.set o "x" (int 42); - - expect @@ - jsonDict o - |> toEqual @@ Obj.magic o); - -test "dict - simple" (fun () -> - let o = Js.Dict.empty () in - Js.Dict.set o "x" 42; - - expect @@ - dict int o - |> toEqual @@ Obj.magic o); - -test "object_ - empty" (fun () -> - expect @@ - object_ @@ [] - |> toEqual @@ Obj.magic @@ Js.Dict.empty ()); - -test "object_ - simple" (fun () -> - expect @@ - object_ [("x", int 42)] - |> toEqual @@ Obj.magic (Js.Dict.fromList [("x", 42)])); - -test "array int" (fun () -> - expect @@ - array int [|1;2;3|] - |> toEqual @@ Obj.magic [|1;2;3|]); - -test "list int" (fun () -> - expect @@ - list int [1;2;3] - |> toEqual @@ Obj.magic [|1;2;3|]); - -test "jsonArray int" (fun () -> - expect @@ - jsonArray ([|1;2;3|] |> Array.map int) - |> toEqual @@ Obj.magic [|1;2;3|]); - -test "stringArray" (fun () -> - expect @@ - stringArray [|"a";"b"|] - |> toEqual @@ Obj.magic [|"a";"b"|]); - -test "numberArray" (fun () -> - expect @@ - numberArray [|0.;4.|] - |> toEqual @@ Obj.magic [|0;4|]); - -test "boolArray" (fun () -> - expect @@ - boolArray [|true;false|] - |> toEqual @@ Obj.magic [|true;false|]); - -test "nullable (None)" (fun () -> - expect @@ - nullable string None - |> toEqual @@ null -); - -test "nullable (Some)" (fun () -> - expect @@ - nullable string (Some "success") - |> toEqual @@ string "success" -); - -test "withDefault (None)" (fun () -> - expect @@ - withDefault (string "default") string None - |> toEqual @@ string "default" -); - -test "withDefault (Some)" (fun () -> - expect @@ - withDefault (string "default") string (Some "success") - |> toEqual @@ string "success" -); - -test "pair" (fun () -> - expect @@ - pair string float ("hello", 1.2) - |> toEqual @@ jsonArray [|string "hello"; float 1.2|] -); - -test "tuple2" (fun () -> - expect @@ - tuple2 string float ("hello", 1.2) - |> toEqual @@ jsonArray [|string "hello"; float 1.2|] -); - -test "tuple3" (fun () -> - expect @@ - tuple3 string float int ("hello", 1.2, 4) - |> toEqual @@ jsonArray [|string "hello"; float 1.2; int 4|] -); - -test "tuple4" (fun () -> - expect @@ - tuple4 string float int bool ("hello", 1.2, 4, true) - |> toEqual @@ jsonArray [|string "hello"; float 1.2; int 4; bool true|] -); + test "tuple4" (fun () -> + expect @@ tuple4 string float int bool ("hello", 1.2, 4, true) + |> toEqual + @@ jsonArray [| string "hello"; float 1.2; int 4; bool true |]) diff --git a/src/__tests__/Json_test.ml b/src/__tests__/Json_test.ml index dac4a13..10199ce 100644 --- a/src/__tests__/Json_test.ml +++ b/src/__tests__/Json_test.ml @@ -19,13 +19,15 @@ let _ = fail "should throw" with | ParseError "Unexpected end of JSON input" - | ParseError (* Node.js v20 *) + | ParseError + (* Node.js v20 *) "Expected property name or '}' in JSON at position 1" | ParseError (* Node.js v21 *) - "Expected property name or '}' in JSON at position 1 (line 1 \ - column 2)" + "Expected property name or '}' in JSON at position 1 (line \ + 1 column 2)" -> pass)); - test "stringify" (fun () -> expect @@ stringify Encode.null |> toEqual "null") + test "stringify" (fun () -> + expect @@ stringify Encode.null |> toEqual "null") From 610e75300b65defcc21a96bd774432cfdfee47d2 Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Thu, 5 Dec 2024 12:29:13 +0400 Subject: [PATCH 04/20] wip --- src/Json.ml | 405 ++++++++++++++++++--------- src/Json.mli | 776 ++++++++++++++++----------------------------------- 2 files changed, 504 insertions(+), 677 deletions(-) diff --git a/src/Json.ml b/src/Json.ml index fc2a21f..a1599b8 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -1,82 +1,102 @@ -module Decode = struct - external _unsafeCreateUninitializedArray : int -> 'a array = "Array" - [@@mel.new] +type t = Js.Json.t +type json = t - external _stringify : Js.Json.t -> string = "JSON.stringify" +let to_json t = t +let of_json t = t - let _isInteger value = - Js.Float.isFinite value && Js.Math.floor_float value == value +type 'a of_json = Js.Json.t -> 'a +type 'a to_json = 'a -> Js.Json.t +type of_json_error = Json_error of string | Unexpected_variant of string - type 'a decoder = Js.Json.t -> 'a - type error = Json_error of string | Unexpected_variant of string +let of_json_error_to_string = function + | Json_error msg -> msg + | Unexpected_variant tag -> "unexpected variant: " ^ tag - let error_to_string = function - | Json_error msg -> msg - | Unexpected_variant tag -> "unexpected variant: " ^ tag +exception Of_json_error of of_json_error - exception DecodeError of error +let of_json_error msg = raise (Of_json_error (Json_error msg)) +let to_string t = Js.Json.stringify t - let error msg = raise (DecodeError (Json_error msg)) - let id json = json +exception Of_string_error of string - let bool json = - if Js.typeof json = "boolean" then - (Obj.magic (json : Js.Json.t) : bool) - else error ("Expected boolean, got " ^ _stringify json) +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 = + (* msg really cannot be None in browser or any sane JS runtime *) + Option.value msg ~default:"JSON error" + in + raise (Of_string_error msg) - let float json = - if Js.typeof json = "number" then - (Obj.magic (json : Js.Json.t) : float) - else error ("Expected number, got " ^ _stringify json) +module Of_json = struct + external _stringify : Js.Json.t -> string = "JSON.stringify" - let int json = - let f = float json in - if _isInteger f then (Obj.magic (f : float) : int) - else error ("Expected integer, got " ^ _stringify json) + let string (json : t) : string = + if Js.typeof json = "string" then (Obj.magic json : string) + else of_json_error "expected a string" - let string json = + let char (json : t) = if Js.typeof json = "string" then - (Obj.magic (json : Js.Json.t) : string) - else error ("Expected string, got " ^ _stringify json) + let s = (Obj.magic json : string) in + if String.length s = 1 then String.get s 0 + else of_json_error "expected a single-character string" + else of_json_error "expected a string" - let char json = - let s = string json in - if String.length s = 1 then String.get s 0 - else error ("Expected single-character string, got " ^ _stringify json) + let bool (json : t) : bool = + if Js.typeof json = "boolean" then (Obj.magic json : bool) + else of_json_error "expected a boolean" - let date json = json |> string |> Js.Date.fromString + let is_int value = + Js.Float.isFinite value && Js.Math.floor_float value == value - let nullable decode json = - if (Obj.magic json : 'a Js.null) == Js.null then Js.null - else Js.Null.return (decode json) + let int (json : t) : int = + if Js.typeof json = "number" then + let v = (Obj.magic json : float) in + if is_int v then (Obj.magic v : int) + else of_json_error "expected an integer" + else of_json_error "expected an integer" - (* TODO: remove this? *) - let nullAs value json = - if (Obj.magic json : 'a Js.null) == Js.null then value - else error ("Expected null, got " ^ _stringify json) + let int64 (json : t) : int64 = + if Js.typeof json = "string" then + let v = (Obj.magic json : string) in + match Int64.of_string_opt v with + | Some v -> v + | None -> of_json_error "expected int64 as string" + else of_json_error "expected int64 as string" - let array decode json = - if Js.Array.isArray json then ( - let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in - let length = Js.Array.length source in - let target = _unsafeCreateUninitializedArray length in - for i = 0 to length - 1 do - let value = - try decode (Array.unsafe_get source i) - with DecodeError err -> - error - (error_to_string err - ^ "\n\tin array at index " - ^ string_of_int i) - in - Array.unsafe_set target i value - done; - target) - else error ("Expected array, got " ^ _stringify json) + let float (json : t) : float = + if Js.typeof json = "number" then (Obj.magic json : float) + else of_json_error "expected a float" - let list decode json = json |> array decode |> Array.to_list + let unit (json : t) : unit = + if (Obj.magic json : 'a Js.null) == Js.null then () + else of_json_error "expected null" - let pair decodeA decodeB json = + let array v_of_json (json : t) : _ array = + if Js.Array.isArray json then + let json = (Obj.magic json : Js.Json.t array) in + Js.Array.map ~f:v_of_json json + else of_json_error "expected a JSON array" + + let list v_of_json (json : t) : _ list = + array v_of_json json |> Array.to_list + + let option v_of_json (json : t) : _ option = + if (Obj.magic json : 'a Js.null) == Js.null then None + else Some (v_of_json json) + + let js_null v_of_json (json : t) : _ Js.null = + if (Obj.magic json : 'a Js.null) == Js.null then Js.null + else Js.Null.return (v_of_json json) + + let js_date json : Js.Date.t = Js.Date.fromString (string json) + + let tuple2 decodeA decodeB json : _ * _ = if Js.Array.isArray json then let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in let length = Js.Array.length source in @@ -84,17 +104,16 @@ module Decode = struct try ( decodeA (Array.unsafe_get source 0), decodeB (Array.unsafe_get source 1) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin pair/tuple2") + with Of_json_error err -> + of_json_error + (of_json_error_to_string err ^ "\n\tin pair/tuple2") else let length = Js.String.make length in - error + of_json_error {j|Expected array of length 2, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) - - let tuple2 = pair + else of_json_error ("Expected array, got " ^ _stringify json) - let tuple3 decodeA decodeB decodeC json = + let tuple3 decodeA decodeB decodeC json : _ * _ * _ = if Js.Array.isArray json then let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in let length = Js.Array.length source in @@ -103,15 +122,15 @@ module Decode = struct ( decodeA (Array.unsafe_get source 0), decodeB (Array.unsafe_get source 1), decodeC (Array.unsafe_get source 2) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple3") + with Of_json_error err -> + of_json_error (of_json_error_to_string err ^ "\n\tin tuple3") else let length = Js.String.make length in - error + of_json_error {j|Expected array of length 3, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) + else of_json_error ("Expected array, got " ^ _stringify json) - let tuple4 decodeA decodeB decodeC decodeD json = + let tuple4 decodeA decodeB decodeC decodeD json : _ * _ * _ * _ = if Js.Array.isArray json then let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in let length = Js.Array.length source in @@ -121,15 +140,15 @@ module Decode = struct decodeB (Array.unsafe_get source 1), decodeC (Array.unsafe_get source 2), decodeD (Array.unsafe_get source 3) ) - with DecodeError err -> - error (error_to_string err ^ "\n\tin tuple4") + with Of_json_error err -> + of_json_error (of_json_error_to_string err ^ "\n\tin tuple4") else let length = Js.String.make length in - error + of_json_error {j|Expected array of length 4, got array of length $length|j} - else error ("Expected array, got " ^ _stringify json) + else of_json_error ("Expected array, got " ^ _stringify json) - let dict decode json = + let js_dict decode json : _ Js.Dict.t = if Js.typeof json = "object" && (not (Js.Array.isArray json)) @@ -143,15 +162,38 @@ module Decode = struct let key = Array.unsafe_get keys i in let value = try decode (Js.Dict.unsafeGet source key) - with DecodeError err -> - error (error_to_string err ^ "\n\tin dict") + with Of_json_error err -> + of_json_error (of_json_error_to_string err ^ "\n\tin dict") in Js.Dict.set target key value done; target) - else error ("Expected object, got " ^ _stringify json) + else of_json_error ("Expected object, got " ^ _stringify json) - let field key decode json = + let result ok_of_json err_of_json (json : t) : (_, _) result = + if Js.Array.isArray json then + let array = (Obj.magic json : Js.Json.t array) in + let len = Js.Array.length array in + if Stdlib.( > ) len 0 then + let tag = Js.Array.unsafe_get array 0 in + if Stdlib.( = ) (Js.typeof tag) "string" then + let tag = (Obj.magic tag : string) in + if Stdlib.( = ) tag "Ok" then ( + if Stdlib.( <> ) len 2 then + of_json_error "expected a JSON array of length 2"; + Ok (ok_of_json (Js.Array.unsafe_get array 1))) + else if Stdlib.( = ) tag "Error" then ( + if Stdlib.( <> ) len 2 then + of_json_error "expected a JSON array of length 2"; + Error (err_of_json (Js.Array.unsafe_get array 1))) + else of_json_error "invalid JSON" + else + of_json_error + "expected a non empty JSON array with element being a string" + else of_json_error "expected a non empty JSON array" + else of_json_error "expected a non empty JSON array" + + let at' key decode json = if Js.typeof json = "object" && (not (Js.Array.isArray json)) @@ -161,24 +203,23 @@ module Decode = struct match Js.Dict.get dict key with | Some value -> ( try decode value - with DecodeError err -> - error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) - | None -> error {j|Expected field '$(key)'|j} - else error ("Expected object, got " ^ _stringify json) + with Of_json_error err -> + of_json_error + (of_json_error_to_string err ^ "\n\tat field '" ^ key ^ "'") + ) + | None -> of_json_error {j|Expected field '$(key)'|j} + else of_json_error ("Expected object, got " ^ _stringify json) let rec at key_path decoder = match key_path with - | [ key ] -> field key decoder - | first :: rest -> field first (at rest decoder) + | [ key ] -> at' key decoder + | first :: rest -> at' first (at rest decoder) | [] -> raise @@ Invalid_argument "Expected key_path to contain at least one element" - let optional decode json = - try Some (decode json) with DecodeError _ -> None - - let oneOf decoders json = + let one_of decoders json = let rec inner decoders errors = match decoders with | [] -> @@ -186,77 +227,169 @@ module Decode = struct "\n- " ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) in - error + of_json_error ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} ^ _stringify json) | decode :: rest -> ( - try decode json with DecodeError e -> inner rest (e :: errors)) + try decode json + with Of_json_error e -> inner rest (e :: errors)) in inner decoders [] - let either a b = oneOf [ a; b ] + let either a b = one_of [ a; b ] + + let try_or_none decode json = + try Some (decode json) with Of_json_error _ -> None - let withDefault default decode json = - try decode json with DecodeError _ -> default + let try_of_default default decode json = + try decode json with Of_json_error _ -> default let map f decode json = f (decode json) - let andThen b a json = b (a json) json end -module Encode = struct - type 'a encoder = 'a -> Js.Json.t +module To_json = struct + external string : string -> t = "%identity" + external bool : bool -> t = "%identity" + external int : int -> t = "%identity" - external null : Js.Json.t = "null" - external string : string -> Js.Json.t = "%identity" - external float : float -> Js.Json.t = "%identity" - external int : int -> Js.Json.t = "%identity" - external bool : bool -> Js.Json.t = "%identity" + let int64 : int64 -> t = fun v -> Obj.magic (Int64.to_string v) - let char c = c |> String.make 1 |> string - let date d = d |> Js.Date.toJSONUnsafe |> string - let nullable encode = function None -> null | Some v -> encode v - let withDefault d encode = function None -> d | Some v -> encode v + external float : float -> t = "%identity" - external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" + let unit () : t = Obj.magic Js.null - let dict encode d = - let pairs = Js.Dict.entries d in - let encodedPairs = Array.map (fun (k, v) -> k, encode v) pairs in - jsonDict (Js.Dict.fromArray encodedPairs) + let array v_to_json vs : t = + let vs : Js.Json.t array = Js.Array.map ~f:v_to_json vs in + Obj.magic vs - let object_ props : Js.Json.t = props |> Js.Dict.fromList |> jsonDict + let list v_to_json vs : t = + let vs = Array.of_list vs in + array v_to_json vs - external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" + let option v_to_json v : t = + match v with None -> Obj.magic Js.null | Some v -> v_to_json v - let array encode l = l |> Array.map encode |> jsonArray + let result a_to_json b_to_json v : t = + match v with + | Ok x -> Obj.magic [| string "Ok"; a_to_json x |] + | Error x -> Obj.magic [| string "Error"; b_to_json x |] - let list encode = function - | [] -> jsonArray [||] - | hd :: tl as l -> - let a = Array.make (List.length l) (encode hd) in - let rec fill i = function - | [] -> a - | hd :: tl -> - Array.unsafe_set a i (encode hd); - fill (i + 1) tl - in - jsonArray (fill 1 tl) + let char c = string (String.make 1 c) + let js_date d = string (Js.Date.toJSONUnsafe d) - let pair encodeA encodeB (a, b) = jsonArray [| encodeA a; encodeB b |] - let tuple2 = pair + let js_null v_to_json v = + match Js.Null.toOption v with + | None -> Obj.magic Js.null + | Some v -> v_to_json v + + external json_dict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" + + let js_dict encode d = + let pairs = Js.Dict.entries d in + let encodedPairs = Array.map (fun (k, v) -> k, encode v) pairs in + json_dict (Js.Dict.fromArray encodedPairs) + + external json_array : Js.Json.t array -> Js.Json.t = "%identity" + + let tuple2 encodeA encodeB (a, b) = + json_array [| encodeA a; encodeB b |] let tuple3 encodeA encodeB encodeC (a, b, c) = - jsonArray [| encodeA a; encodeB b; encodeC c |] + json_array [| encodeA a; encodeB b; encodeC c |] let tuple4 encodeA encodeB encodeC encodeD (a, b, c, d) = - jsonArray [| encodeA a; encodeB b; encodeC c; encodeD d |] + json_array [| encodeA a; encodeB b; encodeC c; encodeD d |] - external stringArray : string array -> Js.Json.t = "%identity" - external numberArray : float array -> Js.Json.t = "%identity" - external boolArray : bool array -> Js.Json.t = "%identity" + external string_array : string array -> Js.Json.t = "%identity" + external float_array : float array -> Js.Json.t = "%identity" + external int_array : int array -> Js.Json.t = "%identity" + external bool_array : bool array -> Js.Json.t = "%identity" +end + +module Primitives = struct + let string_of_json = Of_json.string + let bool_of_json = Of_json.bool + let float_of_json = Of_json.float + let int_of_json = Of_json.int + let int64_of_json = Of_json.int64 + let option_of_json = Of_json.option + let unit_of_json = Of_json.unit + let result_of_json = Of_json.result + let list_of_json = Of_json.list + let array_of_json = Of_json.array + let string_to_json = To_json.string + let bool_to_json = To_json.bool + let float_to_json = To_json.float + let int_to_json = To_json.int + let int64_to_json = To_json.int64 + let option_to_json = To_json.option + let unit_to_json = To_json.unit + let result_to_json = To_json.result + let list_to_json = To_json.list + let array_to_json = To_json.array +end + +module Decode = struct + type 'a decoder = 'a of_json + + let id json = json + let bool = Of_json.bool + let float = Of_json.float + let int = Of_json.int + let string = Of_json.string + let char = Of_json.char + let date json = Of_json.js_date json + let nullable = Of_json.js_null + let array = Of_json.array + let list = Of_json.list + let pair = Of_json.tuple2 + let tuple2 = Of_json.tuple2 + let tuple3 = Of_json.tuple3 + let tuple4 = Of_json.tuple4 + let dict = Of_json.js_dict + let field = Of_json.at' + let at = Of_json.at + let optional = Of_json.try_or_none + let withDefault = Of_json.try_of_default + let oneOf = Of_json.one_of + let either = Of_json.either + let map = Of_json.map + let andThen b a json = b (a json) json + + let nullAs value json = + if (Obj.magic json : 'a Js.null) == Js.null then value + else of_json_error "Expected null" +end + +module Encode = struct + type 'a encoder = 'a to_json + + external null : t = "null" + + let string = To_json.string + let float = To_json.float + let int = To_json.int + let bool = To_json.bool + let char = To_json.char + let date = To_json.js_date + let list = To_json.list + let array = To_json.array + let nullable = To_json.option + let withDefault d encode = function None -> d | Some v -> encode v + let jsonDict = To_json.json_dict + let dict = To_json.js_dict + let object_ props = To_json.json_dict (Js.Dict.fromList props) + let jsonArray = To_json.json_array + let pair = To_json.tuple2 + let tuple2 = To_json.tuple2 + let tuple3 = To_json.tuple3 + let tuple4 = To_json.tuple4 + let stringArray = To_json.string_array + let numberArray = To_json.float_array + let boolArray = To_json.bool_array end -exception ParseError of string +exception ParseError = Of_string_error let parse s = try Some (Js.Json.parseExn s) with _ -> None diff --git a/src/Json.mli b/src/Json.mli index 5be9684..b77fc9f 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -101,618 +101,312 @@ let _ = ]} *) -module Decode : sig - (** Provides a set of low level combinator primitives to decode - Js.Json.t data structures A decoder combinator will return the - decoded value if successful, or raise a [DecodeError of string] if - unsuccessful, where the string argument contains the error message. - Decoders are designed to be combined to produce more complex - decoders that can decode arbitrary data structures, though the - emphasis for this library is for it to be {i possible} to decode any - given data structure, not necessarily for it to be {i convenient}. - For convenience you should look towards opinionated third-party - libraries. *) - - type 'a decoder = Js.Json.t -> 'a - (** The type of a decoder combinator *) - - type error = Json_error of string | Unexpected_variant of string +type t = Js.Json.t +(** The type of a JSON data structure *) - val error_to_string : error -> string +type json = t +(** Defined for convenience. *) - exception DecodeError of error +val to_string : json -> string +(** JSON can be encoded as a string. *) - val id : Js.Json.t decoder - (** Identity decoder. +type exn += + | Of_string_error of string + (** The exception raised when parsing JSON error occurs *) - {b Returns} the input JSON value. +val of_string : string -> json +(** JSON can be parsed from a string. Raises {Of_string_error}. *) - Always succeeds. You would use this if you wanted to partially decode - some JSON in stages; in the first stage you could decode some portion - of the input, while using [id] to keep the rest as JSON and decoding - that in subsequent stages. +type 'a to_json = 'a -> json +(** Describe how to encode a value into JSON. *) - @example {[ - open Json - (* returns [(1 : int, {"a": true} : Js.Json.t)] *) - let json = parseOrRaise {|{"id": 1, {"a": true}}|} - let _ = Decode.(int json, id json) - ]} *) +val to_json : json to_json +(** JSON can be encoded as JSON, trivially. *) - val bool : bool decoder - (** Decodes a JSON value into a [bool] - -{b Returns} a [bool] if the JSON value is a [true] or [false]. +(** The type of a error which occurs during decoding JSON values. *) +type of_json_error = Json_error of string | Unexpected_variant of string -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns true *) - let _ = Json.parseOrRaise "true" |> Decode.bool - (* returns false *) - let _ = Json.parseOrRaise "false" |> Decode.bool - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.bool - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.bool -]} -*) +type exn += + | Of_json_error of of_json_error + (** The exception raised when a decoding error occurs *) - val float : float decoder - (** Decodes a JSON value into a [float] - -{b Returns} a [float] if the JSON value is a number. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 1.23 *) - let _ = Json.parseOrRaise "1.23" |> Decode.float - (* returns 23. *) - let _ = Json.parseOrRaise "23" |> Decode.float - (* raises DecodeError *) - let _ = Json.parseOrRaise "true" |> Decode.float - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.float -]} -*) - - val int : int decoder - (** Decodes a JSON value into an [int] - -{b Returns} an [int] if the JSON value is a number. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "true" |> Decode.int - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.int -]} -*) - - val string : string decoder - (** Decodes a JSON value into a [string] - -{b Returns} a [string] if the JSON value is a string. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns "foo" *) - let _ = Json.parseOrRaise "\"foo\"" |> Decode.string - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.string - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.string -]} -*) - - val char : char decoder - (** Decodes a JSON value into a [char] - -{b Returns} a [char] if the JSON value is a single-character string. - -@raise [DecodeError] if unsuccessful. - -@example {[ - open Json - (* returns 'a' *) - let _ = Json.parseOrRaise "\"a\"" |> Decode.char - (* raises DecodeError *) - let _ = Json.parseOrRaise "\"abc\"" |> Decode.char - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.char -]} -*) - - val date : Js.Date.t decoder - (** Decodes an ISO8601-formatted JSON string into a [Js.Date.t] - - {b Returns} a [Js.Date.t] if the JSON value is an IS8601-formatted - string. - - @raise [DecodeError] if unsuccessful *) - - val nullable : 'a decoder -> 'a Js.null decoder - (** Decodes a JSON value into an ['a Js.null] - -{b Returns} [Js.null] if the JSON value is [null], or an ['a Js.null] if the -given decoder succeeds, - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (Js.Null.return 23) *) - let _ = Json.parseOrRaise "23" |> Decode.(nullable int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "1.23" |> Decode.(nullable int) - (* returns Js.null *) - let _ = Json.parseOrRaise "null" |> Decode.(nullable int) -]} -*) - - val nullAs : 'a -> 'a decoder - (** Returns the given value if the JSON value is [null] - -{b Returns} an ['a] if the JSON value is [null]. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* raises DecodeError *) - let _ = Json.parseOrRaise "\"x\"" |> Decode.nullAs "x" - (* returns "x" *) - let _ = Json.parseOrRaise "null" |> Decode.nullAs "x" - (* returns None *) - let _ = Json.parseOrRaise "null" |> Decode.nullAs None -]} -*) - - val array : 'a decoder -> 'a array decoder - (** Decodes a JSON array into an ['a array] using the given decoder on each element - -{b Returns} an ['a array] if the JSON value is a JSON array and all its -elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns [| 1; 2; 3 |] *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(array int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(array int) -]} -*) - - val list : 'a decoder -> 'a list decoder - (** Decodes a JSON array into an ['a list] using the given decoder on each element - -{b Returns} an ['a list] if the JSON value is a JSON array and all its -elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns [1; 2; 3] *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, "c"]" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(list int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(list int) -]} -*) +type 'a of_json = json -> 'a +(** Describes how to decode a value out of JSON. *) - val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder - (** Decodes a JSON array with two elements into an ['a * 'b] tuple using - each of the given decoders in order. +val of_json : json of_json +(** JSON can be decoded from JSON, trivially. *) -{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both - its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful - -@example {[ - open Json - (* returns (1, "bar") *) - let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(pair int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2]" |> Decode.(pair int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(pair int int) -]} -*) - - val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder - (** Decodes a JSON array with two elements into an ['a * 'b] tuple using - each of the given decoders in order. - -{b Alias of [pair]} - -{b Returns} an ['a * 'b] if the JSON value is a JSON array of length 2 and both - its elements are successfully decoded. - -@raise [DecodeError] if unsuccessful +module Of_json : sig + (** Provides a set of low level combinator primitives to decode + Js.Json.t data structures A decoder combinator will return the + decoded value if successful, or raise a [DecodeError of string] if + unsuccessful, where the string argument contains the error message. + Decoders are designed to be combined to produce more complex + decoders that can decode arbitrary data structures, though the + emphasis for this library is for it to be {i possible} to decode any + given data structure, not necessarily for it to be {i convenient}. + For convenience you should look towards opinionated third-party + libraries. *) -@example {[ - open Json - (* returns (1, "bar") *) - let _ = Json.parseOrRaise "[1, \"bar\"]" |> Decode.(tuple2 int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2]" |> Decode.(tuple2 int string) - (* raises DecodeError *) - let _ = Json.parseOrRaise "[1, 2, 3]" |> Decode.(tuple2 int int) -]} -*) + val string : string of_json + val char : char of_json + val bool : bool of_json + val int : int of_json + val int64 : int64 of_json + val float : float of_json + val unit : unit of_json + val array : 'a of_json -> 'a array of_json + val list : 'a of_json -> 'a list of_json + val option : 'a of_json -> 'a option of_json + val tuple2 : 'a of_json -> 'b of_json -> ('a * 'b) of_json val tuple3 : - 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder - (** Decodes a JSON array with three elements into an ['a * 'b * 'c] - tuple using each of the given decoders in order. - - {b Returns} an ['a * 'b * 'c] if the JSON value is a JSON array of - length 3 and all its elements are successfully decoded. - - @raise [DecodeError] if unsuccessful *) + 'a of_json -> 'b of_json -> 'c of_json -> ('a * 'b * 'c) of_json val tuple4 : - 'a decoder -> - 'b decoder -> - 'c decoder -> - 'd decoder -> - ('a * 'b * 'c * 'd) decoder - (** Decodes a JSON array with four elements into an ['a * 'b * 'c * 'd] - tuple using each of the given decoders in order. + 'a of_json -> + 'b of_json -> + 'c of_json -> + 'd of_json -> + ('a * 'b * 'c * 'd) of_json - {b Returns} an ['a * 'b * 'c * 'd] if the JSON value is a JSON array - of length 4 and all its elements are successfully decoded. + val result : 'a of_json -> 'b of_json -> ('a, 'b) result of_json - @raise [DecodeError] if unsuccessful *) + (** Auxiliary combinators *) - val dict : 'a decoder -> 'a Js.Dict.t decoder - (** Decodes a JSON object into a dict using the given decoder on each of its values - -{b Returns} an ['a Js.Dict.t] if the JSON value is a JSON object and all its -values are successfully decoded. + val at' : string -> 'a of_json -> 'a of_json + val at : string list -> 'a of_json -> 'a of_json + val one_of : 'a of_json list -> 'a of_json + val either : 'a of_json -> 'a of_json -> 'a of_json + val try_or_none : 'a of_json -> 'a option of_json + val try_of_default : 'a -> 'a of_json -> 'a of_json + val map : ('a -> 'b) -> 'a of_json -> 'b of_json -@raise [DecodeError] if unsuccessful + (** Some JS specific combinators. *) -@example {[ - open Json - (* returns (Js.Dict.fromList [("x", 23); ("y", 42)]) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(dict int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(dict int) -]} -*) + val js_dict : 'a of_json -> 'a Js.Dict.t of_json + val js_null : 'a of_json -> 'a Js.null of_json + val js_date : Js.Date.t of_json +end - val field : string -> 'a decoder -> 'a decoder - (** Decodes a JSON object with a specific field into the value of that field - -{b Returns} an ['a] if the JSON value is a JSON object with the given field -and a value that is successfully decoded with the given decoder. +module To_json : sig + external string : string -> json = "%identity" + external bool : bool -> json = "%identity" + external int : int -> json = "%identity" + val int64 : int64 -> json + external float : float -> json = "%identity" + val unit : unit to_json + val array : 'a to_json -> 'a array to_json + val list : 'a to_json -> 'a list to_json + val option : 'a to_json -> 'a option to_json + val result : 'a to_json -> 'b to_json -> ('a, 'b) result to_json + val char : char to_json + val tuple2 : 'a to_json -> 'b to_json -> ('a * 'b) to_json -@raise [DecodeError] if unsuccessful + val tuple3 : + 'a to_json -> 'b to_json -> 'c to_json -> ('a * 'b * 'c) to_json -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": 23, "y": 42 } |} |> Decode.(field "x" int) - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "123" |> Decode.(field "x" int) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(field "x" int) -]} -*) + val tuple4 : + 'a to_json -> + 'b to_json -> + 'c to_json -> + 'd to_json -> + ('a * 'b * 'c * 'd) to_json + + (** JS specific combinators. *) + + val js_date : Js.Date.t to_json + val js_null : 'a to_json -> 'a Js.null to_json + val js_dict : 'a to_json -> 'a Js.dict to_json + + (** More JS specific to_json converters which exploit JSON runtime + representation in JS runtimes. *) + + external json_dict : json Js.dict -> json = "%identity" + external json_array : json array -> json = "%identity" + external string_array : string array -> json = "%identity" + external float_array : float array -> json = "%identity" + external int_array : int array -> json = "%identity" + external bool_array : bool array -> json = "%identity" +end - val at : string list -> 'a decoder -> 'a decoder - (** Same as [field] but takes a top level field and a list of nested fields for decoding nested values. - -{b Returns} an ['a] if the JSON value is a JSON object with the given field -and a value that is successfully decoded with the given decoder. +module Primitives : sig + val string_of_json : json -> string + val bool_of_json : json -> bool + val float_of_json : json -> float + val int_of_json : json -> int + val int64_of_json : json -> int64 + val option_of_json : (json -> 'a) -> json -> 'a option + val unit_of_json : json -> unit + + val result_of_json : + (json -> 'a) -> (json -> 'b) -> json -> ('a, 'b) result + + val list_of_json : (json -> 'a) -> json -> 'a list + val array_of_json : (json -> 'a) -> json -> 'a array + val string_to_json : string -> json + val bool_to_json : bool -> json + val float_to_json : float -> json + val int_to_json : int -> json + val int64_to_json : int64 -> json + val option_to_json : ('a -> json) -> 'a option -> json + val unit_to_json : unit -> json + + val result_to_json : + ('a -> json) -> ('b -> json) -> ('a, 'b) result -> json + + val list_to_json : ('a -> json) -> 'a list -> json + val array_to_json : ('a -> json) -> 'a array -> json +end -@raise [DecodeError] if unsuccessful -@raise [Invalid_argument] if list of fields is empty +module Decode : sig + type 'a decoder = 'a of_json [@@deprecated "Use `of_json` instead"] + (** The type of a decoder combinator *) -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise {| { "x": {"foo": 23}, "y": 42 } |} |> Decode.(at ["x"; "foo"] int) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": null, "y": "b" } |} |> Decode.(at ["x"; "foo"] int) -]} -*) + val id : t of_json [@@deprecated "Use `of_json` instead"] + val bool : bool of_json [@@deprecated "Use `Of_json.bool` instead"] + val float : float of_json [@@deprecated "Use `Of_json.float` instead"] + val int : int of_json [@@deprecated "Use `Of_json.int` instead"] - val optional : 'a decoder -> 'a option decoder - (** Maps a decoder [result] to an option - -{b Returns} [Some of 'a] if the given decoder is successful, [None] if -it is not. + val string : string of_json + [@@deprecated "Use `Of_json.string` instead"] -This decoder will never raise a [DecodeError]. Its purpose is to catch and -transform [DecodeError]'s of a given decoder into [None]s by mapping its -[result] into an [option]. This prevents a decoder error from terminating -a composite decoder, and is useful to decode optional JSON object fields. + val char : char of_json [@@deprecated "Use `Of_json.char` instead"] -@example {[ - open Json - (* returns (Some 23) *) - let _ = Json.parseOrRaise "23" |> Decode.(optional int) - (* returns None *) - let _ = Json.parseOrRaise 1.23 |> Decode.(optional int) - (* returns None *) - let _ = Json.parseOrRaise "null" |> Decode.(optional int) - (* returns (Some 23) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "x" int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "y" int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(optional (field "z" int)) - (* returns (Some 23) *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "x" (optional int)) - (* returns None *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "y" (optional int)) - (* raises DecodeError *) - let _ = Json.parseOrRaise {| { "x": 23, "y": "b" } |} |> Decode.(field "z" (optional int)) -]} -*) + val date : Js.Date.t of_json + [@@deprecated "Use `Of_json.js_date` instead"] - val oneOf : 'a decoder list -> 'a decoder - (** Tries each [decoder] in order, retunring the result of the first that succeeds + val nullable : 'a of_json -> 'a Js.null of_json + [@@deprecated "Use `Of_json.js_null` instead"] -{b Returns} an ['a] if one of the decoders succeed. + val array : 'a of_json -> 'a array of_json + [@@deprecated "Use `Of_json.array` instead"] -@raise [DecodeError] if unsuccessful + val list : 'a of_json -> 'a list of_json + [@@deprecated "Use `Of_json.list` instead"] -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.(oneOf [int; field "x" int]) - (* returns 42 *) - let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(oneOf [int; field "x" int]) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(oneOf [int; field "x" int] -]} -*) + val pair : 'a of_json -> 'b of_json -> ('a * 'b) of_json + [@@deprecated "Use `Of_json.tuple2` instead"] - val either : 'a decoder -> 'a decoder -> 'a decoder - (** Tries each [decoder] in order, retunring the result of the first that succeeds + val tuple2 : 'a of_json -> 'b of_json -> ('a * 'b) of_json + [@@deprecated "Use `Of_json.tuple2` instead"] -{b Returns} an ['a] if one of the decoders succeed. + val tuple3 : + 'a of_json -> 'b of_json -> 'c of_json -> ('a * 'b * 'c) of_json + [@@deprecated "Use `Of_json.tuple3` instead"] -@raise [DecodeError] if unsuccessful + val tuple4 : + ('a of_json -> + 'b of_json -> + 'c of_json -> + 'd of_json -> + ('a * 'b * 'c * 'd) of_json + [@deprecated "Use `Of_json.tuple4` instead"]) -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.(either int (field "x" int)) - (* returns 42 *) - let _ = Json.parseOrRaise {| { "x": 42 } |} |> Decode.(either int (field "x" int)) - (* raises DecodeError *) - let _ = Json.parseOrRaise "null" |> Decode.(either int (field "x" int)) -]} -*) + val dict : 'a of_json -> 'a Js.Dict.t of_json + [@@deprecated "Use `Of_json.js_dict` instead"] - val withDefault : 'a -> 'a decoder -> 'a decoder - (** Tries the given [decoder] and returns its result if it succeeds, or the -given default value if it fails. + val field : string -> 'a of_json -> 'a of_json + [@@deprecated "Use `Of_json.at'` instead"] -{b Returns} an ['a]. + val at : string list -> 'a of_json -> 'a of_json + [@@deprecated "Use `Of_json.at` instead"] -@example {[ - open Json - (* returns 23 *) - let _ = Json.parseOrRaise "23" |> Decode.withDefault 0 int - (* returns 0 *) - let _ = Json.parseOrRaise "\"x\"" |> Decode.withDefault 0 int - (* returns 0 *) - let _ = Json.parseOrRaise "null" |> Decode.withDefault 0 int -]} -*) + val optional : 'a of_json -> 'a option of_json + [@@deprecated "Use `Of_json.try_or_none instead"] - val map : ('a -> 'b) -> 'a decoder -> 'b decoder - (** Returns a decoder that maps the result of the given decoder if successful + val oneOf : 'a of_json list -> 'a of_json + [@@deprecated "Use `Of_json.one_of` instead"] -{b Returns} a ['b] if the given decoder succeeds. + val either : 'a of_json -> 'a of_json -> 'a of_json + [@@deprecated "Use `Of_json.either` instead"] -@example {[ - open Json - (* returns 46 *) - let _ = Json.parseOrRaise "23" |> Decode.map (fun x -> x + x) int -]} -*) + val withDefault : 'a -> 'a of_json -> 'a of_json + [@@deprecated "Use `Of_json.try_of_default` instead"] - val andThen : ('a -> 'b decoder) -> 'a decoder -> 'b decoder - (** Returns a decoder that maps the result of the given decoder if successful + val map : ('a -> 'b) -> 'a of_json -> 'b of_json + [@@deprecated "Use `Of_json.map` instead"] -{b Returns} an ['a] if both decoders succeed. + val andThen : ('a -> 'b of_json) -> 'a of_json -> 'b of_json + [@@deprecated "Use `Of_json.map` instead"] -@example {[ - (* Decode a JSON tree structure *) - type 'a tree = - | Node of 'a * 'a tree list - | Leaf of 'a - - module Decode = struct - open Json.Decode - - let rec tree decoder = - field "type" string |> andThen ( - function | "node" -> node decoder - | "leaf" -> leaf decoder - | _ -> failwith "unknown node type" - ) - - and node decoder json = - Node ( - (json |> field "value" decoder), - (json |> field "children" (array (tree decoder) |> map Array.to_list)) - ) - - and leaf decoder json = - Leaf (json |> field "value" decoder) - end - - let json = {| { - "type": "node", - "value": 9, - "children": [{ - "type": "node", - "value": 5, - "children": [{ - "type": "leaf", - "value": 3 - }, { - "type": "leaf", - "value": 2 - }] - }, { - "type": "leaf", - "value": 4 - }] - } |} - - let myTree = - json |> Json.parseOrRaise - |> Decode.tree Json.Decode.int -]} -*) + val nullAs : 'a -> 'a of_json + [@@deprecated "Use `Of_json.option f |> Option.value ~default` instead"] end +[@@deprecated "Use `Of_json` instead"] module Encode : sig - (** Provides functions for encoding a JSON data structure *) + type 'a encoder = 'a to_json [@@deprecated "Use `to_json` instead"] - type 'a encoder = 'a -> Js.Json.t - (** The type of a encoder combinator *) + external null : t = "null" [@@deprecated "Use `Js.Json.null` instead"] - external null : Js.Json.t = "null" + val string : string to_json + [@@deprecated "Use `To_json.string` instead"] - (** [null] is the singleton null JSON value *) + val float : float to_json [@@deprecated "Use `To_json.float` instead"] + val int : int to_json [@@deprecated "Use `To_json.int` instead"] + val bool : bool to_json [@@deprecated "Use `To_json.bool` instead"] + val char : char to_json [@@deprecated "Use `To_json.char instead"] - external string : string -> Js.Json.t = "%identity" - (** [string s] makes a JSON string of the [string] [s] *) + val date : Js.Date.t to_json + [@@deprecated "Use `To_json.js_date` instead"] - external float : float -> Js.Json.t = "%identity" - (** [float n] makes a JSON number of the [float] [n] *) + val nullable : 'a to_json -> 'a option to_json + [@@deprecated "Use `To_json.option instead"] - external int : int -> Js.Json.t = "%identity" - (** [int n] makes a JSON number of the [int] [n] *) + val withDefault : Js.Json.t -> 'a to_json -> 'a option -> Js.Json.t + [@@deprecated "Use `To_json.option` instead"] - external bool : bool -> Js.Json.t = "%identity" - (** [bool b] makes a JSON boolean of the [bool] [b] *) + val pair : 'a to_json -> 'b to_json -> ('a * 'b) to_json + [@@deprecated "Use `To_json.tuple2` instead"] - val char : char -> Js.Json.t - (** [char c] makes a JSON string of the [char] [c] *) - - val date : Js.Date.t -> Js.Json.t - (** [date d] makes an ISO 8601 JSON string of the [Js.Date.t] [d] *) - - val nullable : 'a encoder -> 'a option -> Js.Json.t - (** [nullable encoder option] returns either the encoded value or [null] - *) - - val withDefault : Js.Json.t -> 'a encoder -> 'a option -> Js.Json.t - (** [withDefault default encoder option] returns the encoded value if - present, oterwise [default] *) - - val pair : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t - (** [pair encoder encoder tuple] creates a JSON array from a tuple of - size 2 *) - - val tuple2 : 'a encoder -> 'b encoder -> 'a * 'b -> Js.Json.t - (** [tuple2 encoder encoder tuple] creates a JSON array from a tuple of - size 2. Alias of [pair] *) + val tuple2 : 'a to_json -> 'b to_json -> ('a * 'b) to_json + [@@deprecated "Use `To_json.tuple2` instead"] val tuple3 : - 'a encoder -> 'b encoder -> 'c encoder -> 'a * 'b * 'c -> Js.Json.t - (** [tuple3 enc enc enc tuple] creates a JSON array from a tuple of size - 3 *) + 'a to_json -> 'b to_json -> 'c to_json -> ('a * 'b * 'c) to_json + [@@deprecated "Use `To_json.tuple3` instead"] val tuple4 : - 'a encoder -> - 'b encoder -> - 'c encoder -> - 'd encoder -> - 'a * 'b * 'c * 'd -> - Js.Json.t - (** [tuple4 enc enc enc enc tuple] creates a JSON array from a tuple of - size 4 *) - - external jsonDict : Js.Json.t Js.Dict.t -> Js.Json.t = "%identity" - (** [jsonDict d] makes a JSON object of the [Js.Dict.t] [d] *) - - val dict : 'a encoder -> 'a Js.Dict.t encoder - (** [dict encoder d] makes a JSON object of the [Js.Dict.t] [d] with the - given [encoder] *) + 'a to_json -> + 'b to_json -> + 'c to_json -> + 'd to_json -> + ('a * 'b * 'c * 'd) to_json + [@@deprecated "Use `To_json.tuple4` instead"] + + val dict : 'a to_json -> 'a Js.Dict.t to_json + [@@deprecated "Use `To_json.js_dict` instead"] val object_ : (string * Js.Json.t) list -> Js.Json.t - (** [object_ props] makes a JSON object of the [props] list of - properties *) + [@@deprecated "Use 'To_json.json_dict (Js.Dict.fromList x)' instead"] - val array : 'a encoder -> 'a array encoder - (** [array encoder l] makes a JSON array of the [list] [l] using the - given [encoder] * NOTE: This will be renamed `array` once the - existing and deprecated `array` function * has been removed. *) + val array : 'a to_json -> 'a array to_json + [@@deprecated "Use `To_json.array` instead"] - val list : 'a encoder -> 'a list encoder - (** [list encoder a] makes a JSON array of the [array] [a] using the - given [encoder] *) + val list : 'a to_json -> 'a list to_json + [@@deprecated "Use `To_json.list` instead"] - (** The functions below are specialized for specific array type which - happened to be already JSON object in the BuckleScript runtime. - Therefore they are more efficient (constant time rather than linear - conversion). *) + val jsonDict : t Js.Dict.t to_json + [@@deprecated "Use `To_json.json_dict` instead"] - external jsonArray : Js.Json.t array -> Js.Json.t = "%identity" - (** [jsonArray a] makes a JSON array of the [Js.Json.t array] [a] *) + val jsonArray : t array to_json + [@@deprecated "Use `To_json.json_array` instead"] - external stringArray : string array -> Js.Json.t = "%identity" - (** [stringArray a] makes a JSON array of the [string array] [a] *) + val stringArray : string array to_json + [@@deprecated "Use `To_json.string_array` instead"] - external numberArray : float array -> Js.Json.t = "%identity" - (** [numberArray a] makes a JSON array of the [float array] [a] *) + val numberArray : float array to_json + [@@deprecated "Use `To_json.number_array` instead"] - external boolArray : bool array -> Js.Json.t = "%identity" - (** [boolArray] makes a JSON array of the [bool array] [a] *) + val boolArray : bool array to_json + [@@deprecated "Use `To_json.bool_array` instead"] end +[@@deprecated "Use `To_json` instead"] -exception ParseError of string - -val parse : string -> Js.Json.t option -(** [parse s] returns [Some json] if s is a valid json string, [None] - otherwise *) - -val parseOrRaise : string -> Js.Json.t -(** [parse s] returns a [Js.Json.t] if s is a valid json string, raises - [ParseError] otherwise *) +type exn += ParseError of string + [@@deprecated "Use `Of_string_error` instead"] -val stringify : Js.Json.t -> string -(** [stringify json] returns the [string] representation of the given - [Js.Json.t] value *) +val parse : string -> json option [@@deprecated "Use `of_string` instead"] +val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] +val stringify : json -> string [@@deprecated "Use `to_string` instead"] From b1456882ce7aede7bd1970fff6fc66983736a429 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Mon, 16 Dec 2024 07:33:37 +0100 Subject: [PATCH 05/20] unify: fix tests (#46) --- README.md | 2 +- examples/complex.ml | 1 + examples/decode.ml | 6 +- examples/dynamicDict_Ocaml.ml | 2 + examples/dynamicDict_Reason.re | 2 + examples/encode.ml | 1 + examples/parse.ml | 2 + examples/tree.ml | 1 + ppx/browser/ppx_deriving_json_runtime.ml | 95 ++++------------ ppx/native/ppx_deriving_json_runtime.ml | 3 +- src/Json.ml | 107 ++++++++++++------ src/Json.mli | 4 +- src/__tests__/Json_decode_test.ml | 137 +++++++++++++---------- src/__tests__/Json_encode_test.ml | 1 + src/__tests__/Json_test.ml | 1 + 15 files changed, 194 insertions(+), 171 deletions(-) diff --git a/README.md b/README.md index ae146ff..6c781b0 100644 --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ Based on [@glennsl/bs-json](https://github.com/glennsl/bs-json). The Decode module in particular provides a basic set of decoder functions to be composed into more complex decoders. A decoder is a function that takes a `Js.Json.t` and either returns a value of the desired type if successful or -raises a `DecodeError` exception if not. Other functions accept a decoder and +raises an `Of_json_error` exception if not. Other functions accept a decoder and produce another decoder. Like `array`, which when given a decoder for type `t` will return a decoder that tries to produce a value of type `t array`. So to decode an `int array` you combine `Json.Decode.int` with `Json.Decode.array` diff --git a/examples/complex.ml b/examples/complex.ml index 2b7a2fb..5f7452e 100644 --- a/examples/complex.ml +++ b/examples/complex.ml @@ -1,3 +1,4 @@ +[@@@alert "-deprecated"] type line = { start : point; end_ : point; thickness : int option } and point = { x : int; y : int } diff --git a/examples/decode.ml b/examples/decode.ml index 250c9b0..2c13eb5 100644 --- a/examples/decode.ml +++ b/examples/decode.ml @@ -1,3 +1,5 @@ +[@@@alert "-deprecated"] + (* Decoding a fixed JSON data structure using Json.Decode *) let mapJsonObjectString f decoder (encoder : int -> Js.Json.t) str = let json = Json.parseOrRaise str in @@ -26,5 +28,5 @@ let _ = let json = {|{ "y": 42 } |} |> Json.parseOrRaise in match Json.Decode.(field "x" int json) with | x -> Js.log x - | exception Json.Decode.DecodeError err -> - Js.log ("Error:" ^ Json.Decode.error_to_string err) + | exception Json.Of_json_error err -> + Js.log ("Error:" ^ Json.of_json_error_to_string err) diff --git a/examples/dynamicDict_Ocaml.ml b/examples/dynamicDict_Ocaml.ml index a80050d..10a2f7c 100644 --- a/examples/dynamicDict_Ocaml.ml +++ b/examples/dynamicDict_Ocaml.ml @@ -1,3 +1,5 @@ +[@@@alert "-deprecated"] + (* Handling an object with dynamic keys for sub-objects. example: diff --git a/examples/dynamicDict_Reason.re b/examples/dynamicDict_Reason.re index be3e76c..b341ea7 100644 --- a/examples/dynamicDict_Reason.re +++ b/examples/dynamicDict_Reason.re @@ -1,3 +1,5 @@ +[@alert "-deprecated"]; + /* Handling an object with dynamic keys for sub-objects. example: diff --git a/examples/encode.ml b/examples/encode.ml index 7ef86b8..f8ebd3a 100644 --- a/examples/encode.ml +++ b/examples/encode.ml @@ -1,3 +1,4 @@ +[@@@alert "-deprecated"] (* Encoding a JSON data structure using Json.Encode *) (* prints ["foo", "bar"] *) diff --git a/examples/parse.ml b/examples/parse.ml index 8582c14..0eb6d8e 100644 --- a/examples/parse.ml +++ b/examples/parse.ml @@ -1,3 +1,5 @@ +[@@@alert "-deprecated"] + (* Parsing a JSON string using Json.parseOrRaise *) let arrayOfInts str = diff --git a/examples/tree.ml b/examples/tree.ml index e46b19e..5a6d054 100644 --- a/examples/tree.ml +++ b/examples/tree.ml @@ -1,3 +1,4 @@ +[@@@alert "-deprecated"] (* Decode a JSON tree structure *) type 'a tree = Node of 'a * 'a tree list | Leaf of 'a diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml index 56241ce..0d5ece2 100644 --- a/ppx/browser/ppx_deriving_json_runtime.ml +++ b/ppx/browser/ppx_deriving_json_runtime.ml @@ -1,11 +1,11 @@ +[@@@alert "-deprecated"] + type t = Js.Json.t let to_json t = t let of_json t = t let to_string t = Js.Json.stringify t -exception Of_string_error of string - let of_string s = try Js.Json.parseExn s with exn -> @@ -18,13 +18,13 @@ let of_string s = (* msg really cannot be None in browser or any sane JS runtime *) Option.value msg ~default:"JSON error" in - raise (Of_string_error msg) + raise (Json.Of_string_error msg) -type error = Json.Decode.error = +type error = Json.of_json_error = | Json_error of string | Unexpected_variant of string -exception Of_json_error = Json.Decode.DecodeError +exception Of_json_error = Json.Of_json_error let of_json_error msg = raise (Of_json_error (Json_error msg)) @@ -60,75 +60,16 @@ module To_json = struct end module Of_json = struct - let string_of_json (json : t) : string = - if Js.typeof json = "string" then (Obj.magic json : string) - else of_json_error "expected a string" - - let bool_of_json (json : t) : bool = - if Js.typeof json = "boolean" then (Obj.magic json : bool) - else of_json_error "expected a boolean" - - let is_int value = - Js.Float.isFinite value && Js.Math.floor_float value == value - - let int_of_json (json : t) : int = - if Js.typeof json = "number" then - let v = (Obj.magic json : float) in - if is_int v then (Obj.magic v : int) - else of_json_error "expected an integer" - else of_json_error "expected an integer" - - let int64_of_json (json : t) : int64 = - if Js.typeof json = "string" then - let v = (Obj.magic json : string) in - match Int64.of_string_opt v with - | Some v -> v - | None -> of_json_error "expected int64 as string" - else of_json_error "expected int64 as string" - - let float_of_json (json : t) : float = - if Js.typeof json = "number" then (Obj.magic json : float) - else of_json_error "expected a float" - - let unit_of_json (json : t) = - if (Obj.magic json : 'a Js.null) == Js.null then () - else of_json_error "expected null" - - let array_of_json v_of_json (json : t) = - if Js.Array.isArray json then - let json = (Obj.magic json : Js.Json.t array) in - Js.Array.map ~f:v_of_json json - else of_json_error "expected a JSON array" - - let list_of_json v_of_json (json : t) = - array_of_json v_of_json json |> Array.to_list - - let option_of_json v_of_json (json : t) = - if (Obj.magic json : 'a Js.null) == Js.null then None - else Some (v_of_json json) - - let result_of_json ok_of_json err_of_json (json : t) = - if Js.Array.isArray json then - let array = (Obj.magic json : Js.Json.t array) in - let len = Js.Array.length array in - if Stdlib.( > ) len 0 then - let tag = Js.Array.unsafe_get array 0 in - if Stdlib.( = ) (Js.typeof tag) "string" then - let tag = (Obj.magic tag : string) in - if Stdlib.( = ) tag "Ok" then ( - if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; - Ok (ok_of_json (Js.Array.unsafe_get array 1))) - else if Stdlib.( = ) tag "Error" then ( - if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; - Error (err_of_json (Js.Array.unsafe_get array 1))) - else of_json_error "invalid JSON" - else - of_json_error - "expected a non empty JSON array with element being a string" - else of_json_error "expected a non empty JSON array" - else of_json_error "expected a non empty JSON array" + let string_of_json = Json.Of_json.string + let bool_of_json = Json.Of_json.bool + let int_of_json = Json.Of_json.int + let int64_of_json = Json.Of_json.int64 + let float_of_json = Json.Of_json.float + let unit_of_json = Json.Of_json.unit + let array_of_json = Json.Of_json.array + let list_of_json = Json.Of_json.list + let option_of_json = Json.Of_json.option + let result_of_json = Json.Of_json.result end module Primitives = struct @@ -137,6 +78,10 @@ module Primitives = struct end module Classify = struct + (* This function is also defined in `Json` module, but not exposed on its mli *) + let is_int value = + Js.Float.isFinite value && Js.Math.floor_float value == value + let classify : t -> [ `Null @@ -153,7 +98,7 @@ module Classify = struct | "string" -> `String (Obj.magic json : string) | "number" -> let v = (Obj.magic json : float) in - if Of_json.is_int v then `Int (Obj.magic v : int) else `Float v + if is_int v then `Int (Obj.magic v : int) else `Float v | "boolean" -> `Bool (Obj.magic json : bool) | "object" -> if Js.Array.isArray json then diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/ppx/native/ppx_deriving_json_runtime.ml index f043e9b..1d3b146 100644 --- a/ppx/native/ppx_deriving_json_runtime.ml +++ b/ppx/native/ppx_deriving_json_runtime.ml @@ -26,8 +26,7 @@ let show_json_type = function | `String _ -> "string" let of_json_error_type_mismatch json expected = - of_json_error - ("expected " ^ expected ^ " but got " ^ show_json_type json) + of_json_error ("Expected " ^ expected ^ ", got " ^ show_json_type json) module To_json = struct let string_to_json v = `String v diff --git a/src/Json.ml b/src/Json.ml index a1599b8..b156a86 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -19,6 +19,9 @@ let to_string t = Js.Json.stringify t exception Of_string_error of string +external _unsafeCreateUninitializedArray : int -> 'a array = "Array" +[@@mel.new] + let of_string s = try Js.Json.parseExn s with exn -> @@ -34,22 +37,23 @@ let of_string s = raise (Of_string_error msg) module Of_json = struct - external _stringify : Js.Json.t -> string = "JSON.stringify" - let string (json : t) : string = if Js.typeof json = "string" then (Obj.magic json : string) - else of_json_error "expected a string" + else of_json_error ("Expected string, got " ^ Js.Json.stringify json) let char (json : t) = if Js.typeof json = "string" then let s = (Obj.magic json : string) in if String.length s = 1 then String.get s 0 - else of_json_error "expected a single-character string" - else of_json_error "expected a string" + else + of_json_error + ("Expected single-character string, got " + ^ Js.Json.stringify json) + else of_json_error ("Expected string, got " ^ Js.Json.stringify json) let bool (json : t) : bool = if Js.typeof json = "boolean" then (Obj.magic json : bool) - else of_json_error "expected a boolean" + else of_json_error ("Expected boolean, got " ^ Js.Json.stringify json) let is_int value = Js.Float.isFinite value && Js.Math.floor_float value == value @@ -58,30 +62,48 @@ module Of_json = struct if Js.typeof json = "number" then let v = (Obj.magic json : float) in if is_int v then (Obj.magic v : int) - else of_json_error "expected an integer" - else of_json_error "expected an integer" + else + of_json_error ("Expected integer, got " ^ Js.Json.stringify json) + else of_json_error ("Expected number, got " ^ Js.Json.stringify json) let int64 (json : t) : int64 = if Js.typeof json = "string" then let v = (Obj.magic json : string) in match Int64.of_string_opt v with | Some v -> v - | None -> of_json_error "expected int64 as string" - else of_json_error "expected int64 as string" + | None -> + of_json_error + ("Expected int64 as string, got " ^ Js.Json.stringify json) + else + of_json_error + ("Expected int64 as string, got " ^ Js.Json.stringify json) let float (json : t) : float = if Js.typeof json = "number" then (Obj.magic json : float) - else of_json_error "expected a float" + else of_json_error ("Expected number, got " ^ Js.Json.stringify json) let unit (json : t) : unit = if (Obj.magic json : 'a Js.null) == Js.null then () - else of_json_error "expected null" + else + of_json_error + ("Expected null as unit, got " ^ Js.Json.stringify json) - let array v_of_json (json : t) : _ array = - if Js.Array.isArray json then - let json = (Obj.magic json : Js.Json.t array) in - Js.Array.map ~f:v_of_json json - else of_json_error "expected a JSON array" + let array v_of_json (json : t) = + if Js.Array.isArray json then ( + let source = (Obj.magic (json : Js.Json.t) : Js.Json.t array) in + let length = Js.Array.length source in + let target = _unsafeCreateUninitializedArray length in + for i = 0 to length - 1 do + let value = + try v_of_json (Array.unsafe_get source i) + with Of_json_error (Json_error err) -> + of_json_error + (err ^ "\n\tin array at index " ^ string_of_int i) + in + Array.unsafe_set target i value + done; + target) + else of_json_error ("Expected array, got " ^ Js.Json.stringify json) let list v_of_json (json : t) : _ list = array v_of_json json |> Array.to_list @@ -110,8 +132,10 @@ module Of_json = struct else let length = Js.String.make length in of_json_error - {j|Expected array of length 2, got array of length $length|j} - else of_json_error ("Expected array, got " ^ _stringify json) + {j|Expected array of length 2 as tuple, got array of length $length|j} + else + of_json_error + ("Expected array as tuple, got " ^ Js.Json.stringify json) let tuple3 decodeA decodeB decodeC json : _ * _ * _ = if Js.Array.isArray json then @@ -127,8 +151,10 @@ module Of_json = struct else let length = Js.String.make length in of_json_error - {j|Expected array of length 3, got array of length $length|j} - else of_json_error ("Expected array, got " ^ _stringify json) + {j|Expected array of length 3 as tuple, got array of length $length|j} + else + of_json_error + ("Expected array as tuple, got " ^ Js.Json.stringify json) let tuple4 decodeA decodeB decodeC decodeD json : _ * _ * _ * _ = if Js.Array.isArray json then @@ -145,8 +171,10 @@ module Of_json = struct else let length = Js.String.make length in of_json_error - {j|Expected array of length 4, got array of length $length|j} - else of_json_error ("Expected array, got " ^ _stringify json) + {j|Expected array of length 4 as tuple, got array of length $length|j} + else + of_json_error + ("Expected array as tuple, got " ^ Js.Json.stringify json) let js_dict decode json : _ Js.Dict.t = if @@ -163,12 +191,18 @@ module Of_json = struct let value = try decode (Js.Dict.unsafeGet source key) with Of_json_error err -> - of_json_error (of_json_error_to_string err ^ "\n\tin dict") + of_json_error + (of_json_error_to_string err + ^ "\n\tin object at key '" + ^ key + ^ "'") in Js.Dict.set target key value done; target) - else of_json_error ("Expected object, got " ^ _stringify json) + else + of_json_error + ("Expected object as dict, got " ^ Js.Json.stringify json) let result ok_of_json err_of_json (json : t) : (_, _) result = if Js.Array.isArray json then @@ -180,18 +214,27 @@ module Of_json = struct let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "Ok" then ( if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; + of_json_error + ("Expected array of length 2 as result 'Ok', got " + ^ Js.Json.stringify json); Ok (ok_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "Error" then ( if Stdlib.( <> ) len 2 then - of_json_error "expected a JSON array of length 2"; + of_json_error + ("Expected array of length 2 as result 'Error', got " + ^ Js.Json.stringify json); Error (err_of_json (Js.Array.unsafe_get array 1))) else of_json_error "invalid JSON" else of_json_error - "expected a non empty JSON array with element being a string" - else of_json_error "expected a non empty JSON array" - else of_json_error "expected a non empty JSON array" + ("Expected non-empty array with element being a string, got " + ^ Js.Json.stringify json) + else + of_json_error + ("Expected non-empty array, got " ^ Js.Json.stringify json) + else + of_json_error + ("Expected a non-empty array, got " ^ Js.Json.stringify json) let at' key decode json = if @@ -208,7 +251,7 @@ module Of_json = struct (of_json_error_to_string err ^ "\n\tat field '" ^ key ^ "'") ) | None -> of_json_error {j|Expected field '$(key)'|j} - else of_json_error ("Expected object, got " ^ _stringify json) + else of_json_error ("Expected object, got " ^ Js.Json.stringify json) let rec at key_path decoder = match key_path with @@ -229,7 +272,7 @@ module Of_json = struct in of_json_error ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} - ^ _stringify json) + ^ Js.Json.stringify json) | decode :: rest -> ( try decode json with Of_json_error e -> inner rest (e :: errors)) diff --git a/src/Json.mli b/src/Json.mli index b77fc9f..a0c013b 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -126,6 +126,8 @@ val to_json : json to_json (** The type of a error which occurs during decoding JSON values. *) type of_json_error = Json_error of string | Unexpected_variant of string +val of_json_error_to_string : of_json_error -> string + type exn += | Of_json_error of of_json_error (** The exception raised when a decoding error occurs *) @@ -139,7 +141,7 @@ val of_json : json of_json module Of_json : sig (** Provides a set of low level combinator primitives to decode Js.Json.t data structures A decoder combinator will return the - decoded value if successful, or raise a [DecodeError of string] if + decoded value if successful, or raise a [Of_json_error] exception if unsuccessful, where the string argument contains the error message. Decoders are designed to be combined to produce more complex decoders that can decode arbitrary data structures, though the diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 19bccda..268ddb4 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -1,3 +1,5 @@ +[@@@alert "-deprecated"] + open Jest open Expect @@ -31,7 +33,7 @@ module Test = struct try let _ = decoder value in fail "should throw" - with Json.Decode.DecodeError _ -> pass) + with Json.Of_json_error _ -> pass) end let () = @@ -76,8 +78,7 @@ let () = let (_ : int) = int (Encode.int inf) in fail "should throw" with - | Decode.DecodeError (Json_error "Expected integer, got null") - -> + | Of_json_error (Json_error "Expected integer, got null") -> pass); Test.throws int [ Bool; Float; String; Null; Array; Object; Char ]); @@ -116,7 +117,7 @@ let () = let (_ : char) = char (Encode.string "") in fail "should throw" with - | Decode.DecodeError + | Of_json_error (Json_error "Expected single-character string, got \"\"") -> pass); @@ -126,7 +127,7 @@ let () = let (_ : char) = char (Encode.string "abc") in fail "should throw" with - | Decode.DecodeError + | Of_json_error (Json_error "Expected single-character string, got \"abc\"") -> pass); @@ -206,11 +207,11 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected boolean, got 1\n\tin array at index 0") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : _ array) = @@ -253,11 +254,11 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected boolean, got 1\n\tin array at index 0") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : 'a list) = @@ -285,9 +286,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 2, got array of length 1") + "Expected array of length 2 as tuple, got array of \ + length 1") -> pass); test "too large" (fun () -> @@ -297,9 +299,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 2, got array of length 3") + "Expected array of length 2 as tuple, got array of \ + length 3") -> pass); test "bad type a" (fun () -> @@ -309,7 +312,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected number, got \"3\"\n\tin pair/tuple2") -> pass); @@ -320,7 +323,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected string, got 4\n\tin pair/tuple2") -> pass); @@ -328,8 +331,10 @@ let () = try let (_ : int * int) = (pair int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError (Json_error "Expected array, got 4") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + with + | Of_json_error (Json_error "Expected array as tuple, got 4") -> + pass); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : int * int) = @@ -351,9 +356,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 2, got array of length 1") + "Expected array of length 2 as tuple, got array of \ + length 1") -> pass); test "too large" (fun () -> @@ -363,9 +369,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 2, got array of length 3") + "Expected array of length 2 as tuple, got array of \ + length 3") -> pass); test "bad type a" (fun () -> @@ -375,7 +382,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected number, got \"3\"\n\tin pair/tuple2") -> pass); @@ -386,7 +393,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected string, got 4\n\tin pair/tuple2") -> pass); @@ -396,8 +403,10 @@ let () = (tuple2 int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError (Json_error "Expected array, got 4") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + with + | Of_json_error (Json_error "Expected array as tuple, got 4") -> + pass); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : 'a * int) = @@ -421,9 +430,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 3, got array of length 1") + "Expected array of length 3 as tuple, got array of \ + length 1") -> pass); test "too large" (fun () -> @@ -433,9 +443,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 3, got array of length 5") + "Expected array of length 3 as tuple, got array of \ + length 5") -> pass); test "bad type a" (fun () -> @@ -445,7 +456,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected number, got \"3\"\n\tin tuple3") -> pass); @@ -457,7 +468,8 @@ let () = in fail "should throw" with - | DecodeError (Json_error "Expected string, got 4\n\tin tuple3") + | Of_json_error + (Json_error "Expected string, got 4\n\tin tuple3") -> pass); test "not array" (fun () -> @@ -466,8 +478,10 @@ let () = (tuple3 int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError (Json_error "Expected array, got 4") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + with + | Of_json_error (Json_error "Expected array as tuple, got 4") -> + pass); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : int * int * int) = @@ -492,9 +506,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 4, got array of length 1") + "Expected array of length 4 as tuple, got array of \ + length 1") -> pass); test "too large" (fun () -> @@ -505,9 +520,10 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected array of length 4, got array of length 6") + "Expected array of length 4 as tuple, got array of \ + length 6") -> pass); test "bad type a" (fun () -> @@ -517,7 +533,7 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected number, got \"3\"\n\tin tuple4") -> pass); @@ -529,7 +545,8 @@ let () = in fail "should throw" with - | DecodeError (Json_error "Expected string, got 4\n\tin tuple4") + | Of_json_error + (Json_error "Expected string, got 4\n\tin tuple4") -> pass); test "not array" (fun () -> @@ -538,8 +555,10 @@ let () = (tuple4 int int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError (Json_error "Expected array, got 4") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + with + | Of_json_error (Json_error "Expected array as tuple, got 4") -> + pass); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : int * int * int * int) = @@ -582,11 +601,12 @@ let () = in fail "should throw" with - | DecodeError - (Json_error "Expected string, got null\n\tin dict") + | Of_json_error + (Json_error + "Expected string, got null\n\tin object at key 'a'") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : _ Js.Dict.t) = @@ -628,7 +648,7 @@ let () = (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError (Json_error "Expected field 'c'") -> pass); + with Of_json_error (Json_error "Expected field 'c'") -> pass); test "decoder error" (fun () -> try let (_ : string) = @@ -637,12 +657,12 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected string, got null\n\tat field 'b'") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let _ = @@ -689,7 +709,8 @@ let () = in fail "should throw" with - | DecodeError (Json_error "Expected field 'y'\n\tat field 'a'") + | Of_json_error + (Json_error "Expected field 'y'\n\tat field 'a'") -> pass); test "decoder error" (fun () -> @@ -704,9 +725,9 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error - "Expected null, got \"foo\"\n\ + "Expected null\n\ \tat field 'y'\n\ \tat field 'x'\n\ \tat field 'a'") @@ -785,9 +806,9 @@ let () = (field "y" (optional int)) (parseOrRaise {| { "x": 2} |}) in fail "should throw" - with DecodeError (Json_error "Expected field 'y'") -> pass); + with Of_json_error (Json_error "Expected field 'y'") -> pass); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : 'a option) = @@ -807,7 +828,7 @@ let () = expect @@ (oneOf [ int; field "x" int ]) (Encode.int 23) |> toEqual 23); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let _ = (oneOf [ (fun _ -> raise Foo) ]) Encode.null in @@ -853,7 +874,7 @@ let () = test "object" (fun () -> expect @@ (withDefault 0 int) (Encode.object_ []) |> toEqual 0); - test "non-DecodeError exceptions in decoder should pass through" + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try let (_ : int) = @@ -921,12 +942,12 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected number, got true\n\ \tin array at index 0\n\ \tin array at index 1\n\ - \tin dict") + \tin object at key 'a'") -> pass); test "dict array array int - heterogenous structure 2" (fun () -> @@ -938,11 +959,11 @@ let () = in fail "should throw" with - | DecodeError + | Of_json_error (Json_error "Expected array, got \"foo\"\n\ \tin array at index 1\n\ - \tin dict") + \tin object at key 'a'") -> pass); test "field" (fun () -> diff --git a/src/__tests__/Json_encode_test.ml b/src/__tests__/Json_encode_test.ml index 0eed75f..0db7b6a 100644 --- a/src/__tests__/Json_encode_test.ml +++ b/src/__tests__/Json_encode_test.ml @@ -1,3 +1,4 @@ +[@@@alert "-deprecated"] open Jest open Expect open! Json.Encode diff --git a/src/__tests__/Json_test.ml b/src/__tests__/Json_test.ml index 10199ce..852903f 100644 --- a/src/__tests__/Json_test.ml +++ b/src/__tests__/Json_test.ml @@ -1,3 +1,4 @@ +[@@@alert "-deprecated"] open Jest open Expect open Json From 9ecc0d4ff290c36780de60eab2eb10d870ce1b6b Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Mon, 16 Dec 2024 13:42:36 +0400 Subject: [PATCH 06/20] Remove ppx_deriving_json_runtime libs, use melange-json instead --- ppx/browser/dune | 12 +- ppx/browser/ppx_deriving_json_js.ml | 44 +- ppx/browser/ppx_deriving_json_runtime.ml | 111 ----- ppx/native/dune | 15 +- ppx/native/ppx_deriving_json_common.ml | 8 +- ppx/native/ppx_deriving_json_native.ml | 29 +- ppx/native/ppx_deriving_tools.ml | 24 +- ppx/test/example.ml | 6 +- ppx/test/example_json_string.ml | 2 +- ppx/test/poly.t | 274 ++++++------ ppx/test/ppx_deriving_json_js.e2e.t | 2 +- ppx/test/ppx_deriving_json_js.t | 420 ++++++++++-------- ppx/test/ppx_deriving_json_js_variants.e2e.t | 2 +- ppx/test/ppx_deriving_json_native.e2e.t | 2 +- ppx/test/ppx_deriving_json_native.t | 149 +++---- ppx/test/run.sh | 4 +- src/Json.ml | 27 ++ src/Json.mli | 11 + .../native/Json.ml | 119 +++-- src/native/dune | 4 + 20 files changed, 633 insertions(+), 632 deletions(-) delete mode 100644 ppx/browser/ppx_deriving_json_runtime.ml rename ppx/native/ppx_deriving_json_runtime.ml => src/native/Json.ml (51%) create mode 100644 src/native/dune diff --git a/ppx/browser/dune b/ppx/browser/dune index c6189e7..1779f11 100644 --- a/ppx/browser/dune +++ b/ppx/browser/dune @@ -1,21 +1,13 @@ (library (public_name melange-json.ppx) (name ppx_deriving_json_js) - (modules :standard \ ppx_deriving_json_runtime ppx_deriving_json_js_test) + (modules :standard \ ppx_deriving_json_js_test) (libraries ppxlib) - (ppx_runtime_libraries melange-json melange-json.ppx-runtime) + (ppx_runtime_libraries melange-json) (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) -(library - (public_name melange-json.ppx-runtime) - (name ppx_deriving_json_js_runtime) - (modules ppx_deriving_json_runtime) - (libraries melange-json) - (wrapped false) - (modes melange)) - (executable (name ppx_deriving_json_js_test) (modules ppx_deriving_json_js_test) diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 5afcb83..585712b 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -7,6 +7,13 @@ open Ppx_deriving_tools.Conv open Ppx_deriving_json_common module Of_json = struct + let of_json_error ~loc fmt = + ksprintf + (fun msg -> + let msg = estring ~loc msg in + [%expr raise (Json.Of_json_error (Json_error [%e msg]))]) + fmt + let build_tuple ~loc derive si (ts : core_type list) e = pexp_tuple ~loc (List.mapi ts ~f:(fun i t -> @@ -38,12 +45,7 @@ module Of_json = struct [%e match ld_attr_default ld with | Some default -> default - | None -> - [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "missing field %S" n.txt)]]]] - ) + | None -> of_json_error ~loc "missing field: %S" n.txt]] ) in [%expr let fs = (Obj.magic [%e x] : [%t build_js_type ~loc fs]) in @@ -65,15 +67,12 @@ module Of_json = struct let ensure_json_object ~loc x = [%expr if Stdlib.not [%e eis_json_object ~loc x] then - Ppx_deriving_json_runtime.of_json_error - [%e estring ~loc (sprintf "expected a JSON object")]] + [%e of_json_error ~loc "expected a JSON object"]] let ensure_json_array_len ~loc n len = [%expr if Stdlib.( <> ) [%e len] [%e eint ~loc n] then - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "expected a JSON array of length %i" n)]] + [%e of_json_error ~loc "expected a JSON array of length %i" n]] let derive_of_tuple derive t x = let loc = t.tpl_loc in @@ -88,10 +87,7 @@ module Of_json = struct then let es = (Obj.magic [%e x] : Js.Json.t array) in [%e build_tuple ~loc derive 0 t.tpl_types [%expr es]] - else - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "expected a JSON array of length %i" n)]] + else [%e of_json_error ~loc "expected a JSON array of length %i" n]] let derive_of_record derive t x = let loc = t.rcd_loc in @@ -111,15 +107,12 @@ module Of_json = struct let tag = (Obj.magic tag : string) in [%e body] else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" - else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" - else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array"] + [%e + of_json_error ~loc + "expected a non empty JSON array with element being a \ + string"] + else [%e of_json_error ~loc "expected a non empty JSON array"] + else [%e of_json_error ~loc "expected a non empty JSON array"]] let derive_of_variant_case derive make c next = match c with @@ -152,8 +145,7 @@ module Of_json = struct let deriving : Ppx_deriving_tools.deriving = deriving_of () ~name:"of_json" - ~error:(fun ~loc -> - [%expr Ppx_deriving_json_runtime.of_json_error "invalid JSON"]) + ~error:(fun ~loc -> of_json_error ~loc "invalid JSON") ~of_t:(fun ~loc -> [%type: Js.Json.t]) ~derive_of_tuple ~derive_of_record ~derive_of_variant ~derive_of_variant_case diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml deleted file mode 100644 index 0d5ece2..0000000 --- a/ppx/browser/ppx_deriving_json_runtime.ml +++ /dev/null @@ -1,111 +0,0 @@ -[@@@alert "-deprecated"] - -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 = - 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 = - (* msg really cannot be None in browser or any sane JS runtime *) - Option.value msg ~default:"JSON error" - in - raise (Json.Of_string_error msg) - -type error = Json.of_json_error = - | Json_error of string - | Unexpected_variant of string - -exception Of_json_error = Json.Of_json_error - -let of_json_error msg = raise (Of_json_error (Json_error msg)) - -let unexpected_variant_error tag = - raise (Of_json_error (Unexpected_variant tag)) - -module To_json = struct - external string_to_json : string -> t = "%identity" - external bool_to_json : bool -> t = "%identity" - external int_to_json : int -> t = "%identity" - - let int64_to_json : int64 -> t = fun v -> Obj.magic (Int64.to_string v) - - external float_to_json : float -> t = "%identity" - - let unit_to_json () : t = Obj.magic Js.null - - let array_to_json v_to_json vs : t = - let vs : Js.Json.t array = Js.Array.map ~f:v_to_json vs in - Obj.magic vs - - let list_to_json v_to_json vs : t = - let vs = Array.of_list vs in - array_to_json v_to_json vs - - let option_to_json v_to_json v : t = - match v with None -> Obj.magic Js.null | Some v -> v_to_json v - - let result_to_json a_to_json b_to_json v : t = - match v with - | Ok x -> Obj.magic [| string_to_json "Ok"; a_to_json x |] - | Error x -> Obj.magic [| string_to_json "Error"; b_to_json x |] -end - -module Of_json = struct - let string_of_json = Json.Of_json.string - let bool_of_json = Json.Of_json.bool - let int_of_json = Json.Of_json.int - let int64_of_json = Json.Of_json.int64 - let float_of_json = Json.Of_json.float - let unit_of_json = Json.Of_json.unit - let array_of_json = Json.Of_json.array - let list_of_json = Json.Of_json.list - let option_of_json = Json.Of_json.option - let result_of_json = Json.Of_json.result -end - -module Primitives = struct - include Of_json - include To_json -end - -module Classify = struct - (* This function is also defined in `Json` module, but not exposed on its mli *) - let is_int value = - Js.Float.isFinite value && Js.Math.floor_float value == value - - let classify : - t -> - [ `Null - | `String of string - | `Float of float - | `Int of int - | `Bool of bool - | `List of t list - | `Assoc of (string * t) list ] = - fun json -> - if (Obj.magic json : 'a Js.null) == Js.null then `Null - else - match Js.typeof json with - | "string" -> `String (Obj.magic json : string) - | "number" -> - let v = (Obj.magic json : float) in - if is_int v then `Int (Obj.magic v : int) else `Float v - | "boolean" -> `Bool (Obj.magic json : bool) - | "object" -> - if Js.Array.isArray json then - let xs = Array.to_list (Obj.magic json : t array) in - `List xs - else - let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in - `Assoc (Array.to_list xs) - | typ -> failwith ("unknown JSON value type: " ^ typ) -end diff --git a/ppx/native/dune b/ppx/native/dune index 01c1a7b..18286fe 100644 --- a/ppx/native/dune +++ b/ppx/native/dune @@ -1,24 +1,13 @@ (library (public_name melange-json-native.ppx) (name ppx_deriving_json_native) - (modules - :standard - \ - ppx_deriving_json_runtime - ppx_deriving_json_native_test) + (modules :standard \ ppx_deriving_json_native_test) (libraries ppxlib) - (ppx_runtime_libraries melange-json-native.ppx-runtime yojson) + (ppx_runtime_libraries melange-json-native yojson) (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) -(library - (public_name melange-json-native.ppx-runtime) - (name ppx_deriving_json_native_runtime) - (wrapped false) - (modules ppx_deriving_json_runtime) - (libraries yojson)) - (executable (name ppx_deriving_json_native_test) (modules ppx_deriving_json_native_test) diff --git a/ppx/native/ppx_deriving_json_common.ml b/ppx/native/ppx_deriving_json_common.ml index f3524bd..0a528ff 100644 --- a/ppx/native/ppx_deriving_json_common.ml +++ b/ppx/native/ppx_deriving_json_common.ml @@ -119,9 +119,7 @@ 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)]) + [%expr fun _json -> [%e of_json] (Json.of_string _json)]) let register ~of_json () = Deriving.add "of_json_string" @@ -134,9 +132,7 @@ 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)]) + [%expr fun _data -> Json.to_string ([%e to_json] _data)]) let register ~to_json () = Deriving.add "to_json_string" diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index e1b8c43..2e6d98d 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -7,6 +7,13 @@ open Ppx_deriving_tools.Conv open Ppx_deriving_json_common module Of_json = struct + let of_json_error ~loc fmt = + ksprintf + (fun msg -> + let msg = estring ~loc msg in + [%expr raise (Json.Of_json_error (Json_error [%e msg]))]) + fmt + let with_refs ~loc prefix fs inner = let gen_name n = sprintf "%s_%s" prefix n in let gen_expr (n : label loc) = @@ -45,10 +52,7 @@ module Of_json = struct [%pat? name] --> if allow_extra_fields then [%expr ()] - else - [%expr - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)] + else of_json_error ~loc "unknown field: %s" "name" in let cases = List.fold_left (List.rev fs) ~init:[ fail_case ] @@ -80,11 +84,7 @@ module Of_json = struct match default with | Some default -> default | None -> - [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc:key.loc - (sprintf "missing field %S" key.txt)]]]] + of_json_error ~loc "missing field: %S" key.txt]] )) in pexp_record ~loc fields None @@ -108,11 +108,7 @@ module Of_json = struct [ xpatt --> build_tuple ~loc derive xexprs t.tpl_types; [%pat? _] - --> [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc - (sprintf "expected a JSON array of length %i" n)]]; + --> of_json_error ~loc "expected a JSON array of length %i" n; ] let derive_of_record derive t x = @@ -125,10 +121,7 @@ module Of_json = struct [%pat? `Assoc fs] --> build_record ~allow_extra_fields ~loc derive t.rcd_fields [%expr fs] Fun.id; - [%pat? _] - --> [%expr - Ppx_deriving_json_runtime.of_json_error - [%e estring ~loc (sprintf "expected a JSON object")]]; + [%pat? _] --> of_json_error ~loc "expected a JSON object"; ] let derive_of_variant_case derive make vcs = diff --git a/ppx/native/ppx_deriving_tools.ml b/ppx/native/ppx_deriving_tools.ml index 0649f46..2d56acc 100644 --- a/ppx/native/ppx_deriving_tools.ml +++ b/ppx/native/ppx_deriving_tools.ml @@ -436,9 +436,8 @@ module Conv = struct ~init: ( [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))], + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))], [] ) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in @@ -466,9 +465,8 @@ module Conv = struct match [%e maybe_e] with | e -> (e :> [%t t]) | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - _) -> + Json.Of_json_error (Json.Unexpected_variant _) + -> [%e next]] in next, cases) @@ -511,9 +509,8 @@ module Conv = struct [%pat? _] --> [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))]; + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))]; ] ~f:(fun next (c : constructor_declaration) -> let ctx = Vcs_ctx_variant c in @@ -565,9 +562,8 @@ module Conv = struct ~init: [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))] + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))] ~f:(fun next (n, ts) -> let maybe = self#derive_type_ref ~loc self#name n ts x @@ -577,9 +573,7 @@ module Conv = struct match [%e maybe] with | x -> (x :> [%t t]) | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) - -> + Json.Of_json_error (Json.Unexpected_variant _) -> [%e next]]) in let cases = diff --git a/ppx/test/example.ml b/ppx/test/example.ml index 17687dd..1b5f441 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -23,7 +23,7 @@ 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] type array_list = { a: int array; b: int list} [@@deriving json] -type json = Ppx_deriving_json_runtime.t +type json = Json.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); @@ -65,11 +65,11 @@ let of_json_cases = [ ] 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 json = Json.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 + let data' = Json.to_string json' in print_endline (Printf.sprintf "JSON REPRINT: %s" data') let test () = List.iter run' of_json_cases diff --git a/ppx/test/example_json_string.ml b/ppx/test/example_json_string.ml index b2ac29e..840c716 100644 --- a/ppx/test/example_json_string.ml +++ b/ppx/test/example_json_string.ml @@ -1,4 +1,4 @@ -open Ppx_deriving_json_runtime.Primitives +open Json.Primitives let print fmt = Printf.ksprintf print_endline fmt diff --git a/ppx/test/poly.t b/ppx/test/poly.t index 7944a84..cff0717 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -2,8 +2,8 @@ We can alias poly varaints: $ echo ' > type t = [`A | `B] [@@deriving json] > type u = t [@@deriving json] - > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -18,9 +18,10 @@ We can alias poly varaints: | `List ((`String "B")::[]) -> `B | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) : Yojson.Basic.t -> t) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -40,9 +41,8 @@ We can alias poly varaints: let rec u_to_json = (fun x -> to_json x : u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -65,31 +65,38 @@ We can alias poly varaints: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `A) else if Stdlib.(=) tag "B" then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `B) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being a string"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array") + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" : Js.Json.t -> t) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -111,9 +118,8 @@ We can alias poly varaints: let rec u_to_json = (fun x -> to_json x : u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) === stdout:native === ["A"] === stdout:js === @@ -123,10 +129,10 @@ We can extend aliased polyvariants: $ echo ' > type t = [`A | `B] [@@deriving json] > type u = [t | `C] [@@deriving json] - > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) - > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|}) = `C) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = print_endline (Json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -141,9 +147,10 @@ We can extend aliased polyvariants: | `List ((`String "B")::[]) -> `B | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) : Yojson.Basic.t -> t) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -164,12 +171,11 @@ We can extend aliased polyvariants: | x -> (match of_json x with | x -> (x :> [ | t | `C ]) - | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) : Yojson.Basic.t -> u) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : + Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -178,12 +184,10 @@ We can extend aliased polyvariants: u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -206,31 +210,38 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `A) else if Stdlib.(=) tag "B" then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `B) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being a string"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array") + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" : Js.Json.t -> t) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -260,29 +271,36 @@ We can extend aliased polyvariants: let tag = (Obj.magic tag : string) in match of_json x with | e -> (e :> [ | t | `C ]) - | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) + -> (if Stdlib.(=) tag "C" then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error + "expected a JSON array of length 1")); `C) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being a string"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array") + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" : Js.Json.t -> u) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -293,12 +311,10 @@ We can extend aliased polyvariants: u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] @@ -314,10 +330,10 @@ We can extend poly variants which are placed behind signatures: > type t = [`A | `B] [@@deriving json] > end > type u = [P.t | `C] [@@deriving json] - > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) - > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|}) = `C) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = print_endline (Json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === module P : @@ -343,9 +359,9 @@ We can extend poly variants which are placed behind signatures: | `List ((`String "B")::[]) -> `B | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) : Yojson.Basic.t -> t) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : + Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -368,12 +384,11 @@ We can extend poly variants which are placed behind signatures: | x -> (match P.of_json x with | x -> (x :> [ | P.t | `C ]) - | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) : Yojson.Basic.t -> u) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : + Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -382,12 +397,10 @@ We can extend poly variants which are placed behind signatures: u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === ppx output:browser === module P : sig @@ -421,31 +434,39 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error + "expected a JSON array of length 1")); `A) else if Stdlib.(=) tag "B" then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error + "expected a JSON array of length 1")); `B) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being a string"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array") + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" : Js.Json.t -> t) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : + Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -476,29 +497,36 @@ We can extend poly variants which are placed behind signatures: let tag = (Obj.magic tag : string) in match P.of_json x with | e -> (e :> [ | P.t | `C ]) - | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) + -> (if Stdlib.(=) tag "C" then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error + "expected a JSON array of length 1")); `C) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being a string"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array") + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" : Js.Json.t -> u) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -509,12 +537,10 @@ We can extend poly variants which are placed behind signatures: u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) - let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) - let () = - assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index dbf65be..c803faf 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -7,7 +7,7 @@ > (name lib) > (modes melange) > (modules example example_json_string main) - > (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + > (flags :standard -w -37-69 -open Json.Primitives) > (preprocess (pps melange.ppx melange-json.ppx))) > (melange.emit > (alias js) diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index e51689f..89c5807 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -135,8 +135,9 @@ ( int_of_json (Js.Array.unsafe_get es 0), string_of_json (Js.Array.unsafe_get es 1) ) else - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2" + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")) : Js.Json.t -> tuple) let _ = tuple_of_json @@ -175,7 +176,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < name : Js.Json.t Js.undefined @@ -187,14 +188,15 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); age = (match Js.Undefined.toOption fs##age with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"age\""); + raise + (Json.Of_json_error (Json_error "missing field: \"age\""))); } : Js.Json.t -> record) @@ -240,7 +242,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < my_name : Js.Json.t Js.undefined @@ -252,8 +254,9 @@ (match Js.Undefined.toOption fs##my_name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"my_name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"my_name\""))); age = (match Js.Undefined.toOption fs##my_age with | Stdlib.Option.Some v -> int_of_json v @@ -302,7 +305,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < k : Js.Json.t Js.undefined > Js.t) in { k = @@ -348,18 +351,21 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); B (int_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); let fs = Js.Array.unsafe_get array 1 in if Stdlib.not @@ -372,8 +378,9 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object"; + raise + (Json.Of_json_error + (Json_error "expected a JSON object")); let fs = (Obj.magic fs : < name : Js.Json.t Js.undefined > Js.t) in @@ -383,20 +390,25 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> sum) let _ = sum_of_json @@ -444,22 +456,27 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "S2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 3"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 3")); S2 ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) )) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> sum2) let _ = sum2_of_json @@ -503,24 +520,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `C) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> other) let _ = other_of_json @@ -554,34 +575,38 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `B (int_of_json (Js.Array.unsafe_get array 1))) else match other_of_json x with | e -> (e :> [ `A | `B of int | other ]) - | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) + -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> poly) let _ = poly_of_json @@ -622,26 +647,30 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "P2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 3"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 3")); `P2 ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) )) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> poly2) let _ = poly2_of_json @@ -685,24 +714,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `C (a_of_json (Js.Array.unsafe_get array 1))) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> 'a c) let _ = c_of_json @@ -741,25 +774,31 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); Fix (recur_of_json (Js.Array.unsafe_get array 1))) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> recur) let _ = recur_of_json @@ -800,29 +839,34 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> polyrecur) let _ = polyrecur_of_json @@ -863,25 +907,31 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); A) else if Stdlib.( = ) tag "b_aliased" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); B) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> evar) let _ = evar_of_json @@ -921,29 +971,34 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A_aliased" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `a) else if Stdlib.( = ) tag "b" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `b) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> epoly) let _ = epoly_of_json @@ -983,25 +1038,31 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); A (a_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); B (b_of_json (Js.Array.unsafe_get array 1))) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> ('a, 'b) p2) let _ = p2_of_json @@ -1044,15 +1105,15 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < a : Js.Json.t Js.undefined > Js.t) in { a = (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error (Json_error "missing field: \"a\""))); } : Js.Json.t -> allow_extra_fields) @@ -1092,8 +1153,9 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); let fs = Js.Array.unsafe_get array 1 in if Stdlib.not @@ -1106,8 +1168,9 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object"; + raise + (Json.Of_json_error + (Json_error "expected a JSON object")); let fs = (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t) in @@ -1117,20 +1180,25 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (Json_error + "expected a non empty JSON array with element being \ + a string")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -1177,7 +1245,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < a : Js.Json.t Js.undefined @@ -1189,8 +1257,8 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error (Json_error "missing field: \"a\""))); b_opt = (match Js.Undefined.toOption fs##b_opt with | Stdlib.Option.Some v -> (option_of_json int_of_json) v diff --git a/ppx/test/ppx_deriving_json_js_variants.e2e.t b/ppx/test/ppx_deriving_json_js_variants.e2e.t index 27fa139..5a79ca4 100644 --- a/ppx/test/ppx_deriving_json_js_variants.e2e.t +++ b/ppx/test/ppx_deriving_json_js_variants.e2e.t @@ -21,6 +21,6 @@ > let json = sum_to_json A > ' >> main.ml -Can build without having to open Ppx_deriving_json_runtime.Primitives +Can build without having to open Json.Primitives $ dune build @js diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index d9cde85..2ab2253 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -5,7 +5,7 @@ $ echo ' > (executable > (name main) - > (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + > (flags :standard -w -37-69 -open Json.Primitives) > (preprocess (pps melange-json-native.ppx)))' > dune $ echo ' diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 45b991d..cab4326 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -128,8 +128,9 @@ match x with | `List [ x_0; x_1 ] -> int_of_json x_0, string_of_json x_1 | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2" + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")) : Yojson.Basic.t -> tuple) let _ = tuple_of_json @@ -169,8 +170,9 @@ x_name := Stdlib.Option.Some (string_of_json v) | "age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -179,18 +181,20 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"age\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"age\""))); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record) let _ = record_of_json @@ -241,8 +245,9 @@ x_name := Stdlib.Option.Some (string_of_json v) | "my_age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -251,16 +256,17 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"my_name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"my_name\""))); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> 100); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record_aliased) let _ = record_aliased_of_json @@ -308,8 +314,9 @@ x_k := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -320,8 +327,8 @@ | Stdlib.Option.None -> Stdlib.Option.None); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record_opt) let _ = record_opt_of_json @@ -367,8 +374,9 @@ | "name" -> x_name := Stdlib.Option.Some (string_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -378,14 +386,14 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); } | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> sum) let _ = sum_of_json @@ -430,9 +438,8 @@ S2 (int_of_json x_0, string_of_json x_1) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> sum2) let _ = sum2_of_json @@ -465,9 +472,8 @@ | `List (`String "C" :: []) -> `C | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> other) let _ = other_of_json @@ -496,13 +502,10 @@ | x -> ( match other_of_json x with | x -> (x :> [ `A | `B of int | other ]) - | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : Yojson.Basic.t -> poly) let _ = poly_of_json @@ -537,9 +540,8 @@ `P2 (int_of_json x_0, string_of_json x_1) | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> poly2) let _ = poly2_of_json @@ -572,9 +574,8 @@ | `List [ `String "C"; x_0 ] -> `C (a_of_json x_0) | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> 'a c) let _ = c_of_json @@ -606,9 +607,8 @@ | `List [ `String "Fix"; x_0 ] -> Fix (recur_of_json x_0) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> recur) let _ = recur_of_json @@ -642,9 +642,8 @@ | `List [ `String "Fix"; x_0 ] -> `Fix (polyrecur_of_json x_0) | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> polyrecur) let _ = polyrecur_of_json @@ -678,9 +677,8 @@ | `List (`String "b_aliased" :: []) -> B | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> evar) let _ = evar_of_json @@ -714,9 +712,8 @@ | `List (`String "b" :: []) -> `b | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> epoly) let _ = epoly_of_json @@ -750,9 +747,8 @@ | `List [ `String "B"; x_0 ] -> B (b_of_json x_0) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> ('a, 'b) p2) let _ = p2_of_json @@ -799,12 +795,13 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> allow_extra_fields) let _ = allow_extra_fields_of_json @@ -855,14 +852,14 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); } | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -915,8 +912,9 @@ x_b_opt := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -925,16 +923,17 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); b_opt = (match Stdlib.( ! ) x_b_opt with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> Stdlib.Option.None); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> drop_default_option) let _ = drop_default_option_of_json diff --git a/ppx/test/run.sh b/ppx/test/run.sh index ea376fa..8bb4ab2 100755 --- a/ppx/test/run.sh +++ b/ppx/test/run.sh @@ -13,7 +13,7 @@ echo ' (name lib) (modes melange) (modules main_js) - (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (flags :standard -w -37-69 -open Json.Primitives) (preprocess (pps melange.ppx melange-json.ppx))) (melange.emit (alias js) @@ -24,7 +24,7 @@ echo ' (executable (name main) (modules main) - (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (flags :standard -w -37-69 -open Json.Primitives) (preprocess (pps melange-json-native.ppx))) ' > dune diff --git a/src/Json.ml b/src/Json.ml index b156a86..97e2822 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -445,3 +445,30 @@ let parseOrRaise s = raise @@ ParseError message external stringify : Js.Json.t -> string = "JSON.stringify" + +let classify : + t -> + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] = + fun json -> + if (Obj.magic json : 'a Js.null) == Js.null then `Null + else + match Js.typeof json with + | "string" -> `String (Obj.magic json : string) + | "number" -> + let v = (Obj.magic json : float) in + if Of_json.is_int v then `Int (Obj.magic v : int) else `Float v + | "boolean" -> `Bool (Obj.magic json : bool) + | "object" -> + if Js.Array.isArray json then + let xs = Array.to_list (Obj.magic json : t array) in + `List xs + else + let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in + `Assoc (Array.to_list xs) + | typ -> failwith ("unknown JSON value type: " ^ typ) diff --git a/src/Json.mli b/src/Json.mli index a0c013b..c0fa7ea 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -412,3 +412,14 @@ type exn += ParseError of string val parse : string -> json option [@@deprecated "Use `of_string` instead"] val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] val stringify : json -> string [@@deprecated "Use `to_string` instead"] + +val classify : + json -> + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] +(** Classify a JSON value into a variant type. *) diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/src/native/Json.ml similarity index 51% rename from ppx/native/ppx_deriving_json_runtime.ml rename to src/native/Json.ml index 1d3b146..46ed65b 100644 --- a/ppx/native/ppx_deriving_json_runtime.ml +++ b/src/native/Json.ml @@ -1,7 +1,9 @@ type t = Yojson.Basic.t +(** The type of a JSON data structure *) + +type json = t +(** Defined for convenience. *) -let to_json t = t -let of_json t = t let to_string t = Yojson.Basic.to_string t exception Of_string_error of string @@ -10,6 +12,11 @@ let of_string s = try Yojson.Basic.from_string s with Yojson.Json_error msg -> raise (Of_string_error msg) +type 'a to_json = 'a -> json +(** Describe how to encode a value into JSON. *) + +let to_json : json to_json = fun x -> x + type error = Json_error of string | Unexpected_variant of string exception Of_json_error of error @@ -28,27 +35,10 @@ let show_json_type = function let of_json_error_type_mismatch json expected = of_json_error ("Expected " ^ expected ^ ", got " ^ show_json_type json) -module To_json = struct - let string_to_json v = `String v - let bool_to_json v = `Bool v - let int_to_json v = `Int v - let int64_to_json v = `String (Int64.to_string v) - let float_to_json v = `Float v - let unit_to_json () = `Null - let list_to_json v_to_json vs = `List (List.map v_to_json vs) - - let array_to_json v_to_json vs = - `List (Array.to_list (Array.map v_to_json vs)) - - let option_to_json v_to_json = function - | None -> `Null - | Some v -> v_to_json v - - let result_to_json a_to_json b_to_json v = - match v with - | Ok x -> `List [ `String "Ok"; a_to_json x ] - | Error x -> `List [ `String "Error"; b_to_json x ] -end +type 'a of_json = json -> 'a +(** Describe how to decode a value from JSON. *) + +let of_json : 'a of_json = fun x -> x module Of_json = struct let typeof = function @@ -60,67 +50,98 @@ module Of_json = struct | `Null -> "null" | `String _ -> "string" - let string_of_json = function + let string = function | `String s -> s | json -> of_json_error_type_mismatch json "string" - let bool_of_json = function + let bool = function | `Bool b -> b | json -> of_json_error_type_mismatch json "bool" - let int_of_json = function + let int = function | `Int i -> i | json -> of_json_error_type_mismatch json "int" - let int64_of_json = function + let int64 = function | `String i as json -> ( match Int64.of_string_opt i with | Some v -> v | None -> of_json_error_type_mismatch json "int64 as string") | json -> of_json_error_type_mismatch json "int64 as string" - let float_of_json = function + let float = 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 unit = function `Null -> () | _ -> of_json_error "expected null" - let option_of_json v_of_json = function + let option v_of_json = function | `Null -> None | json -> Some (v_of_json json) - let list_of_json v_of_json = function + let list v_of_json = function | `List l -> List.map v_of_json l | json -> of_json_error_type_mismatch json "array" - let array_of_json v_of_json = function + let array v_of_json = function | `List l -> Array.map v_of_json (Array.of_list l) | json -> of_json_error_type_mismatch json "array" - let result_of_json ok_of_json err_of_json json = + let result ok_of_json err_of_json json = match json with | `List [ `String "Ok"; x ] -> Ok (ok_of_json x) | `List [ `String "Error"; x ] -> Error (err_of_json x) | _ -> of_json_error "invalid JSON" end -module Primitives = struct - include To_json - include Of_json +module To_json = struct + let string v = `String v + let bool v = `Bool v + let int v = `Int v + let int64 v = `String (Int64.to_string v) + let float v = `Float v + let unit () = `Null + let list v_to_json vs = `List (List.map v_to_json vs) + let array v_to_json vs = `List (Array.to_list (Array.map v_to_json vs)) + let option v_to_json = function None -> `Null | Some v -> v_to_json v + + let result a_to_json b_to_json v = + match v with + | Ok x -> `List [ `String "Ok"; a_to_json x ] + | Error x -> `List [ `String "Error"; b_to_json x ] end -module Classify = struct - let classify : - t -> - [ `Null - | `String of string - | `Float of float - | `Int of int - | `Bool of bool - | `List of t list - | `Assoc of (string * t) list ] = - fun x -> x +module Primitives = struct + let string_of_json = Of_json.string + let bool_of_json = Of_json.bool + let float_of_json = Of_json.float + let int_of_json = Of_json.int + let int64_of_json = Of_json.int64 + let option_of_json = Of_json.option + let unit_of_json = Of_json.unit + let result_of_json = Of_json.result + let list_of_json = Of_json.list + let array_of_json = Of_json.array + let string_to_json = To_json.string + let bool_to_json = To_json.bool + let float_to_json = To_json.float + let int_to_json = To_json.int + let int64_to_json = To_json.int64 + let option_to_json = To_json.option + let unit_to_json = To_json.unit + let result_to_json = To_json.result + let list_to_json = To_json.list + let array_to_json = To_json.array end + +let classify : + t -> + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] = + fun x -> x diff --git a/src/native/dune b/src/native/dune new file mode 100644 index 0000000..25b63a5 --- /dev/null +++ b/src/native/dune @@ -0,0 +1,4 @@ +(library + (name json) + (public_name melange-json-native) + (libraries yojson)) From 579a2376e9fb3920ddf1981886fb536988852d98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Sun, 16 Feb 2025 18:39:23 +0100 Subject: [PATCH 07/20] make tests more easily fixable --- src/__tests__/Json_decode_test.ml | 647 ++++++++++++++---------------- 1 file changed, 299 insertions(+), 348 deletions(-) diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 6882f03..74a91a5 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -36,6 +36,12 @@ module Test = struct with Json.Of_json_error _ -> pass) end +let wrap_exn exp = + try + let _ = exp () in + "not called" + with Json.Of_json_error (Json_error str) -> str + let () = describe "id" (fun () -> let open Json in @@ -74,12 +80,11 @@ let () = expect @@ int (Encode.int big_int) |> toEqual big_int); test "infinity" (fun () -> let inf = [%raw "Infinity"] in - try - let (_ : int) = int (Encode.int inf) in - fail "should throw" - with - | Of_json_error (Json_error "expected an integer but got inf") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int) = int (Encode.int inf) in + fail "should throw") + |> toEqual "expected an integer but got inf"); Test.throws int [ Bool; Float; String; Null; Array; Object; Char ]); @@ -93,11 +98,13 @@ let () = expect @@ string (Encode.char 'a') |> toEqual "a"); test "object as string" (fun () -> - try - let (_ : string) = string (Encode.jsonDict (Js.Dict.empty ())) in - fail "should throw" - with Of_json_error (Json_error "expected a string but got {}") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string) = + string (Encode.jsonDict (Js.Dict.empty ())) + in + fail "should throw") + |> toEqual "expected a string but got {}"); Test.throws string [ Bool; Float; Int; Null; Array; Object ]); @@ -120,24 +127,18 @@ let () = expect @@ char (Encode.string "a") |> toEqual 'a'); test "empty string" (fun () -> - try - let (_ : char) = char (Encode.string "") in - fail "should throw" - with - | Of_json_error - (Json_error "expected a single-character string but got \"\"") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : char) = char (Encode.string "") in + fail "should throw") + |> toEqual "expected a single-character string but got \"\""); test "multiple-character string" (fun () -> - try - let (_ : char) = char (Encode.string "abc") in - fail "should throw" - with - | Of_json_error - (Json_error "expected a single-character string but got \"abc\"") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : char) = char (Encode.string "abc") in + fail "should throw") + |> toEqual "expected a single-character string but got \"abc\""); Test.throws char [ Bool; Float; Int; Null; Array; Object ]); @@ -208,16 +209,14 @@ let () = |> toEqual [| Js.null; Js.null; Js.null |]); test "array int -> array boolean" (fun () -> - try - let (_ : bool array) = - (array bool) (parseOrRaise {| [1, 2, 3] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a boolean but got 1\n\tin array at index 0") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : bool array) = + (array bool) (parseOrRaise {| [1, 2, 3] |}) + in + fail "should throw") + |> toEqual "expected a boolean but got 1\n\tin array at index 0"); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -255,16 +254,14 @@ let () = |> toEqual [ Js.null; Js.null; Js.null ]); test "array int -> list boolean" (fun () -> - try - let (_ : bool list) = - (list bool) (parseOrRaise {| [1, 2, 3] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a boolean but got 1\n\tin array at index 0") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : bool list) = + (list bool) (parseOrRaise {| [1, 2, 3] |}) + in + fail "should throw") + |> toEqual "expected a boolean but got 1\n\tin array at index 0"); + test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -287,58 +284,46 @@ let () = expect @@ pair int int (parseOrRaise {| [4, 3] |}) |> toEqual (4, 3)); test "too small" (fun () -> - try - let (_ : int * int) = - (pair int int) (parseOrRaise {| [4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 2 but got [4]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (pair int int) (parseOrRaise {| [4] |}) + in + fail "should throw") + |> toEqual "expected tuple as array of length 2 but got [4]"); test "too large" (fun () -> - try - let (_ : int * int) = - (pair int int) (parseOrRaise {| [3, 4, 5] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 2 but got [3, 4, 5]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (pair int int) (parseOrRaise {| [3, 4, 5] |}) + in + fail "should throw") + |> toEqual + "expected tuple as array of length 2 but got [3, 4, 5]"); test "bad type a" (fun () -> - try - let (_ : int * int) = - (pair int int) (parseOrRaise {| ["3", 4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected an integer but got \"3\"\n\tin pair/tuple2") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (pair int int) (parseOrRaise {| ["3", 4] |}) + in + fail "should throw") + |> toEqual "expected an integer but got \"3\"\n\tin pair/tuple2"); test "bad type b" (fun () -> - try - let (_ : string * string) = - (pair string string) (parseOrRaise {| ["3", 4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a string but got 4\n\tin pair/tuple2") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string * string) = + (pair string string) (parseOrRaise {| ["3", 4] |}) + in + fail "should throw") + |> toEqual "expected a string but got 4\n\tin pair/tuple2"); test "not array" (fun () -> - try - let (_ : int * int) = (pair int int) (parseOrRaise {| 4 |}) in - fail "should throw" - with - | Of_json_error (Json_error "expected tuple as array but got 4") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (pair int int) (parseOrRaise {| 4 |}) + in + fail "should throw") + |> toEqual "expected tuple as array but got 4"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -355,60 +340,46 @@ let () = expect @@ tuple2 string int (parseOrRaise {| ["a", 3] |}) |> toEqual ("a", 3)); test "too small" (fun () -> - try - let (_ : int * int) = - (tuple2 int int) (parseOrRaise {| [4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 2 but got [4]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| [4] |}) + in + fail "should throw") + |> toEqual "expected tuple as array of length 2 but got [4]"); test "too large" (fun () -> - try - let (_ : int * int) = - (tuple2 int int) (parseOrRaise {| [3, 4, 5] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 2 but got [3, 4, 5]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| [3, 4, 5] |}) + in + fail "should throw") + |> toEqual + "expected tuple as array of length 2 but got [3, 4, 5]"); test "bad type a" (fun () -> - try - let (_ : int * int) = - (tuple2 int int) (parseOrRaise {| ["3", 4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected an integer but got \"3\"\n\tin pair/tuple2") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| ["3", 4] |}) + in + fail "should throw") + |> toEqual "expected an integer but got \"3\"\n\tin pair/tuple2"); test "bad type b" (fun () -> - try - let (_ : string * string) = - (tuple2 string string) (parseOrRaise {| ["3", 4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a string but got 4\n\tin pair/tuple2") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string * string) = + (tuple2 string string) (parseOrRaise {| ["3", 4] |}) + in + fail "should throw") + |> toEqual "expected a string but got 4\n\tin pair/tuple2"); test "not array" (fun () -> - try - let (_ : int * int) = - (tuple2 int int) (parseOrRaise {| 4 |}) - in - fail "should throw" - with - | Of_json_error (Json_error "expected tuple as array but got 4") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int) = + (tuple2 int int) (parseOrRaise {| 4 |}) + in + fail "should throw") + |> toEqual "expected tuple as array but got 4"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -427,61 +398,57 @@ let () = @@ tuple3 string int float (parseOrRaise {| ["a", 3, 4.5] |}) |> toEqual ("a", 3, 4.5)); test "too small" (fun () -> - try - let (_ : int * int * int) = - (tuple3 int int int) (parseOrRaise {| [4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 3 but got [4]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int) = + (tuple3 int int int) (parseOrRaise {| [4] |}) + in + fail "should throw") + |> toEqual "expected tuple as array of length 3 but got [4]"); test "too large" (fun () -> - try - let (_ : int * int * int) = - (tuple3 int int int) (parseOrRaise {| [3, 4, 5, 6, 7] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 3 but got [3, 4, 5, 6, 7]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int) = + (tuple3 int int int) + (parseOrRaise {| [3, 4, 5, 6, 7] |}) + in + fail "should throw") + |> toEqual + "expected tuple as array of length 3 but got [3, 4, 5, 6, \ + 7]"); test "bad type a" (fun () -> - try - let (_ : int * int * int) = - (tuple3 int int int) (parseOrRaise {| ["3", 4, 5] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected an integer but got \"3\"\n\tin tuple3") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int) = + (tuple3 int int int) (parseOrRaise {| ["3", 4, 5] |}) + in + fail "should throw") + |> toEqual "expected an integer but got \"3\"\n\tin tuple3"); test "bad type b" (fun () -> - try - let (_ : string * string * string) = - (tuple3 string string string) - (parseOrRaise {| ["3", 4, "5"] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a string but got 4\n\tin tuple3") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string * string * string) = + (tuple3 string string string) + (parseOrRaise {| ["3", 4, "5"] |}) + in + fail "should throw") + |> toEqual "expected a string but got 4\n\tin tuple3"); test "not array" (fun () -> - try - let (_ : int * int * int) = - (tuple3 int int int) (parseOrRaise {| 4 |}) - in - fail "should throw" - with - | Of_json_error (Json_error "expected tuple as array but got 4") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int) = + (tuple3 int int int) (parseOrRaise {| 4 |}) + in + fail "should throw") + |> toEqual "expected tuple as array but got 4"); + test "not array" (fun () -> + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int) = + (tuple3 int int int) (parseOrRaise {| 4 |}) + in + fail "should throw") + |> toEqual "expected tuple as array but got 4"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -501,62 +468,50 @@ let () = (parseOrRaise {| ["a", 3, 4.5, true] |}) |> toEqual ("a", 3, 4.5, true)); test "too small" (fun () -> - try - let (_ : int * int * int * int) = - (tuple4 int int int int) (parseOrRaise {| [4] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 4 but got [4]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int * int) = + (tuple4 int int int int) (parseOrRaise {| [4] |}) + in + fail "should throw") + |> toEqual "expected tuple as array of length 4 but got [4]"); test "too large" (fun () -> - try - let (_ : int * int * int * int) = - (tuple4 int int int int) - (parseOrRaise {| [3, 4, 5, 6, 7, 8] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected tuple as array of length 4 but got [3, 4, 5, 6, 7, 8]") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int * int) = + (tuple4 int int int int) + (parseOrRaise {| [3, 4, 5, 6, 7, 8] |}) + in + fail "should throw") + |> toEqual + "expected tuple as array of length 4 but got [3, 4, 5, 6, \ + 7, 8]"); test "bad type a" (fun () -> - try - let (_ : int * int * int * int) = - (tuple4 int int int int) (parseOrRaise {| ["3", 4, 5, 6] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected an integer but got \"3\"\n\tin tuple4") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int * int) = + (tuple4 int int int int) + (parseOrRaise {| ["3", 4, 5, 6] |}) + in + fail "should throw") + |> toEqual "expected an integer but got \"3\"\n\tin tuple4"); test "bad type b" (fun () -> - try - let (_ : string * string * string * string) = - (tuple4 string string string string) - (parseOrRaise {| ["3", 4, "5", "6"] |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a string but got 4\n\tin tuple4") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string * string * string * string) = + (tuple4 string string string string) + (parseOrRaise {| ["3", 4, "5", "6"] |}) + in + fail "should throw") + |> toEqual "expected a string but got 4\n\tin tuple4"); test "not array" (fun () -> - try - let (_ : int * int * int * int) = - (tuple4 int int int int) (parseOrRaise {| 4 |}) - in - fail "should throw" - with - | Of_json_error (Json_error "expected tuple as array but got 4") -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int * int * int * int) = + (tuple4 int int int int) (parseOrRaise {| 4 |}) + in + fail "should throw") + |> toEqual "expected tuple as array but got 4"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -594,17 +549,15 @@ let () = (parseOrRaise {| { "a": null, "b": null } |}) |> toEqual (Obj.magic [%obj { a = Js.null; b = Js.null }])); test "null -> dict string" (fun () -> - try - let (_ : string Js.Dict.t) = - (dict string) (parseOrRaise {| { "a": null, "b": null } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected a string but got null\n\tin object at key 'a'") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string Js.Dict.t) = + (dict string) + (parseOrRaise {| { "a": null, "b": null } |}) + in + fail "should throw") + |> toEqual + "expected a string but got null\n\tin object at key 'a'"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> try @@ -641,25 +594,25 @@ let () = (parseOrRaise {| { "a": null, "b": null } |}) |> toEqual Js.null); test "missing key" (fun () -> - try - let (_ : string) = - (field "c" string) - (parseOrRaise {| { "a": null, "b": null } |}) - in - fail "should throw" - with Of_json_error (Json_error "expected object with field 'c' but got {\"a\": _, \"b\": _}") -> pass); + expect + @@ wrap_exn (fun () -> + let (_ : string) = + (field "c" string) + (parseOrRaise {| { "a": null, "b": null } |}) + in + fail "should throw") + |> toEqual + "expected object with field 'c' but got {\"a\": _, \"b\": \ + _}"); test "decoder error" (fun () -> - try - let (_ : string) = - (field "b" string) - (parseOrRaise {| { "a": null, "b": null } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected a string but got null\n\tat field 'b'") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : string) = + (field "b" string) + (parseOrRaise {| { "a": null, "b": null } |}) + in + fail "should throw") + |> toEqual "expected a string but got null\n\tat field 'b'"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> @@ -697,41 +650,37 @@ let () = |> toEqual Js.null); test "missing key" (fun () -> - try - let (_ : 'a Js.null) = - (at [ "a"; "y" ] (nullAs Js.null)) - (parseOrRaise - {| { + expect + @@ wrap_exn (fun () -> + let (_ : 'a Js.null) = + (at [ "a"; "y" ] (nullAs Js.null)) + (parseOrRaise + {| { "a": { "x" : null }, "b": null } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error "expected object with field 'y' but got {\"x\": _}\n\tat field 'a'") - -> - pass); + in + fail "should throw") + |> toEqual + "expected object with field 'y' but got {\"x\": _}\n\ + \tat field 'a'"); test "decoder error" (fun () -> - try - let (_ : 'a Js.null) = - (at [ "a"; "x"; "y" ] (nullAs Js.null)) - (parseOrRaise - {| { + expect + @@ wrap_exn (fun () -> + let (_ : 'a Js.null) = + (at [ "a"; "x"; "y" ] (nullAs Js.null)) + (parseOrRaise + {| { "a": { "x" : { "y": "foo" } }, "b": null } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected null but got \"foo\"\n\ - \tat field 'y'\n\ - \tat field 'x'\n\ - \tat field 'a'") - -> - pass); + in + fail "should throw") + |> toEqual + "expected null but got \"foo\"\n\ + \tat field 'y'\n\ + \tat field 'x'\n\ + \tat field 'a'"); test "empty list of keys should raise Invalid_argument" (fun () -> try let (_ : int) = at [] int Js.Json.null in @@ -800,12 +749,14 @@ let () = @@ field "x" (optional int) (parseOrRaise {| { "x": 2.3} |}) |> toEqual None); test "field optional - no such field" (fun () -> - try - let (_ : int option) = - (field "y" (optional int)) (parseOrRaise {| { "x": 2} |}) - in - fail "should throw" - with Of_json_error (Json_error "expected object with field 'y' but got {\"x\": _}") -> pass); + expect + @@ wrap_exn (fun () -> + let (_ : int option) = + (field "y" (optional int)) + (parseOrRaise {| { "x": 2} |}) + in + fail "should throw") + |> toEqual "expected object with field 'y' but got {\"x\": _}"); test "non-Of_json_error exceptions in decoder should pass through" (fun () -> @@ -849,12 +800,18 @@ let () = expect @@ (either int (field "x" int)) (Encode.int 23) |> toEqual 23); - test "object as string in either" (fun () -> - try - let a = Encode.jsonDict (Js.Dict.empty ()) in - let (_ : string) = either string string a in - fail "should throw" - with Of_json_error (Json_error "All decoders given to oneOf failed. Here are all the errors: \n- expected a string but got {}\n- expected a string but got {}\nAnd the JSON being decoded: {}") -> pass); + test "object as string in either" (fun () -> + expect + @@ wrap_exn (fun () -> + let a = Encode.jsonDict (Js.Dict.empty ()) in + let (_ : string) = either string string a in + fail "should throw") + |> toEqual + "All decoders given to oneOf failed. Here are all the \ + errors: \n\ + - expected a string but got {}\n\ + - expected a string but got {}\n\ + And the JSON being decoded: {}"); Test.throws (either int (field "x" int)) @@ -940,38 +897,32 @@ let () = b = [| [| 4 |]; [| 5; 6 |] |]; }])); test "dict array array int - heterogenous structure" (fun () -> - try - let (_ : int array array Js.Dict.t) = - (dict (array (array int))) - (parseOrRaise - {| { "a": [[1, 2], [true]], "b": [[4], [5, 6]] } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected an integer but got true\n\ - \tin array at index 0\n\ - \tin array at index 1\n\ - \tin object at key 'a'") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int array array Js.Dict.t) = + (dict (array (array int))) + (parseOrRaise + {| { "a": [[1, 2], [true]], "b": [[4], [5, 6]] } |}) + in + fail "should throw") + |> toEqual + "expected an integer but got true\n\ + \tin array at index 0\n\ + \tin array at index 1\n\ + \tin object at key 'a'"); test "dict array array int - heterogenous structure 2" (fun () -> - try - let (_ : int array array Js.Dict.t) = - (dict (array (array int))) - (parseOrRaise - {| { "a": [[1, 2], "foo"], "b": [[4], [5, 6]] } |}) - in - fail "should throw" - with - | Of_json_error - (Json_error - "expected an array but got \"foo\"\n\ - \tin array at index 1\n\ - \tin object at key 'a'") - -> - pass); + expect + @@ wrap_exn (fun () -> + let (_ : int array array Js.Dict.t) = + (dict (array (array int))) + (parseOrRaise + {| { "a": [[1, 2], "foo"], "b": [[4], [5, 6]] } |}) + in + fail "should throw") + |> toEqual + "expected an array but got \"foo\"\n\ + \tin array at index 1\n\ + \tin object at key 'a'"); test "field" (fun () -> let json = parseOrRaise {| { "foo": [1, 2, 3], "bar": "baz" } |} From 59b7b84f509f97b7741ec9f1b28a6a2e02fe4863 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Fri, 21 Feb 2025 15:54:38 +0000 Subject: [PATCH 08/20] rename Json to Melange_json --- CHANGES.md | 3 + README.md | 46 ++-- examples/complex.ml | 13 +- examples/decode.ml | 28 +-- examples/dynamicDict_Ocaml.ml | 22 +- examples/dynamicDict_Reason.re | 26 +- examples/encode.ml | 43 ++-- examples/parse.ml | 8 +- examples/tree.ml | 20 +- ppx/browser/ppx_deriving_json_js.ml | 16 +- ppx/common/ppx_deriving_json_common.ml | 4 +- ppx/common/ppx_deriving_tools.ml | 14 +- ppx/native/ppx_deriving_json_native.ml | 8 +- ppx/test/errors.t/prettify.ml | 2 +- ppx/test/example.ml | 6 +- ppx/test/example_json_string.ml | 2 +- ppx/test/poly.t | 193 ++++++++------- ppx/test/ppx_deriving_json_js.e2e.t | 2 +- ppx/test/ppx_deriving_json_js.t | 236 ++++++++++++------- ppx/test/ppx_deriving_json_js_variants.e2e.t | 2 +- ppx/test/ppx_deriving_json_native.e2e.t | 2 +- ppx/test/ppx_deriving_json_native.t | 89 ++++--- ppx/test/run.sh | 4 +- src/__tests__/Json_decode_test.ml | 56 ++--- src/__tests__/Json_encode_test.ml | 2 +- src/__tests__/Json_test.ml | 4 +- src/dune | 2 +- src/{Json.ml => melange_json.ml} | 8 +- src/{Json.mli => melange_json.mli} | 62 +++-- src/native/dune | 2 +- src/native/{Json.ml => melange_json.ml} | 0 31 files changed, 506 insertions(+), 419 deletions(-) rename src/{Json.ml => melange_json.ml} (98%) rename src/{Json.mli => melange_json.mli} (87%) rename src/native/{Json.ml => melange_json.ml} (100%) diff --git a/CHANGES.md b/CHANGES.md index 8c009b9..714fa96 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,8 @@ ## Unpublished +- **[breaking]** Library, PPX: Unify runtimes, replace `Json` module with + `Melange_json`, deprecate `Decode` and `Encode` modules. + ([#36](https://github.com/melange-community/melange-json/pull/36)) - **[breaking]** PPX: Code to decode polyvariants doesn't use an additional `_poly` function which was also generated by the PPX. Instead `Unexpected_variant` error is used to signal that next decoder should be diff --git a/README.md b/README.md index c4cd10a..1700a9a 100644 --- a/README.md +++ b/README.md @@ -11,9 +11,9 @@ composed into more complex decoders. A decoder is a function that takes a raises an `Of_json_error` exception if not. Other functions accept a decoder and produce another decoder. Like `array`, which when given a decoder for type `t` will return a decoder that tries to produce a value of type `t array`. So to -decode an `int array` you combine `Json.Decode.int` with `Json.Decode.array` -into `Json.Decode.(array int)`. An array of arrays of ints? `Json.Decode.(array -(array int))`. Dict containing arrays of ints? `Json.Decode.(dict (array int))`. +decode an `int array` you combine `Melange_json.Of_json.int` with `Melange_json.Of_json.array` +into `Melange_json.Of_json.(array int)`. An array of arrays of ints? `Melange_json.Of_json.(array +(array int))`. Dict containing arrays of ints? `Melange_json.Of_json.(dict (array int))`. ## Example @@ -30,16 +30,16 @@ and point = { module Decode = { let point = json => - Json.Decode.{ + Melange_json.Of_json.{ x: json |> field("x", int), y: json |> field("y", int) }; let line = json => - Json.Decode.{ + Melange_json.Of_json.{ start: json |> field("start", point), end_: json |> field("end", point), - thickness: json |> optional(field("thickness", int)) + thickness: json |> try_or_none(field("thickness", int)) }; }; @@ -48,14 +48,14 @@ let data = {| { "end": { "x": 5, "y": 8 } } |}; -let line = data |> Json.parseOrRaise +let line = data |> Melange_json.of_string |> Decode.line; ``` -NOTE: `Json.Decode.{ ... }` creates an ordinary record, but also opens the -`Json.Decode` module locally, within the scope delimited by the curly braces, so +NOTE: `Melange_json.Of_json.{ ... }` creates an ordinary record, but also opens the +`Melange_json.Of_json` module locally, within the scope delimited by the curly braces, so we don't have to qualify the functions we use from it, like `field`, `int` and -`optional` here. You can also use `Json.Decode.( ... )` to open the module +`try_or_none` here. You can also use `Melange_json.Of_json.( ... )` to open the module locally within the parentheses, if you're not creating a record. See [examples](./examples/) for more. @@ -86,13 +86,11 @@ Add `melange-json` to the `libraries` field in your `dune` file: For the moment, please see the interface files: -* [Json](./src/Json.mli) -* [Json.Encode](./src/Json_encode.mli) -* [Json.Decode](./src/Json_decode.mli) +* [Melange_json](./src/melange_json.mli) ### Writing custom decoders and encoders -If you look at the type signature of `Json.Decode.array`, for example, you'll +If you look at the type signature of `Melange_json.Decode.array`, for example, you'll see it takes an `'a decoder` and returns an `'a array decoder`. `'a decoder` is just an alias for `Js.Json.t -> 'a`, so if we expand the type signature of `array` we'll get `(Js.Json.t -> 'a) -> Js.Json.t -> 'a array`. We can now see @@ -106,7 +104,7 @@ Let's look at `Decode.point` from the example above: ```reason let point = json => { - open! Json.Decode; + open! Melange_json.Decode; { x: json |> field("x", int), y: json |> field("y", int) @@ -115,12 +113,12 @@ let point = json => { ``` This is a function `Js.Json.t -> point`, or a `point decoder`. So if we'd like -to decode an array of points, we can just pass it to `Json.Decode.array` to get +to decode an array of points, we can just pass it to `Melange_json.Of_json.array` to get a `point array decoder` in return. #### Builders -To write a decoder _builder_ like `Json.Decode.array` we need to take another +To write a decoder _builder_ like `Melange_json.Of_json.array` we need to take another decoder as an argument, and thanks to currying we just need to apply it where we'd otherwise use a fixed decoder. Say we want to be able to decode both `int point`s and `float point`s. First we'd have to parameterize the type: @@ -137,7 +135,7 @@ argument: ```reason let point = (decodeNumber, json) => { - open! Json.Decode; + open! Melange_json.Decode; { x: json |> field("x", decodeNumber), y: json |> field("y", decodeNumber) @@ -148,8 +146,8 @@ let point = (decodeNumber, json) => { And if we wish we can now create aliases for each variant: ```reason -let intPoint = point(Json.Decode.int); -let floatPoint = point(Json.Decode.float); +let intPoint = point(Melange_json.Of_json.int); +let floatPoint = point(Melange_json.Of_json.float); ``` #### Encoders @@ -182,7 +180,7 @@ add the `[@@deriving json]` attribute to the type declaration, ensuring the converters for primitives like `int` and `string` are in scope if necessary: ```ocaml -open Json.Primitives +open Melange_json.Primitives type t = { a: int; @@ -217,7 +215,7 @@ type t = { b: string [@json.default "-"]; } [@@deriving of_json] -let t = of_json (Json.parseOrRaise {|{"a": 42}|}) +let t = of_json (Melange_json.of_string {|{"a": 42}|}) (* t = { a = 42; b = "-"; } *) ``` @@ -232,7 +230,7 @@ type t = { b: string option [@json.option]; } [@@deriving of_json] -let t = of_json (Json.parseOrRaise {|{"a": 42}|}) +let t = of_json (Melange_json.of_string {|{"a": 42}|}) (* t = { a = 42; b = None; } *) ``` @@ -263,7 +261,7 @@ type t = { b: string [@json.key "B"]; } [@@deriving of_json] -let t = of_json (Json.parseOrRaise {|{"A": 42, "B": "foo"}|}) +let t = of_json (Melange_json.of_string {|{"A": 42, "B": "foo"}|}) (* t = { a = 42; b = "foo"; } *) ``` diff --git a/examples/complex.ml b/examples/complex.ml index 5f7452e..67ad8ec 100644 --- a/examples/complex.ml +++ b/examples/complex.ml @@ -1,17 +1,18 @@ -[@@@alert "-deprecated"] type line = { start : point; end_ : point; thickness : int option } and point = { x : int; y : int } -module Decode = struct +module Of_json = struct let point json = - Json.Decode.{ x = json |> field "x" int; y = json |> field "y" int } + Melange_json.Of_json. + { x = json |> field "x" int; + y = json |> field "y" int } let line json = - Json.Decode. + Melange_json.Of_json. { start = json |> field "start" point; end_ = json |> field "end" point; - thickness = json |> optional (field "thickness" int); + thickness = json |> try_or_none (field "thickness" int); } end @@ -21,4 +22,4 @@ let data = "end": { "x": 5, "y": 8 } } |} -let _ = data |> Json.parseOrRaise |> Decode.line |> Js.log +let _ = data |> Melange_json.of_string |> Of_json.line |> Js.log diff --git a/examples/decode.ml b/examples/decode.ml index 2c13eb5..4060575 100644 --- a/examples/decode.ml +++ b/examples/decode.ml @@ -1,21 +1,19 @@ -[@@@alert "-deprecated"] - -(* Decoding a fixed JSON data structure using Json.Decode *) +(* Decoding a fixed JSON data structure using Melange_json.Of_json *) let mapJsonObjectString f decoder (encoder : int -> Js.Json.t) str = - let json = Json.parseOrRaise str in - Json.Decode.(dict decoder json) + let json = Melange_json.of_string str in + Melange_json.Of_json.(js_dict decoder json) |> Js.Dict.map ~f:(fun [@u] v -> f v) - |> Json.Encode.dict encoder - |> Json.stringify + |> Melange_json.To_json.js_dict encoder + |> Melange_json.to_string let sum = Array.fold_left ( + ) 0 (* prints `{ "foo": 6, "bar": 24 }` *) -let _ = +let () = Js.log @@ mapJsonObjectString sum - Json.Decode.(array int) - Json.Encode.int + Melange_json.Of_json.(array int) + Melange_json.To_json.int {| { "foo": [1, 2, 3], @@ -24,9 +22,9 @@ let _ = |} (* Error handling *) -let _ = - let json = {|{ "y": 42 } |} |> Json.parseOrRaise in - match Json.Decode.(field "x" int json) with +let () = + let json = {|{ "y": 42 } |} |> Melange_json.of_string in + match Melange_json.Of_json.(field "x" int json) with | x -> Js.log x - | exception Json.Of_json_error err -> - Js.log ("Error:" ^ Json.of_json_error_to_string err) + | exception Melange_json.Of_json_error err -> + Js.log ("Error:" ^ Melange_json.of_json_error_to_string err) diff --git a/examples/dynamicDict_Ocaml.ml b/examples/dynamicDict_Ocaml.ml index 10a2f7c..7aa80ca 100644 --- a/examples/dynamicDict_Ocaml.ml +++ b/examples/dynamicDict_Ocaml.ml @@ -1,5 +1,3 @@ -[@@@alert "-deprecated"] - (* Handling an object with dynamic keys for sub-objects. example: @@ -17,22 +15,22 @@ type obj = { static : string; dynamics : int Js.Dict.t } -module Decode = struct +module Of_json = struct let obj json = - Json.Decode. + Melange_json.Of_json. { static = json |> field "static" string; - dynamics = json |> field "dynamics" (dict int); + dynamics = json |> field "dynamics" (js_dict int); } end -module Encode = struct +module To_json = struct let obj c = - Json.Encode.( - object_ + Melange_json.To_json.( + json_dict (Js.Dict.fromList [ - "static", c.static |> string; "dynamics", c.dynamics |> dict int; - ]) + "static", c.static |> string; "dynamics", c.dynamics |> js_dict int; + ])) end let data = @@ -41,7 +39,7 @@ let data = "dynamics": { "hello": 5, "random": 8 } } |} -let decodedData = data |> Json.parseOrRaise |> Decode.obj +let decodedData = data |> Melange_json.of_string |> Of_json.obj (* Will log [ 'hi', { hello: 5, random: 8 } ] @@ -51,4 +49,4 @@ let _ = decodedData |> Js.log (* Will log { static: 'hi', dynamics: { hello: 5, random: 8 } } *) -let encodedDataBack = decodedData |> Encode.obj |> Js.log +let encodedDataBack = decodedData |> To_json.obj |> Js.log diff --git a/examples/dynamicDict_Reason.re b/examples/dynamicDict_Reason.re index b341ea7..c9ae011 100644 --- a/examples/dynamicDict_Reason.re +++ b/examples/dynamicDict_Reason.re @@ -1,5 +1,3 @@ -[@alert "-deprecated"]; - /* Handling an object with dynamic keys for sub-objects. example: @@ -20,21 +18,23 @@ type obj = { dynamics: Js.Dict.t(int), }; -module Decode = { +module Of_json = { let obj = json => - Json.Decode.{ + Melange_json.Of_json.{ static: json |> field("static", string), - dynamics: json |> field("dynamics", dict(int)), + dynamics: json |> field("dynamics", js_dict(int)), }; }; -module Encode = { +module To_json = { let obj = c => { - Json.Encode.( - object_([ - ("static", string(c.static)), - ("dynamics", c.dynamics |> dict(int)), - ]) + Melange_json.To_json.( + json_dict( + Js.Dict.fromList([ + ("static", string(c.static)), + ("dynamics", c.dynamics |> js_dict(int)), + ]), + ) ); }; }; @@ -44,7 +44,7 @@ let data = {| { "dynamics": { "hello": 5, "random": 8 } } |}; -let decodedData = data |> Json.parseOrRaise |> Decode.obj; +let decodedData = data |> Melange_json.of_string |> Of_json.obj; /* Will log [ 'hi', { hello: 5, random: 8 } ] @@ -54,4 +54,4 @@ let _ = decodedData |> Js.log; /* Will log { static: 'hi', dynamics: { hello: 5, random: 8 } } */ -let encodedDataBack = decodedData |> Encode.obj |> Js.log; +let encodedDataBack = decodedData |> To_json.obj |> Js.log; diff --git a/examples/encode.ml b/examples/encode.ml index f8ebd3a..c4cc419 100644 --- a/examples/encode.ml +++ b/examples/encode.ml @@ -1,24 +1,26 @@ -[@@@alert "-deprecated"] -(* Encoding a JSON data structure using Json.Encode *) +(* Encoding a JSON data structure using Melange_json.Encode *) (* prints ["foo", "bar"] *) let _ = [| "foo"; "bar" |] - |> Json.Encode.stringArray - |> Json.stringify + |> Melange_json.To_json.string_array + |> Melange_json.to_string |> Js.log (* prints ["foo", "bar"] *) let _ = [| "foo"; "bar" |] - |> Js.Array.map ~f:Json.Encode.string - |> Json.Encode.jsonArray - |> Json.stringify + |> Js.Array.map ~f:Melange_json.To_json.string + |> Melange_json.To_json.json_array + |> Melange_json.to_string |> Js.log (* prints { x: 42, foo: 'bar' } *) let _ = - Json.Encode.(object_ [ "x", int 42; "foo", string "bar" ] |> Js.log) + Melange_json.To_json.( + json_dict (Js.Dict.fromList [ "x", int 42; "foo", string "bar" ]) + ) + |> Js.log (* Advanced example: encode a record *) type line = { start : point; end_ : point; thickness : int option } @@ -26,18 +28,23 @@ and point = { x : float; y : float } module Encode = struct let point r = - let open! Json.Encode in - object_ [ "x", float r.x; "y", float r.y ] + let open! Melange_json.To_json in + json_dict (Js.Dict.fromList [ "x", float r.x; "y", float r.y ]) let line r = - Json.Encode.( - object_ - [ - "start", point r.start; - "end", point r.end_; - ( "thickness", - match r.thickness with Some x -> int x | None -> null ); - ]) + Melange_json.To_json.( + json_dict ( + Js.Dict.fromList + [ + "start", point r.start; + "end", point r.end_; + ( "thickness", + match r.thickness with + | Some x -> int x + | None -> unit () ); + ] + ) + ) end let data = diff --git a/examples/parse.ml b/examples/parse.ml index 0eb6d8e..53167e8 100644 --- a/examples/parse.ml +++ b/examples/parse.ml @@ -1,10 +1,8 @@ -[@@@alert "-deprecated"] - -(* Parsing a JSON string using Json.parseOrRaise *) +(* Parsing a JSON string using Melange_json.parseOrRaise *) let arrayOfInts str = - let json = Json.parseOrRaise str in - Json.Decode.(array int json) + let json = Melange_json.of_string str in + Melange_json.Of_json.(array int json) (* prints `[3, 2, 1]` *) let _ = Js.log (arrayOfInts "[1, 2, 3]" |> Js.Array.reverseInPlace) diff --git a/examples/tree.ml b/examples/tree.ml index 5a6d054..023efc7 100644 --- a/examples/tree.ml +++ b/examples/tree.ml @@ -1,16 +1,15 @@ -[@@@alert "-deprecated"] (* Decode a JSON tree structure *) type 'a tree = Node of 'a * 'a tree list | Leaf of 'a module Decode = struct - open Json.Decode + open Melange_json.Of_json - let rec tree decoder = - field "type" string - |> andThen (function - | "node" -> node decoder - | "leaf" -> leaf decoder - | _ -> failwith "unknown node type") + let rec tree decoder json = + let node_type = field "type" string json in + match node_type with + | "node" -> node decoder json + | "leaf" -> leaf decoder json + | _ -> failwith "unknown node type" and node decoder json = Node @@ -60,4 +59,7 @@ let json = } |} let myTree = - json |> Json.parseOrRaise |> Decode.tree Json.Decode.int |> print + json + |> Melange_json.of_string + |> Decode.tree Melange_json.Of_json.int + |> print diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index a90ac62..780f313 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -41,7 +41,7 @@ module Of_json = struct | Some default -> default | None -> [%expr - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x [%e estring ~loc (sprintf "expected field %S to be present" n.txt)]]]] ) @@ -66,13 +66,13 @@ module Of_json = struct let ensure_json_object ~loc x = [%expr if Stdlib.not [%e eis_json_object ~loc x] then - Json.of_json_msg_error + Melange_json.of_json_msg_error [%e estring ~loc (sprintf "expected a JSON object")]] let ensure_json_array_len ~loc n len x = [%expr if Stdlib.( <> ) [%e len] [%e eint ~loc n] then - Json.of_json_msg_error ~json:[%e x] + Melange_json.of_json_msg_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]] @@ -90,7 +90,7 @@ module Of_json = struct let es = (Obj.magic [%e x] : Js.Json.t array) in [%e build_tuple ~loc derive 0 t.tpl_types [%expr es]] else - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]] @@ -112,14 +112,14 @@ module Of_json = struct let tag = (Obj.magic tag : string) in [%e body] else - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] "expected a non empty JSON array with element being a \ string" else - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] "expected a non empty JSON array" else - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] "expected a non empty JSON array"] let derive_of_variant_case derive make c next = @@ -154,7 +154,7 @@ module Of_json = struct let deriving : Ppx_deriving_tools.deriving = deriving_of () ~name:"of_json" ~error:(fun ~loc -> - [%expr Json.of_json_msg_error "invalid JSON"]) + [%expr Melange_json.of_json_msg_error "invalid JSON"]) ~of_t:(fun ~loc -> [%type: Js.Json.t]) ~derive_of_tuple ~derive_of_record ~derive_of_variant ~derive_of_variant_case diff --git a/ppx/common/ppx_deriving_json_common.ml b/ppx/common/ppx_deriving_json_common.ml index 0a528ff..d5ab540 100644 --- a/ppx/common/ppx_deriving_json_common.ml +++ b/ppx/common/ppx_deriving_json_common.ml @@ -119,7 +119,7 @@ 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] (Json.of_string _json)]) + [%expr fun _json -> [%e of_json] (Melange_json.of_string _json)]) let register ~of_json () = Deriving.add "of_json_string" @@ -132,7 +132,7 @@ 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 -> Json.to_string ([%e to_json] _data)]) + [%expr fun _data -> Melange_json.to_string ([%e to_json] _data)]) let register ~to_json () = Deriving.add "to_json_string" diff --git a/ppx/common/ppx_deriving_tools.ml b/ppx/common/ppx_deriving_tools.ml index 163cbc0..41d044f 100644 --- a/ppx/common/ppx_deriving_tools.ml +++ b/ppx/common/ppx_deriving_tools.ml @@ -436,8 +436,8 @@ module Conv = struct ~init: ( [%expr raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))], + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant"))], [] ) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in @@ -465,7 +465,7 @@ module Conv = struct match [%e maybe_e] with | e -> (e :> [%t t]) | exception - Json.Of_json_error (Json.Unexpected_variant _) + Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> [%e next]] in @@ -523,7 +523,7 @@ module Conv = struct [ [%pat? _] --> [%expr - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x [%e estring ~loc error_message]]; ] ~f:(fun next (c : constructor_declaration) -> @@ -576,8 +576,8 @@ module Conv = struct ~init: [%expr raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))] + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant"))] ~f:(fun next (n, ts) -> let maybe = self#derive_type_ref ~loc self#name n ts x @@ -587,7 +587,7 @@ module Conv = struct match [%e maybe] with | x -> (x :> [%t t]) | exception - Json.Of_json_error (Json.Unexpected_variant _) -> + Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> [%e next]]) in let cases = diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index 1bfafc2..5b2b914 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -47,7 +47,7 @@ module Of_json = struct if allow_extra_fields then [%expr ()] else [%expr - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)] in let cases = @@ -81,7 +81,7 @@ module Of_json = struct | Some default -> default | None -> [%expr - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x [%e estring ~loc:key.loc (sprintf "expected field %S" key.txt)]]]] @@ -109,7 +109,7 @@ module Of_json = struct xpatt --> build_tuple ~loc derive xexprs t.tpl_types; [%pat? _] --> [%expr - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]]; @@ -127,7 +127,7 @@ module Of_json = struct [%expr fs] Fun.id; [%pat? _] --> [%expr - Json.of_json_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON object")]]; ] diff --git a/ppx/test/errors.t/prettify.ml b/ppx/test/errors.t/prettify.ml index a55783d..9eeb634 100644 --- a/ppx/test/errors.t/prettify.ml +++ b/ppx/test/errors.t/prettify.ml @@ -1,4 +1,4 @@ -open Json.Primitives +open Melange_json.Primitives type variant = | A diff --git a/ppx/test/example.ml b/ppx/test/example.ml index 1b5f441..c12172c 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -23,7 +23,7 @@ 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] type array_list = { a: int array; b: int list} [@@deriving json] -type json = Json.t +type json = Melange_json.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); @@ -65,11 +65,11 @@ let of_json_cases = [ ] let run' (C (data, of_json, to_json, v)) = print_endline (Printf.sprintf "JSON DATA: %s" data); - let json = Json.of_string data in + let json = Melange_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 + let data' = Melange_json.to_string json' in print_endline (Printf.sprintf "JSON REPRINT: %s" data') let test () = List.iter run' of_json_cases diff --git a/ppx/test/example_json_string.ml b/ppx/test/example_json_string.ml index 840c716..be46797 100644 --- a/ppx/test/example_json_string.ml +++ b/ppx/test/example_json_string.ml @@ -1,4 +1,4 @@ -open Json.Primitives +open Melange_json.Primitives let print fmt = Printf.ksprintf print_endline fmt diff --git a/ppx/test/poly.t b/ppx/test/poly.t index faab569..c75ee32 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -2,8 +2,8 @@ We can alias poly variants: $ echo ' > type t = [`A | `B] [@@deriving json] > type u = t [@@deriving json] - > let () = print_endline (Json.to_string (u_to_json `A)) - > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) + > let () = print_endline (Melange_json.to_string (u_to_json `A)) + > let () = assert (u_of_json (Melange_json.of_string {|["B"]|}) = `B) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -18,10 +18,9 @@ We can alias poly variants: | `List ((`String "B")::[]) -> `B | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t - -> - t) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : + Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -41,8 +40,8 @@ We can alias poly variants: let rec u_to_json = (fun x -> to_json x : u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -65,7 +64,7 @@ We can alias poly variants: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else @@ -73,19 +72,23 @@ We can alias poly variants: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `B) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant"))) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") - else Json.of_json_error ~json:x "expected a non empty JSON array") - else Json.of_json_error ~json:x "expected a non empty JSON array" : - Js.Json.t -> t) + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array") + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -107,8 +110,8 @@ We can alias poly variants: let rec u_to_json = (fun x -> to_json x : u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) === stdout:native === ["A"] === stdout:js === @@ -118,10 +121,10 @@ We can extend aliased polyvariants: $ echo ' > type t = [`A | `B] [@@deriving json] > type u = [t | `C] [@@deriving json] - > let () = print_endline (Json.to_string (u_to_json `A)) - > let () = print_endline (Json.to_string (u_to_json `C)) - > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) - > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) + > let () = print_endline (Melange_json.to_string (u_to_json `A)) + > let () = print_endline (Melange_json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Melange_json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Melange_json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -136,10 +139,9 @@ We can extend aliased polyvariants: | `List ((`String "B")::[]) -> `B | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t - -> - t) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : + Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -160,10 +162,11 @@ We can extend aliased polyvariants: | x -> (match of_json x with | x -> (x :> [ | t | `C ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) -> + | exception Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) : + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant"))) : Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] @@ -173,10 +176,10 @@ We can extend aliased polyvariants: u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = print_endline (Json.to_string (u_to_json `C)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) - let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = print_endline (Melange_json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Melange_json.of_string {|["C"]|})) = `C) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -199,7 +202,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else @@ -207,19 +210,23 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `B) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant"))) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") - else Json.of_json_error ~json:x "expected a non empty JSON array") - else Json.of_json_error ~json:x "expected a non empty JSON array" : - Js.Json.t -> t) + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array") + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -249,25 +256,29 @@ We can extend aliased polyvariants: let tag = (Obj.magic tag : string) in match of_json x with | e -> (e :> [ | t | `C ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) - -> + | exception Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> (if Stdlib.(=) tag "C" then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `C) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant"))) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") - else Json.of_json_error ~json:x "expected a non empty JSON array") - else Json.of_json_error ~json:x "expected a non empty JSON array" : - Js.Json.t -> u) + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array") + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -278,10 +289,10 @@ We can extend aliased polyvariants: u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = print_endline (Json.to_string (u_to_json `C)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) - let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = print_endline (Melange_json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Melange_json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] @@ -297,10 +308,10 @@ We can extend poly variants which are placed behind signatures: > type t = [`A | `B] [@@deriving json] > end > type u = [P.t | `C] [@@deriving json] - > let () = print_endline (Json.to_string (u_to_json `A)) - > let () = print_endline (Json.to_string (u_to_json `C)) - > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) - > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) + > let () = print_endline (Melange_json.to_string (u_to_json `A)) + > let () = print_endline (Melange_json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Melange_json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Melange_json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === module P : @@ -326,8 +337,8 @@ We can extend poly variants which are placed behind signatures: | `List ((`String "B")::[]) -> `B | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) : + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] @@ -351,10 +362,11 @@ We can extend poly variants which are placed behind signatures: | x -> (match P.of_json x with | x -> (x :> [ | P.t | `C ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) -> + | exception Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) : + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant"))) : Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] @@ -364,10 +376,10 @@ We can extend poly variants which are placed behind signatures: u -> Yojson.Basic.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = print_endline (Json.to_string (u_to_json `C)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) - let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = print_endline (Melange_json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Melange_json.of_string {|["C"]|})) = `C) === ppx output:browser === module P : sig @@ -401,7 +413,7 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else @@ -409,22 +421,23 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `B) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant"))) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array") else - Json.of_json_error ~json:x "expected a non empty JSON array" : - Js.Json.t -> t) + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -455,25 +468,29 @@ We can extend poly variants which are placed behind signatures: let tag = (Obj.magic tag : string) in match P.of_json x with | e -> (e :> [ | P.t | `C ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) - -> + | exception Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> (if Stdlib.(=) tag "C" then (if Stdlib.(<>) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `C) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant"))) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") - else Json.of_json_error ~json:x "expected a non empty JSON array") - else Json.of_json_error ~json:x "expected a non empty JSON array" : - Js.Json.t -> u) + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array") + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -484,10 +501,10 @@ We can extend poly variants which are placed behind signatures: u -> Js.Json.t) let _ = u_to_json end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = print_endline (Json.to_string (u_to_json `A)) - let () = print_endline (Json.to_string (u_to_json `C)) - let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) - let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) + let () = print_endline (Melange_json.to_string (u_to_json `A)) + let () = print_endline (Melange_json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Melange_json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Melange_json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index 8271b64..ffcbab5 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -7,7 +7,7 @@ > (name lib) > (modes melange) > (modules example example_json_string main) - > (flags :standard -w -20-37-69 -open Json.Primitives) + > (flags :standard -w -20-37-69 -open Melange_json.Primitives) > (preprocess (pps melange.ppx melange-json.ppx))) > (melange.emit > (alias js) diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index fa3b556..8a96187 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -134,7 +134,9 @@ let es = (Obj.magic x : Js.Json.t array) in ( int_of_json (Js.Array.unsafe_get es 0), string_of_json (Js.Array.unsafe_get es 1) ) - else Json.of_json_error ~json:x "expected a JSON array of length 2" + else + Melange_json.of_json_error ~json:x + "expected a JSON array of length 2" : Js.Json.t -> tuple) let _ = tuple_of_json @@ -172,7 +174,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic x : < name : Js.Json.t Js.undefined @@ -184,13 +186,13 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"name\" to be present"); age = (match Js.Undefined.toOption fs##age with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"age\" to be present"); } : Js.Json.t -> record) @@ -236,7 +238,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic x : < my_name : Js.Json.t Js.undefined @@ -248,7 +250,7 @@ (match Js.Undefined.toOption fs##my_name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"my_name\" to be present"); age = (match Js.Undefined.toOption fs##my_age with @@ -297,7 +299,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic x : < k : Js.Json.t Js.undefined > Js.t) in { k = @@ -343,17 +345,17 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; B (int_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -366,7 +368,8 @@ (Stdlib.( == ) (Obj.magic fs : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then + Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic fs : < name : Js.Json.t Js.undefined > Js.t) in @@ -376,16 +379,20 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"name\" to be present"); }) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> sum) let _ = sum_of_json @@ -433,18 +440,22 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "S2" then ( if Stdlib.( <> ) len 3 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 3"; S2 ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) )) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> sum2) let _ = sum2_of_json @@ -488,19 +499,23 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `C) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> other) let _ = other_of_json @@ -534,28 +549,34 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; `B (int_of_json (Js.Array.unsafe_get array 1))) else match other_of_json x with | e -> (e :> [ `A | `B of int | other ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) - -> + | exception + Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant + "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> poly) let _ = poly_of_json @@ -596,21 +617,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "P2" then ( if Stdlib.( <> ) len 3 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 3"; `P2 ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) )) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> poly2) let _ = poly2_of_json @@ -654,19 +679,23 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; `C (a_of_json (Js.Array.unsafe_get array 1))) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> 'a c) let _ = c_of_json @@ -705,21 +734,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; Fix (recur_of_json (Js.Array.unsafe_get array 1))) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> recur) let _ = recur_of_json @@ -760,24 +793,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> polyrecur) let _ = polyrecur_of_json @@ -818,21 +855,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "b_aliased" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; B) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> evar) let _ = evar_of_json @@ -872,24 +913,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A_aliased" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `a) else if Stdlib.( = ) tag "b" then ( if Stdlib.( <> ) len 1 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 1"; `b) else raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> epoly) let _ = epoly_of_json @@ -929,21 +974,25 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; A (a_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; B (b_of_json (Js.Array.unsafe_get array 1))) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> ('a, 'b) p2) let _ = p2_of_json @@ -985,14 +1034,14 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic x : < a : Js.Json.t Js.undefined > Js.t) in { a = (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"a\" to be present"); } : Js.Json.t -> allow_extra_fields) @@ -1033,7 +1082,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Json.of_json_msg_error ~json:x + Melange_json.of_json_msg_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -1046,7 +1095,8 @@ (Stdlib.( == ) (Obj.magic fs : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then + Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t) in @@ -1056,16 +1106,20 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"a\" to be present"); }) - else Json.of_json_msg_error "invalid JSON" + else Melange_json.of_json_msg_error "invalid JSON" else - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ string" - else Json.of_json_error ~json:x "expected a non empty JSON array" - else Json.of_json_error ~json:x "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" + else + Melange_json.of_json_error ~json:x + "expected a non empty JSON array" : Js.Json.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -1111,7 +1165,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_msg_error "expected a JSON object"; let fs = (Obj.magic x : < a : Js.Json.t Js.undefined @@ -1123,7 +1177,7 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected field \"a\" to be present"); b_opt = (match Js.Undefined.toOption fs##b_opt with diff --git a/ppx/test/ppx_deriving_json_js_variants.e2e.t b/ppx/test/ppx_deriving_json_js_variants.e2e.t index 1225f5e..8c79656 100644 --- a/ppx/test/ppx_deriving_json_js_variants.e2e.t +++ b/ppx/test/ppx_deriving_json_js_variants.e2e.t @@ -21,6 +21,6 @@ > let json = sum_to_json A > ' >> main.ml -Can build without having to open Json.Primitives +Can build without having to open Melange_json.Primitives $ dune build @js diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index 5c0a0b2..055728b 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -5,7 +5,7 @@ $ echo ' > (executable > (name main) - > (flags :standard -w -37-69 -open Json.Primitives) + > (flags :standard -w -37-69 -open Melange_json.Primitives) > (preprocess (pps melange-json-native.ppx)))' > dune $ echo ' diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 16e6627..0097756 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -128,7 +128,8 @@ match x with | `List [ x_0; x_1 ] -> int_of_json x_0, string_of_json x_1 | _ -> - Json.of_json_error ~json:x "expected a JSON array of length 2" + Melange_json.of_json_error ~json:x + "expected a JSON array of length 2" : Yojson.Basic.t -> tuple) let _ = tuple_of_json @@ -168,7 +169,7 @@ x_name := Stdlib.Option.Some (string_of_json v) | "age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)); iter fs @@ -179,14 +180,16 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"name\""); + Melange_json.of_json_error ~json:x + "expected field \"name\""); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"age\""); + Melange_json.of_json_error ~json:x + "expected field \"age\""); } - | _ -> Json.of_json_error ~json:x "expected a JSON object" + | _ -> Melange_json.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record) let _ = record_of_json @@ -237,7 +240,7 @@ x_name := Stdlib.Option.Some (string_of_json v) | "my_age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)); iter fs @@ -248,13 +251,14 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"my_name\""); + Melange_json.of_json_error ~json:x + "expected field \"my_name\""); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> 100); } - | _ -> Json.of_json_error ~json:x "expected a JSON object" + | _ -> Melange_json.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record_aliased) let _ = record_aliased_of_json @@ -302,7 +306,7 @@ x_k := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)); iter fs @@ -314,7 +318,7 @@ | Stdlib.Option.Some v -> v | Stdlib.Option.None -> Stdlib.Option.None); } - | _ -> Json.of_json_error ~json:x "expected a JSON object" + | _ -> Melange_json.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> record_opt) let _ = record_opt_of_json @@ -360,7 +364,7 @@ | "name" -> x_name := Stdlib.Option.Some (string_of_json v) | name -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)); iter fs @@ -372,10 +376,11 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"name\""); + Melange_json.of_json_error ~json:x + "expected field \"name\""); } | _ -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x "expected [\"A\"] or [\"B\", _] or [\"C\", { _ }]" : Yojson.Basic.t -> sum) @@ -419,7 +424,7 @@ match x with | `List [ `String "S2"; x_0; x_1 ] -> S2 (int_of_json x_0, string_of_json x_1) - | _ -> Json.of_json_error ~json:x "expected [\"S2\", _, _]" + | _ -> Melange_json.of_json_error ~json:x "expected [\"S2\", _, _]" : Yojson.Basic.t -> sum2) let _ = sum2_of_json @@ -452,8 +457,8 @@ | `List (`String "C" :: []) -> `C | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> other) let _ = other_of_json @@ -482,10 +487,13 @@ | x -> ( match other_of_json x with | x -> (x :> [ `A | `B of int | other ]) - | exception Json.Of_json_error (Json.Unexpected_variant _) -> + | exception + Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant"))) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) + ) : Yojson.Basic.t -> poly) let _ = poly_of_json @@ -520,8 +528,8 @@ `P2 (int_of_json x_0, string_of_json x_1) | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> poly2) let _ = poly2_of_json @@ -554,8 +562,8 @@ | `List [ `String "C"; x_0 ] -> `C (a_of_json x_0) | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> 'a c) let _ = c_of_json @@ -586,7 +594,8 @@ | `List (`String "A" :: []) -> A | `List [ `String "Fix"; x_0 ] -> Fix (recur_of_json x_0) | _ -> - Json.of_json_error ~json:x "expected [\"A\"] or [\"Fix\", _]" + Melange_json.of_json_error ~json:x + "expected [\"A\"] or [\"Fix\", _]" : Yojson.Basic.t -> recur) let _ = recur_of_json @@ -620,8 +629,8 @@ | `List [ `String "Fix"; x_0 ] -> `Fix (polyrecur_of_json x_0) | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> polyrecur) let _ = polyrecur_of_json @@ -653,7 +662,9 @@ match x with | `List (`String "A" :: []) -> A | `List (`String "b_aliased" :: []) -> B - | _ -> Json.of_json_error ~json:x "expected [\"A\"] or [\"B\"]" + | _ -> + Melange_json.of_json_error ~json:x + "expected [\"A\"] or [\"B\"]" : Yojson.Basic.t -> evar) let _ = evar_of_json @@ -687,8 +698,8 @@ | `List (`String "b" :: []) -> `b | x -> raise - (Json.Of_json_error - (Json.Unexpected_variant "unexpected variant")) + (Melange_json.Of_json_error + (Melange_json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> epoly) let _ = epoly_of_json @@ -721,7 +732,8 @@ | `List [ `String "A"; x_0 ] -> A (a_of_json x_0) | `List [ `String "B"; x_0 ] -> B (b_of_json x_0) | _ -> - Json.of_json_error ~json:x "expected [\"A\", _] or [\"B\", _]" + Melange_json.of_json_error ~json:x + "expected [\"A\", _] or [\"B\", _]" : Yojson.Basic.t -> ('a, 'b) p2) let _ = p2_of_json @@ -768,9 +780,10 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"a\""); + Melange_json.of_json_error ~json:x + "expected field \"a\""); } - | _ -> Json.of_json_error ~json:x "expected a JSON object" + | _ -> Melange_json.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> allow_extra_fields) let _ = allow_extra_fields_of_json @@ -821,9 +834,10 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"a\""); + Melange_json.of_json_error ~json:x + "expected field \"a\""); } - | _ -> Json.of_json_error ~json:x "expected [\"A\", { _ }]" + | _ -> Melange_json.of_json_error ~json:x "expected [\"A\", { _ }]" : Yojson.Basic.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -876,7 +890,7 @@ x_b_opt := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Json.of_json_error ~json:x + Melange_json.of_json_error ~json:x (Stdlib.Printf.sprintf {|did not expect field "%s"|} name)); iter fs @@ -887,13 +901,14 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Json.of_json_error ~json:x "expected field \"a\""); + Melange_json.of_json_error ~json:x + "expected field \"a\""); b_opt = (match Stdlib.( ! ) x_b_opt with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> Stdlib.Option.None); } - | _ -> Json.of_json_error ~json:x "expected a JSON object" + | _ -> Melange_json.of_json_error ~json:x "expected a JSON object" : Yojson.Basic.t -> drop_default_option) let _ = drop_default_option_of_json diff --git a/ppx/test/run.sh b/ppx/test/run.sh index b98a9ef..072ad91 100755 --- a/ppx/test/run.sh +++ b/ppx/test/run.sh @@ -13,7 +13,7 @@ echo ' (name lib) (modes melange) (modules main_js) - (flags :standard -w -20-37-69 -open Json.Primitives) + (flags :standard -w -20-37-69 -open Melange_json.Primitives) (preprocess (pps melange.ppx melange-json.ppx))) (melange.emit (alias js) @@ -24,7 +24,7 @@ echo ' (executable (name main) (modules main) - (flags :standard -w -37-69 -open Json.Primitives) + (flags :standard -w -37-69 -open Melange_json.Primitives) (preprocess (pps melange-json-native.ppx))) ' > dune diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 74a91a5..231ae3f 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -17,7 +17,7 @@ module Test = struct | Char let valueFor = - let open! Json.Encode in + let open! Melange_json.Encode in function | Float -> float 1.23 | Int -> int 23 @@ -33,24 +33,24 @@ module Test = struct try let _ = decoder value in fail "should throw" - with Json.Of_json_error _ -> pass) + with Melange_json.Of_json_error _ -> pass) end let wrap_exn exp = try let _ = exp () in "not called" - with Json.Of_json_error (Json_error str) -> str + with Melange_json.Of_json_error (Json_error str) -> str let () = describe "id" (fun () -> - let open Json in + let open Melange_json in let open Decode in test "id" (fun () -> expect @@ int (0 |> Encode.int |> Decode.id) |> toEqual 0)); describe "bool" (fun () -> - let open Json in + let open Melange_json in let open Decode in test "bool" (fun () -> expect @@ bool (Encode.bool true) |> toEqual true); @@ -60,7 +60,7 @@ let () = Test.throws bool [ Float; Int; String; Null; Array; Object; Char ]); describe "float" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "float" (fun () -> expect @@ float (Encode.float 1.23) |> toEqual 1.23); @@ -70,7 +70,7 @@ let () = Test.throws float [ Bool; String; Null; Array; Object; Char ]); describe "int" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "int" (fun () -> expect @@ int (Encode.int 23) |> toEqual 23); @@ -89,7 +89,7 @@ let () = Test.throws int [ Bool; Float; String; Null; Array; Object; Char ]); describe "string" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "string" (fun () -> expect @@ string (Encode.string "test") |> toEqual "test"); @@ -109,7 +109,7 @@ let () = Test.throws string [ Bool; Float; Int; Null; Array; Object ]); describe "date" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "ISO8601-formatted string" (fun () -> expect @@ date (Encode.string "2012-04-23T18:25:43.511Z") @@ -118,7 +118,7 @@ let () = Test.throws date [ Bool; Float; Int; Null; Array; Object ]); describe "char" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "character" (fun () -> expect @@ char (Encode.char 'a') |> toEqual 'a'); @@ -143,7 +143,7 @@ let () = Test.throws char [ Bool; Float; Int; Null; Array; Object ]); describe "nullable" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "int -> int" (fun () -> expect @@ (nullable int) (Encode.int 23) @@ -169,7 +169,7 @@ let () = Test.throws (nullable bool) [ Int ]); describe "nullAs" (fun () -> - let open Json in + let open Melange_json in let open Decode in test "as 0 - null" (fun () -> expect @@ (nullAs 0) Encode.null |> toEqual 0); @@ -185,7 +185,7 @@ let () = [ Bool; Float; Int; String; Array; Object; Char ]); describe "array" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "array" (fun () -> expect @@ (array int) (Encode.jsonArray [||]) |> toEqual [||]); @@ -231,7 +231,7 @@ let () = [ Bool; Float; Int; String; Null; Object; Char ]); describe "list" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "array" (fun () -> expect @@ (list int) (Encode.jsonArray [||]) |> toEqual []); @@ -275,7 +275,7 @@ let () = [ Bool; Float; Int; String; Null; Object; Char ]); describe "pair" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "heterogenous" (fun () -> expect @@ pair string int (parseOrRaise {| ["a", 3] |}) @@ -334,7 +334,7 @@ let () = with Foo -> pass)); describe "tuple2" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "heterogenous" (fun () -> expect @@ tuple2 string int (parseOrRaise {| ["a", 3] |}) @@ -391,7 +391,7 @@ let () = with Foo -> pass)); describe "tuple3" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "heterogenous" (fun () -> expect @@ -460,7 +460,7 @@ let () = with Foo -> pass)); describe "tuple4" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "heterogenous" (fun () -> expect @@ -523,7 +523,7 @@ let () = with Foo -> pass)); describe "dict" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "object" (fun () -> expect @@ dict int (Encode.object_ []) @@ -571,7 +571,7 @@ let () = [ Bool; Float; Int; String; Null; Array; Char ]); describe "field" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "boolean" (fun () -> expect @@ -628,7 +628,7 @@ let () = [ Bool; Float; Int; String; Null; Array; Object; Char ]); describe "at" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "boolean" (fun () -> expect @@ -696,7 +696,7 @@ let () = [ Bool; Float; Int; String; Null; Array; Object; Char ]); describe "optional" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "boolean -> int" (fun () -> expect @@ (optional int) (Encode.bool true) |> toEqual None); @@ -768,7 +768,7 @@ let () = with Foo -> pass)); describe "oneOf" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "object with field" (fun () -> expect @@ -790,7 +790,7 @@ let () = [ Bool; Float; String; Null; Array; Object; Char ]); describe "either" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "object with field" (fun () -> expect @@ -818,7 +818,7 @@ let () = [ Bool; Float; String; Null; Array; Object; Char ]); describe "withDefault" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "boolean" (fun () -> expect @@ (withDefault 0 int) (Encode.bool true) |> toEqual 0); @@ -847,7 +847,7 @@ let () = with Foo -> pass)); describe "map" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "int" (fun () -> expect @@ (int |> map (( + ) 2)) (Encode.int 23) |> toEqual 25); @@ -857,7 +857,7 @@ let () = [ Bool; Float; String; Null; Array; Object; Char ]); describe "andThen" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "int -> int" (fun () -> expect @@ (int |> andThen (fun _ -> int)) (Encode.int 23) @@ -881,7 +881,7 @@ let () = [ Float ]); describe "composite expressions" (fun () -> - let open Json in + let open Melange_json in let open! Decode in test "dict array array int" (fun () -> expect diff --git a/src/__tests__/Json_encode_test.ml b/src/__tests__/Json_encode_test.ml index 0db7b6a..e2c7cc8 100644 --- a/src/__tests__/Json_encode_test.ml +++ b/src/__tests__/Json_encode_test.ml @@ -1,7 +1,7 @@ [@@@alert "-deprecated"] open Jest open Expect -open! Json.Encode +open! Melange_json.Encode let _ = test "null" (fun () -> expect null |> toEqual @@ Obj.magic Js.null); diff --git a/src/__tests__/Json_test.ml b/src/__tests__/Json_test.ml index 852903f..a144094 100644 --- a/src/__tests__/Json_test.ml +++ b/src/__tests__/Json_test.ml @@ -1,9 +1,9 @@ [@@@alert "-deprecated"] open Jest open Expect -open Json +open Melange_json -let _ = +let () = describe "parse" (fun () -> test "success" (fun () -> expect @@ parse "null" |> toEqual (Some Encode.null)); diff --git a/src/dune b/src/dune index c3e508d..9e1aa75 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (dirs :standard __tests__) (library - (name json) + (name melange_json) (public_name melange-json) (modes melange) (preprocess diff --git a/src/Json.ml b/src/melange_json.ml similarity index 98% rename from src/Json.ml rename to src/melange_json.ml index 4cdf15f..4ae9f60 100644 --- a/src/Json.ml +++ b/src/melange_json.ml @@ -204,7 +204,7 @@ module Of_json = struct else of_json_error ~json "expected result as non-empty array" else of_json_error ~json "expected result as array" - let at' key decode json = + let field key decode json = if Js.typeof json = "object" && (not (Js.Array.isArray json)) @@ -224,8 +224,8 @@ module Of_json = struct let rec at key_path decoder = match key_path with - | [ key ] -> at' key decoder - | first :: rest -> at' first (at rest decoder) + | [ key ] -> field key decoder + | first :: rest -> field first (at rest decoder) | [] -> raise @@ Invalid_argument @@ -361,7 +361,7 @@ module Decode = struct let tuple3 = Of_json.tuple3 let tuple4 = Of_json.tuple4 let dict = Of_json.js_dict - let field = Of_json.at' + let field = Of_json.field let at = Of_json.at let optional = Of_json.try_or_none let withDefault = Of_json.try_of_default diff --git a/src/Json.mli b/src/melange_json.mli similarity index 87% rename from src/Json.mli rename to src/melange_json.mli index d5a0a64..5e4345b 100644 --- a/src/Json.mli +++ b/src/melange_json.mli @@ -1,40 +1,36 @@ (** Efficient JSON handling This module has four aspects to it: - Parsing, which turns a JSON string into an encoded JSON data structure -- Stringificaiton, which produces a JSON string from an encoded JSON data structure +- Stringification, which produces a JSON string from an encoded JSON data structure - Encoding, which is the process of construction a JSON data structure - Decoding, which is the process of deconstructing a JSON data structure {3 Parsing} -{! parse} and {! parseOrRaise} will both (try to) parse a JSON string into a JSON -data structure ({! Js.Json.t}), but behaves differently when encountering a -parse error. [parseOrRaise] will raise a [ParseError], while [parse] will return -a [Js.Json.t result] indicating whether or not the parsing succeeded. There's -not much more to it: [string] in, [Js.Json.t] out. +{! of_string} will (try to) parse a JSON string into a JSON data structure +({! Js.Json.t}), it will raise a [Of_string_error]. There's not much more to it: +[string] in, [Js.Json.t] out. The parsed result, and encoded JSON data structure, then needs to be decoded to actually be usable. See {!section:Decoding} below. {3 Stringification} -Stringification is the exact reverse of parsing. {! stringify} and {! stringifyAny} -both technically do the same thing, but where [stringifyAny] will take any value -and try to do its best with it, retuning a [string option], [stringify] on the -other hand uses the type system to guarantee success, but requires that the data -has been encoded in a JSON data structure first. See {!section:Encoding} below. +Stringification is the exact reverse of parsing. {! to_string} uses the type +system to guarantee success, but requires that the data has been encoded in a +JSON data structure first. See {!section:Encoding} below. {3 Encoding} Encoding creates a JSON data structure which can stringified directly with -{! stringify} or passed to other APIs requiring a typed JSON data structure. Or +{! to_string} or passed to other APIs requiring a typed JSON data structure. Or you could just go straight to decoding it again, if that's your thing. Encoding -functions are in the {! Encode} module. +functions are in the {! To_json} module. {3 Decoding} Decoding is a more complex process, due to the highly dynamic nature of JSON -data structures. The {! Decode} module provides decoder combinators that can +data structures. The {! Of_json} module provides decoder combinators that can be combined to create complex composite decoders for any _known_ JSON data structure. It allows for custom decoders to produce user-defined types. @example {[ -(* Parsing a JSON string using Json.parse *) +(* Parsing a JSON string using Melange_json.of_string *) let arrayOfInts str - match Json.parse str with + match Melange_json.of_string str with | Some value -> - match Json.Decode.(array int value) + match Melange_json.Of_json.(array int value) | Ok arr -> arr | Error _ -> [] | None -> failWith "Unable to parse JSON" @@ -44,44 +40,44 @@ let _ = Js.log (arrayOfInts "[1, 2, 3]" |> Js.Array.reverse) ]} @example {[ -(* Stringifying a value using Json.stringify *) +(* Stringifying a value using Melange_json.to_string *) (* prints `null` *) let _ = - Json.stringify (Encode.int 42) + Melange_json.to_string (To_json.int 42) |> Js.log ]} @example {[ -(* Encoding a JSON data structure using Json.Encode *) +(* Encoding a JSON data structure using Melange_json.Encode *) (* prints ["foo", "bar"] *) let _ = [| "foo", "bar" |] - |> Json.Encode.stringArray - |> Json.stringify + |> Melange_json.To_json.string_array + |> Melange_json.to_string |> Js.log (* prints ["foo", "bar"] *) let _ = [| "foo", "bar" |] - |> Js.Array.map Encode.int - |> Json.Encode.jsonArray - |> Json.stringify + |> Js.Array.map To_json.int + |> To_json.json_array + |> to_string |> Js.log ]} @example {[ -(* Decoding a fixed JSON data structure using Json.Decode *) +(* Decoding a fixed JSON data structure using Melange_json.Of_json *) let mapJsonObjectString f decoder encoder str = - match Json.parse str with + match Melange_json.of_string str with | Ok json -> - match Json.Decode.(dict decoder json) with + match Melange_json.Of_json.(js_dict decoder json) with | Ok dict -> dict |> Js.Dict.map f |> Js.Dict.map encoder - |> Json.Encode.dict - |> Json.stringify + |> Melange_json.To_json.js_dict + |> to_string | Error _ -> [] | Error _ -> [] @@ -91,7 +87,7 @@ let sum ns = (* prints `{ "foo": 6, "bar": 24 }` *) let _ = Js.log ( - mapJsonObjectString sun Json.Decode.(array int) Json.Encode.int {| + mapJsonObjectString sum Melange_json.Of_json.(array int) Melange_json.To_json.int {| { "foo": [1, 2, 3], "bar": [9, 8, 7] @@ -178,7 +174,7 @@ module Of_json : sig (** Auxiliary combinators *) - val at' : string -> 'a of_json -> 'a of_json + val field : string -> 'a of_json -> 'a of_json val at : string list -> 'a of_json -> 'a of_json val one_of : 'a of_json list -> 'a of_json val either : 'a of_json -> 'a of_json -> 'a of_json @@ -311,7 +307,7 @@ module Decode : sig [@@deprecated "Use `Of_json.js_dict` instead"] val field : string -> 'a of_json -> 'a of_json - [@@deprecated "Use `Of_json.at'` instead"] + [@@deprecated "Use `Of_json.field` instead"] val at : string list -> 'a of_json -> 'a of_json [@@deprecated "Use `Of_json.at` instead"] diff --git a/src/native/dune b/src/native/dune index 6027277..c6f8ad4 100644 --- a/src/native/dune +++ b/src/native/dune @@ -1,5 +1,5 @@ (library - (name json) + (name melange_json) (public_name melange-json-native) (libraries yojson)) diff --git a/src/native/Json.ml b/src/native/melange_json.ml similarity index 100% rename from src/native/Json.ml rename to src/native/melange_json.ml From 710cfe3294ab2c18778b9b81d090b095996d8c69 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Fri, 21 Feb 2025 15:55:07 +0000 Subject: [PATCH 09/20] format --- examples/complex.ml | 3 +- examples/dynamicDict_Ocaml.ml | 10 +++--- examples/encode.ml | 23 +++++------- ppx/browser/ppx_deriving_json_js.ml | 9 ++--- ppx/common/ppx_deriving_tools.ml | 13 ++++--- ppx/native/dune | 2 +- src/__tests__/Json_encode_test.ml | 1 + src/__tests__/Json_test.ml | 1 + src/classify.ml | 54 ++++++++++++++--------------- src/melange_json.ml | 6 ++-- src/native/dune | 2 +- 11 files changed, 62 insertions(+), 62 deletions(-) diff --git a/examples/complex.ml b/examples/complex.ml index 67ad8ec..eea540f 100644 --- a/examples/complex.ml +++ b/examples/complex.ml @@ -4,8 +4,7 @@ and point = { x : int; y : int } module Of_json = struct let point json = Melange_json.Of_json. - { x = json |> field "x" int; - y = json |> field "y" int } + { x = json |> field "x" int; y = json |> field "y" int } let line json = Melange_json.Of_json. diff --git a/examples/dynamicDict_Ocaml.ml b/examples/dynamicDict_Ocaml.ml index 7aa80ca..72044d9 100644 --- a/examples/dynamicDict_Ocaml.ml +++ b/examples/dynamicDict_Ocaml.ml @@ -27,10 +27,12 @@ end module To_json = struct let obj c = Melange_json.To_json.( - json_dict (Js.Dict.fromList - [ - "static", c.static |> string; "dynamics", c.dynamics |> js_dict int; - ])) + json_dict + (Js.Dict.fromList + [ + "static", c.static |> string; + "dynamics", c.dynamics |> js_dict int; + ])) end let data = diff --git a/examples/encode.ml b/examples/encode.ml index c4cc419..c1c7c5d 100644 --- a/examples/encode.ml +++ b/examples/encode.ml @@ -18,8 +18,7 @@ let _ = (* prints { x: 42, foo: 'bar' } *) let _ = Melange_json.To_json.( - json_dict (Js.Dict.fromList [ "x", int 42; "foo", string "bar" ]) - ) + json_dict (Js.Dict.fromList [ "x", int 42; "foo", string "bar" ])) |> Js.log (* Advanced example: encode a record *) @@ -33,18 +32,14 @@ module Encode = struct let line r = Melange_json.To_json.( - json_dict ( - Js.Dict.fromList - [ - "start", point r.start; - "end", point r.end_; - ( "thickness", - match r.thickness with - | Some x -> int x - | None -> unit () ); - ] - ) - ) + json_dict + (Js.Dict.fromList + [ + "start", point r.start; + "end", point r.end_; + ( "thickness", + match r.thickness with Some x -> int x | None -> unit () ); + ])) end let data = diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 780f313..25280af 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -7,7 +7,6 @@ open Ppx_deriving_tools.Conv open Ppx_deriving_json_common module Of_json = struct - let build_tuple ~loc derive si (ts : core_type list) e = pexp_tuple ~loc (List.mapi ts ~f:(fun i t -> @@ -43,8 +42,9 @@ module Of_json = struct [%expr Melange_json.of_json_error ~json:x [%e - estring ~loc (sprintf "expected field %S to be present" n.txt)]]]] - ) + estring ~loc + (sprintf "expected field %S to be present" + n.txt)]]]] ) in [%expr let fs = (Obj.magic [%e x] : [%t build_js_type ~loc fs]) in @@ -142,7 +142,8 @@ module Of_json = struct let arity = List.length t.tpl_types in [%expr if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then ( - [%e ensure_json_array_len ~loc (arity + 1) [%expr len] [%expr x]]; + [%e + ensure_json_array_len ~loc (arity + 1) [%expr len] [%expr x]]; [%e if Stdlib.( = ) arity 0 then make None else diff --git a/ppx/common/ppx_deriving_tools.ml b/ppx/common/ppx_deriving_tools.ml index 41d044f..a5f6118 100644 --- a/ppx/common/ppx_deriving_tools.ml +++ b/ppx/common/ppx_deriving_tools.ml @@ -437,7 +437,8 @@ module Conv = struct ( [%expr raise (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant"))], + (Melange_json.Unexpected_variant + "unexpected variant"))], [] ) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in @@ -465,8 +466,8 @@ module Conv = struct match [%e maybe_e] with | e -> (e :> [%t t]) | exception - Melange_json.Of_json_error (Melange_json.Unexpected_variant _) - -> + Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> [%e next]] in next, cases) @@ -577,7 +578,8 @@ module Conv = struct [%expr raise (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant"))] + (Melange_json.Unexpected_variant + "unexpected variant"))] ~f:(fun next (n, ts) -> let maybe = self#derive_type_ref ~loc self#name n ts x @@ -587,7 +589,8 @@ module Conv = struct match [%e maybe] with | x -> (x :> [%t t]) | exception - Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> + Melange_json.Of_json_error + (Melange_json.Unexpected_variant _) -> [%e next]]) in let cases = diff --git a/ppx/native/dune b/ppx/native/dune index e1e64b2..d654b3d 100644 --- a/ppx/native/dune +++ b/ppx/native/dune @@ -31,4 +31,4 @@ (files ../common/ppx_deriving_json_common.ml)) (copy_files# - (files ../common/ppx_deriving_tools.{ml,mli})) \ No newline at end of file + (files ../common/ppx_deriving_tools.{ml,mli})) diff --git a/src/__tests__/Json_encode_test.ml b/src/__tests__/Json_encode_test.ml index e2c7cc8..8716c28 100644 --- a/src/__tests__/Json_encode_test.ml +++ b/src/__tests__/Json_encode_test.ml @@ -1,4 +1,5 @@ [@@@alert "-deprecated"] + open Jest open Expect open! Melange_json.Encode diff --git a/src/__tests__/Json_test.ml b/src/__tests__/Json_test.ml index a144094..f46a95d 100644 --- a/src/__tests__/Json_test.ml +++ b/src/__tests__/Json_test.ml @@ -1,4 +1,5 @@ [@@@alert "-deprecated"] + open Jest open Expect open Melange_json diff --git a/src/classify.ml b/src/classify.ml index e18ba08..7d2323d 100644 --- a/src/classify.ml +++ b/src/classify.ml @@ -1,30 +1,30 @@ type t = Js.Json.t let classify : - t -> - [ `Null - | `String of string - | `Float of float - | `Int of int - | `Bool of bool - | `List of t list - | `Assoc of (string * t) list ] = - fun json -> - if (Obj.magic json : 'a Js.null) == Js.null then `Null - else - match Js.typeof json with - | "string" -> `String (Obj.magic json : string) - | "number" -> - let v = (Obj.magic json : float) in - if Js.Float.isFinite v && Js.Math.floor_float v == v then - `Int (Obj.magic v : int) - else `Float v - | "boolean" -> `Bool (Obj.magic json : bool) - | "object" -> - if Js.Array.isArray json then - let xs = Array.to_list (Obj.magic json : t array) in - `List xs - else - let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in - `Assoc (Array.to_list xs) - | typ -> failwith ("unknown JSON value type: " ^ typ) \ No newline at end of file + t -> + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] = + fun json -> + if (Obj.magic json : 'a Js.null) == Js.null then `Null + else + match Js.typeof json with + | "string" -> `String (Obj.magic json : string) + | "number" -> + let v = (Obj.magic json : float) in + if Js.Float.isFinite v && Js.Math.floor_float v == v then + `Int (Obj.magic v : int) + else `Float v + | "boolean" -> `Bool (Obj.magic json : bool) + | "object" -> + if Js.Array.isArray json then + let xs = Array.to_list (Obj.magic json : t array) in + `List xs + else + let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in + `Assoc (Array.to_list xs) + | typ -> failwith ("unknown JSON value type: " ^ typ) diff --git a/src/melange_json.ml b/src/melange_json.ml index 4ae9f60..006d53e 100644 --- a/src/melange_json.ml +++ b/src/melange_json.ml @@ -128,8 +128,7 @@ module Of_json = struct decodeB (Array.unsafe_get source 1), decodeC (Array.unsafe_get source 2) ) with Of_json_error err -> - of_json_msg_error - (of_json_error_to_string err ^ "\n\tin tuple3") + of_json_msg_error (of_json_error_to_string err ^ "\n\tin tuple3") else of_json_error ~json "expected tuple as array of length 3" else of_json_error ~json "expected tuple as array" @@ -144,8 +143,7 @@ module Of_json = struct decodeC (Array.unsafe_get source 2), decodeD (Array.unsafe_get source 3) ) with Of_json_error err -> - of_json_msg_error - (of_json_error_to_string err ^ "\n\tin tuple4") + of_json_msg_error (of_json_error_to_string err ^ "\n\tin tuple4") else of_json_error ~json "expected tuple as array of length 4" else of_json_error ~json "expected tuple as array" diff --git a/src/native/dune b/src/native/dune index c6f8ad4..e0931f3 100644 --- a/src/native/dune +++ b/src/native/dune @@ -4,4 +4,4 @@ (libraries yojson)) (copy_files - (files ../errors.ml)) \ No newline at end of file + (files ../errors.ml)) From b8fd14bed9abfdd24992d80d942e55adfa916ab8 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Fri, 21 Feb 2025 16:05:33 +0000 Subject: [PATCH 10/20] add comment in strange test --- src/__tests__/Json_decode_test.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 231ae3f..c9a4292 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -79,6 +79,8 @@ let () = let big_int = [%raw "2147483648"] in expect @@ int (Encode.int big_int) |> toEqual big_int); test "infinity" (fun () -> + (* does this test make sense? it uses `Infinity` which is picked as + float at runtime so the error is weird *) let inf = [%raw "Infinity"] in expect @@ wrap_exn (fun () -> From 1ea1e05f879f45114087a5be855164f7a26e52be Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Fri, 21 Feb 2025 16:39:27 +0000 Subject: [PATCH 11/20] add back classify module --- src/melange_json.ml | 4 ++-- src/melange_json.mli | 22 ++++++++++++---------- src/native/melange_json.ml | 2 ++ 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/melange_json.ml b/src/melange_json.ml index 006d53e..c564679 100644 --- a/src/melange_json.ml +++ b/src/melange_json.ml @@ -1,6 +1,8 @@ type t = Js.Json.t type json = t +module Classify = Classify + let to_json t = t let of_json t = t @@ -414,5 +416,3 @@ let parseOrRaise s = raise @@ ParseError message external stringify : Js.Json.t -> string = "JSON.stringify" - -let classify = Classify.classify diff --git a/src/melange_json.mli b/src/melange_json.mli index 5e4345b..2034238 100644 --- a/src/melange_json.mli +++ b/src/melange_json.mli @@ -411,13 +411,15 @@ val parse : string -> json option [@@deprecated "Use `of_string` instead"] val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] val stringify : json -> string [@@deprecated "Use `to_string` instead"] -val classify : - json -> - [ `Assoc of (string * json) list - | `Bool of bool - | `Float of float - | `Int of int - | `List of json list - | `Null - | `String of string ] -(** Classify a JSON value into a variant type. *) +module Classify : sig + val classify : + json -> + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] + (** Classify a JSON value into a variant type. *) +end diff --git a/src/native/melange_json.ml b/src/native/melange_json.ml index 027ea9c..0db09a8 100644 --- a/src/native/melange_json.ml +++ b/src/native/melange_json.ml @@ -6,6 +6,8 @@ type t = Yojson.Basic.t type json = t (** Defined for convenience. *) +module Classify = Classify + let to_string t = Yojson.Basic.to_string t include Errors From 3fa710dc65665e8541f4aa72d648af5dcb990f95 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Mon, 24 Feb 2025 10:58:35 +0000 Subject: [PATCH 12/20] add tests for ppx errors --- ppx/test/example.ml | 51 ++++++++++++++++++++++++- ppx/test/ppx_deriving_json_js.e2e.t | 28 ++++++++++++++ ppx/test/ppx_deriving_json_native.e2e.t | 28 ++++++++++++++ 3 files changed, 106 insertions(+), 1 deletion(-) diff --git a/ppx/test/example.ml b/ppx/test/example.ml index c12172c..0d0e192 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -25,6 +25,13 @@ type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_de type array_list = { a: int array; b: int list} [@@deriving json] type json = Melange_json.t type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json +type color = Red | Green | Blue [@@deriving json] + +type shape = + | Circle of float (* radius *) + | Rectangle of float * float (* width * height *) + | Point of { x: float; y: float } [@@deriving json] + let of_json_cases = [ C ({|1|}, user_of_json, user_to_json, 1); C ({|"9223372036854775807"|}, userid_of_json, userid_to_json, 9223372036854775807L); @@ -62,6 +69,9 @@ let of_json_cases = [ 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}); C ({|{"a":[1],"b":[2]}|}, array_list_of_json, array_list_to_json, {a=[|1|]; b=[2]}); + C ({|["Circle", 5.0]|}, shape_of_json, shape_to_json, Circle 5.0); + C ({|["Rectangle", 10.0, 20.0]|}, shape_of_json, shape_to_json, Rectangle (10.0, 20.0)); + C ({|["Point", {"x": 1.0, "y": 2.0}]|}, shape_of_json, shape_to_json, Point {x=1.0; y=2.0}); ] let run' (C (data, of_json, to_json, v)) = print_endline (Printf.sprintf "JSON DATA: %s" data); @@ -71,5 +81,44 @@ let run' (C (data, of_json, to_json, v)) = let json' = to_json v' in let data' = Melange_json.to_string json' in print_endline (Printf.sprintf "JSON REPRINT: %s" data') + +(* Error cases for object validation *) +type must_be_object = { field: int } [@@deriving json] +type must_be_array_2 = (int * int) [@@deriving json] +type must_be_array_3 = (int * int * int) [@@deriving json] + +let error_cases = [ + (* Should fail with "expected a JSON object" *) + C ({|42|}, must_be_object_of_json, must_be_object_to_json, {field=1}); + + (* Should fail with "expected a JSON array of length 2" *) + C ({|[1]|}, must_be_array_2_of_json, must_be_array_2_to_json, (1, 2)); + C ({|[1,2,3]|}, must_be_array_2_of_json, must_be_array_2_to_json, (1, 2)); + + (* Should fail with "expected a JSON array of length 3" *) + C ({|[1,2]|}, must_be_array_3_of_json, must_be_array_3_to_json, (1, 2, 3)); + C ({|[1,2,3,4]|}, must_be_array_3_of_json, must_be_array_3_to_json, (1, 2, 3)); + + (* Should fail with "expected a JSON string representing a variant" *) + C ({|42|}, color_of_json, color_to_json, Red); + C ({|"Yellow"|}, color_of_json, color_to_json, Red); + + (* Should fail with shape validation *) + C ({|["Circle"]|}, shape_of_json, shape_to_json, Circle 1.0); + C ({|["Rectangle", 10.0]|}, shape_of_json, shape_to_json, Rectangle (10.0, 20.0)); + C ({|["Point", 1.0, 2.0]|}, shape_of_json, shape_to_json, Point {x=1.0; y=2.0}); +] + +let run_error_case' (C (data, of_json, _to_json, _v)) = + print_endline (Printf.sprintf "ERROR CASE DATA: %s" data); + let json = Melange_json.of_string data in + try + let _v' = of_json json in + print_endline "Error: should have failed" + with Melange_json.Of_json_error (Json_error msg) -> + print_endline (Printf.sprintf "Got expected error: %s" msg) + let test () = - List.iter run' of_json_cases + List.iter run' of_json_cases; + print_endline "\nTesting error cases:"; + List.iter run_error_case' error_cases diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index ffcbab5..5253154 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -99,6 +99,34 @@ JSON REPRINT: {"a":1,"b_opt":2} JSON DATA: {"a":[1],"b":[2]} JSON REPRINT: {"a":[1],"b":[2]} + JSON DATA: ["Circle", 5.0] + JSON REPRINT: ["Circle",5] + JSON DATA: ["Rectangle", 10.0, 20.0] + JSON REPRINT: ["Rectangle",10,20] + JSON DATA: ["Point", {"x": 1.0, "y": 2.0}] + JSON REPRINT: ["Point",{"x":1,"y":2}] + + Testing error cases: + ERROR CASE DATA: 42 + Got expected error: expected a JSON object + ERROR CASE DATA: [1] + Got expected error: expected a JSON array of length 2 but got [1] + ERROR CASE DATA: [1,2,3] + Got expected error: expected a JSON array of length 2 but got [1, 2, 3] + ERROR CASE DATA: [1,2] + Got expected error: expected a JSON array of length 3 but got [1, 2] + ERROR CASE DATA: [1,2,3,4] + Got expected error: expected a JSON array of length 3 but got [1, 2, 3, 4] + ERROR CASE DATA: 42 + Got expected error: expected a non empty JSON array but got 42 + ERROR CASE DATA: "Yellow" + Got expected error: expected a non empty JSON array but got "Yellow" + ERROR CASE DATA: ["Circle"] + Got expected error: expected a JSON array of length 2 + ERROR CASE DATA: ["Rectangle", 10.0] + Got expected error: expected a JSON array of length 3 + ERROR CASE DATA: ["Point", 1.0, 2.0] + Got expected error: expected a JSON array of length 2 *** json_string deriver tests *** ** To_json_string ** A 42 -> ["A",42] diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index 055728b..8b8817d 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -89,6 +89,34 @@ JSON REPRINT: {"a":1,"b_opt":2} JSON DATA: {"a":[1],"b":[2]} JSON REPRINT: {"a":[1],"b":[2]} + JSON DATA: ["Circle", 5.0] + JSON REPRINT: ["Circle",5.0] + JSON DATA: ["Rectangle", 10.0, 20.0] + JSON REPRINT: ["Rectangle",10.0,20.0] + JSON DATA: ["Point", {"x": 1.0, "y": 2.0}] + JSON REPRINT: ["Point",{"x":1.0,"y":2.0}] + + Testing error cases: + ERROR CASE DATA: 42 + Got expected error: expected a JSON object but got 42 + ERROR CASE DATA: [1] + Got expected error: expected a JSON array of length 2 but got [1] + ERROR CASE DATA: [1,2,3] + Got expected error: expected a JSON array of length 2 but got [1, 2, 3] + ERROR CASE DATA: [1,2] + Got expected error: expected a JSON array of length 3 but got [1, 2] + ERROR CASE DATA: [1,2,3,4] + Got expected error: expected a JSON array of length 3 but got [1, 2, 3, 4] + ERROR CASE DATA: 42 + Got expected error: expected ["Red"] or ["Green"] or ["Blue"] but got 42 + ERROR CASE DATA: "Yellow" + Got expected error: expected ["Red"] or ["Green"] or ["Blue"] but got "Yellow" + ERROR CASE DATA: ["Circle"] + Got expected error: expected ["Circle", _] or ["Rectangle", _, _] or ["Point", { _ }] but got ["Circle"] + ERROR CASE DATA: ["Rectangle", 10.0] + Got expected error: expected ["Circle", _] or ["Rectangle", _, _] or ["Point", { _ }] but got ["Rectangle", 10.] + ERROR CASE DATA: ["Point", 1.0, 2.0] + Got expected error: expected ["Circle", _] or ["Rectangle", _, _] or ["Point", { _ }] but got ["Point", 1., 2.] *** json_string deriver tests *** ** To_json_string ** A 42 -> ["A",42] From be46a4d83110deb341f4b53ca4d1d4b37fc24e41 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Mon, 24 Feb 2025 10:59:40 +0000 Subject: [PATCH 13/20] fix ppx errors --- ppx/browser/ppx_deriving_json_js.ml | 4 +-- ppx/test/poly.t | 16 ++++----- ppx/test/ppx_deriving_json_js.e2e.t | 8 ++--- ppx/test/ppx_deriving_json_js.t | 56 +++++++++++++++-------------- 4 files changed, 43 insertions(+), 41 deletions(-) diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 25280af..2c8ce00 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -66,13 +66,13 @@ module Of_json = struct let ensure_json_object ~loc x = [%expr if Stdlib.not [%e eis_json_object ~loc x] then - Melange_json.of_json_msg_error + Melange_json.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON object")]] let ensure_json_array_len ~loc n len x = [%expr if Stdlib.( <> ) [%e len] [%e eint ~loc n] then - Melange_json.of_json_msg_error ~json:[%e x] + Melange_json.of_json_error ~json:[%e x] [%e estring ~loc (sprintf "expected a JSON array of length %i" n)]] diff --git a/ppx/test/poly.t b/ppx/test/poly.t index c75ee32..5e2eb85 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -64,7 +64,7 @@ We can alias poly variants: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `A) else @@ -72,7 +72,7 @@ We can alias poly variants: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `B) else @@ -202,7 +202,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `A) else @@ -210,7 +210,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `B) else @@ -262,7 +262,7 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `C) else @@ -413,7 +413,7 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `A) else @@ -421,7 +421,7 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `B) else @@ -474,7 +474,7 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `C) else diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index 5253154..5cbb6cb 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -108,7 +108,7 @@ Testing error cases: ERROR CASE DATA: 42 - Got expected error: expected a JSON object + Got expected error: expected a JSON object but got 42 ERROR CASE DATA: [1] Got expected error: expected a JSON array of length 2 but got [1] ERROR CASE DATA: [1,2,3] @@ -122,11 +122,11 @@ ERROR CASE DATA: "Yellow" Got expected error: expected a non empty JSON array but got "Yellow" ERROR CASE DATA: ["Circle"] - Got expected error: expected a JSON array of length 2 + Got expected error: expected a JSON array of length 2 but got ["Circle"] ERROR CASE DATA: ["Rectangle", 10.0] - Got expected error: expected a JSON array of length 3 + Got expected error: expected a JSON array of length 3 but got ["Rectangle", 10] ERROR CASE DATA: ["Point", 1.0, 2.0] - Got expected error: expected a JSON array of length 2 + Got expected error: expected a JSON array of length 2 but got ["Point", 1, 2] *** json_string deriver tests *** ** To_json_string ** A 42 -> ["A",42] diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index 8a96187..9842fc1 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -174,7 +174,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Melange_json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_error ~json:x "expected a JSON object"; let fs = (Obj.magic x : < name : Js.Json.t Js.undefined @@ -238,7 +238,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Melange_json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_error ~json:x "expected a JSON object"; let fs = (Obj.magic x : < my_name : Js.Json.t Js.undefined @@ -299,7 +299,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Melange_json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_error ~json:x "expected a JSON object"; let fs = (Obj.magic x : < k : Js.Json.t Js.undefined > Js.t) in { k = @@ -345,17 +345,17 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; B (int_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -369,7 +369,8 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Melange_json.of_json_msg_error "expected a JSON object"; + Melange_json.of_json_error ~json:fs + "expected a JSON object"; let fs = (Obj.magic fs : < name : Js.Json.t Js.undefined > Js.t) in @@ -440,7 +441,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "S2" then ( if Stdlib.( <> ) len 3 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 3"; S2 ( int_of_json (Js.Array.unsafe_get array 1), @@ -499,7 +500,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `C) else @@ -549,12 +550,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; `B (int_of_json (Js.Array.unsafe_get array 1))) else @@ -617,7 +618,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "P2" then ( if Stdlib.( <> ) len 3 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 3"; `P2 ( int_of_json (Js.Array.unsafe_get array 1), @@ -679,7 +680,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; `C (a_of_json (Js.Array.unsafe_get array 1))) else @@ -734,12 +735,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; Fix (recur_of_json (Js.Array.unsafe_get array 1))) else Melange_json.of_json_msg_error "invalid JSON" @@ -793,12 +794,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))) else @@ -855,12 +856,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; A) else if Stdlib.( = ) tag "b_aliased" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; B) else Melange_json.of_json_msg_error "invalid JSON" @@ -913,12 +914,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A_aliased" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `a) else if Stdlib.( = ) tag "b" then ( if Stdlib.( <> ) len 1 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 1"; `b) else @@ -974,12 +975,12 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; A (a_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; B (b_of_json (Js.Array.unsafe_get array 1))) else Melange_json.of_json_msg_error "invalid JSON" @@ -1034,7 +1035,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Melange_json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_error ~json:x "expected a JSON object"; let fs = (Obj.magic x : < a : Js.Json.t Js.undefined > Js.t) in { a = @@ -1082,7 +1083,7 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Melange_json.of_json_msg_error ~json:x + Melange_json.of_json_error ~json:x "expected a JSON array of length 2"; let fs = Js.Array.unsafe_get array 1 in if @@ -1096,7 +1097,8 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Melange_json.of_json_msg_error "expected a JSON object"; + Melange_json.of_json_error ~json:fs + "expected a JSON object"; let fs = (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t) in @@ -1165,7 +1167,7 @@ (Stdlib.not (Js.Array.isArray x)) (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) - then Melange_json.of_json_msg_error "expected a JSON object"; + then Melange_json.of_json_error ~json:x "expected a JSON object"; let fs = (Obj.magic x : < a : Js.Json.t Js.undefined From 820b3bdeae705c4d625e19fce77d3ab44a3b01f3 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 6 Mar 2025 14:56:10 +0100 Subject: [PATCH 14/20] make classify a simple value instead of a module --- src/melange_json.ml | 2 +- src/melange_json.mli | 25 ++++++++++++------------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/melange_json.ml b/src/melange_json.ml index c564679..eab832e 100644 --- a/src/melange_json.ml +++ b/src/melange_json.ml @@ -1,7 +1,7 @@ type t = Js.Json.t type json = t -module Classify = Classify +let classify = Classify.classify let to_json t = t let of_json t = t diff --git a/src/melange_json.mli b/src/melange_json.mli index 2034238..0325e52 100644 --- a/src/melange_json.mli +++ b/src/melange_json.mli @@ -92,7 +92,7 @@ let _ = "foo": [1, 2, 3], "bar": [9, 8, 7] } - |} + |} ) ]} *) @@ -411,15 +411,14 @@ val parse : string -> json option [@@deprecated "Use `of_string` instead"] val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] val stringify : json -> string [@@deprecated "Use `to_string` instead"] -module Classify : sig - val classify : - json -> - [ `Assoc of (string * json) list - | `Bool of bool - | `Float of float - | `Int of int - | `List of json list - | `Null - | `String of string ] - (** Classify a JSON value into a variant type. *) -end +val classify : +json -> +[ `Assoc of (string * json) list +| `Bool of bool +| `Float of float +| `Int of int +| `List of json list +| `Null +| `String of string ] +(** Classify a JSON value into a variant type. *) + From 00d8d66155fc9800786e575dabb4738400b5e09c Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 6 Mar 2025 15:06:41 +0100 Subject: [PATCH 15/20] add declassify function --- src/classify.ml | 21 ++++++++++++++++++++- src/melange_json.ml | 1 + src/melange_json.mli | 26 ++++++++++++++++++-------- src/native/classify.ml | 11 +++++++++++ 4 files changed, 50 insertions(+), 9 deletions(-) diff --git a/src/classify.ml b/src/classify.ml index 7d2323d..51c1b6a 100644 --- a/src/classify.ml +++ b/src/classify.ml @@ -1,4 +1,6 @@ -type t = Js.Json.t +module J = Js.Json + +type t = J.t let classify : t -> @@ -28,3 +30,20 @@ let classify : let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in `Assoc (Array.to_list xs) | typ -> failwith ("unknown JSON value type: " ^ typ) + +let declassify : + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] -> + t = function + | `Null -> J.null + | `String str -> J.string str + | `Float f -> J.number f + | `Int i -> J.number (Js.Int.toFloat i) + | `Bool b -> J.boolean b + | `List li -> J.array (Array.of_list li) + | `Assoc assoc -> J.object_ (Js.Dict.fromList assoc) diff --git a/src/melange_json.ml b/src/melange_json.ml index eab832e..4496ef5 100644 --- a/src/melange_json.ml +++ b/src/melange_json.ml @@ -2,6 +2,7 @@ type t = Js.Json.t type json = t let classify = Classify.classify +let declassify = Classify.declassify let to_json t = t let of_json t = t diff --git a/src/melange_json.mli b/src/melange_json.mli index 0325e52..b606fab 100644 --- a/src/melange_json.mli +++ b/src/melange_json.mli @@ -412,13 +412,23 @@ val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] val stringify : json -> string [@@deprecated "Use `to_string` instead"] val classify : -json -> -[ `Assoc of (string * json) list -| `Bool of bool -| `Float of float -| `Int of int -| `List of json list -| `Null -| `String of string ] + json -> + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] (** Classify a JSON value into a variant type. *) +val declassify : + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] -> + json +(** Declassify a variant type into a JSON value. *) diff --git a/src/native/classify.ml b/src/native/classify.ml index 1a3267f..eb568ac 100644 --- a/src/native/classify.ml +++ b/src/native/classify.ml @@ -10,3 +10,14 @@ let classify : | `List of t list | `Assoc of (string * t) list ] = fun x -> x + +let declassify : + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] -> + t = + fun x -> x From 6affb419e55e20e7f35a5b929ce0975366e193a5 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Sat, 8 Mar 2025 22:22:34 +0000 Subject: [PATCH 16/20] fix runtest alias --- ppx/native/dune | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/ppx/native/dune b/ppx/native/dune index 98822ec..1857137 100644 --- a/ppx/native/dune +++ b/ppx/native/dune @@ -27,4 +27,17 @@ %{target} (run echo "let () = Ppxlib.Driver.standalone ()")))) -(include_subdirs (unqualified)) +(copy_files# + (files ./common/ppx_deriving_json_common.ml)) + +(copy_files# + (files ./common/ppx_deriving_tools.{ml,mli})) + +; include_subdirs triggers a dependency cycle +; $ dune runtest +; Error: Dependency cycle between: +; alias .melange-json-files +; -> alias .melange-json-native-files +; -> alias .melange-json-files +; -> required by alias ppx/test/runtest +; (include_subdirs (unqualified)) From 6b4b2f750d5a0eeeff75679fa6c39004a027a5de Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Sat, 8 Mar 2025 22:59:25 +0000 Subject: [PATCH 17/20] apply classify changes to native too --- src/native/melange_json.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/native/melange_json.ml b/src/native/melange_json.ml index 0db09a8..b71f725 100644 --- a/src/native/melange_json.ml +++ b/src/native/melange_json.ml @@ -6,7 +6,8 @@ type t = Yojson.Basic.t type json = t (** Defined for convenience. *) -module Classify = Classify +let classify = Classify.classify +let declassify = Classify.declassify let to_string t = Yojson.Basic.to_string t From eb327c6addadf29796265763221a5d05c9721680 Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Sun, 9 Mar 2025 10:45:58 +0000 Subject: [PATCH 18/20] improve changelog --- CHANGES.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 714fa96..8cbf153 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,8 @@ ## Unpublished -- **[breaking]** Library, PPX: Unify runtimes, replace `Json` module with - `Melange_json`, deprecate `Decode` and `Encode` modules. +- **[breaking]** Library, PPX: Unify runtimes (`*.ppx-runtime` libraries are + removed, can use `melange-json` and `melange-json-native` instead), replace + `Json` module with `Melange_json`, deprecate `Decode` and `Encode` modules. ([#36](https://github.com/melange-community/melange-json/pull/36)) - **[breaking]** PPX: Code to decode polyvariants doesn't use an additional `_poly` function which was also generated by the PPX. Instead From a4c27dec4745db37cf952b90987374c671d739cc Mon Sep 17 00:00:00 2001 From: Javier Chavarri Date: Sun, 9 Mar 2025 17:46:54 +0000 Subject: [PATCH 19/20] remove remaining refs to Ppx_deriving_json_runtime --- ppx/test/allow_any.t/prettify.ml | 2 -- ppx/test/allow_any_poly.t/prettify.ml | 2 -- ppx/test/errors.t/run.t | 18 +++++++++--------- src/native/melange_json.ml | 10 ++-------- 4 files changed, 11 insertions(+), 21 deletions(-) diff --git a/ppx/test/allow_any.t/prettify.ml b/ppx/test/allow_any.t/prettify.ml index 8a344d3..ef26357 100644 --- a/ppx/test/allow_any.t/prettify.ml +++ b/ppx/test/allow_any.t/prettify.ml @@ -1,5 +1,3 @@ -(* open Ppx_deriving_json_runtime.Primitives *) - type variant = | Other of Yojson.Basic.t [@allow_any] | Foo diff --git a/ppx/test/allow_any_poly.t/prettify.ml b/ppx/test/allow_any_poly.t/prettify.ml index 855a28a..5646bd3 100644 --- a/ppx/test/allow_any_poly.t/prettify.ml +++ b/ppx/test/allow_any_poly.t/prettify.ml @@ -1,5 +1,3 @@ -(* open Ppx_deriving_json_runtime.Primitives *) - type variant = [ `Other of Yojson.Basic.t [@allow_any] | `Foo diff --git a/ppx/test/errors.t/run.t b/ppx/test/errors.t/run.t index a36d532..d0438bf 100644 --- a/ppx/test/errors.t/run.t +++ b/ppx/test/errors.t/run.t @@ -10,31 +10,31 @@ $ ocamlopt -dsource _build/default/prettify.pp.ml "d": [ 123, [ 1.2, 2.3, 2.4 ], "i am here" ] } $ dune exec ./prettify.exe -- tag_as_string.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got "A"|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got "A"|}) [2] $ dune exec ./prettify.exe -- wrong_core_type.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected int but got string: "i am a string"|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected int but got string: "i am a string"|}) [2] $ dune exec ./prettify.exe -- wrong_core_type_wide.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected int but got string: "i am a v ... "|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected int but got string: "i am a v ... "|}) [2] $ dune exec ./prettify.exe -- deep_culprit.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected string but got object: {"a": _, "foo": _, "b": _, "c": _, "d": _}|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected string but got object: {"a": _, "foo": _, "b": _, "c": _, "d": _}|}) [2] $ dune exec ./prettify.exe -- wide_culprit.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected string but got array: [123, 234, 345, 123, 234, 345, 123, 234, ...]|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected string but got array: [123, 234, 345, 123, 234, 345, 123, 234, ...]|}) [2] $ dune exec ./prettify.exe -- missing_field.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected field "b" but got {"a": _, "foo": _, "c": _, "d": _}|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected field "b" but got {"a": _, "foo": _, "c": _, "d": _}|}) [2] $ dune exec ./prettify.exe -- unknown_tag.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["Bar"]|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["Bar"]|}) [2] $ dune exec ./prettify.exe -- wrong_tag_payload.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["B", 123, "booh"]|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["B", 123, "booh"]|}) [2] $ dune exec ./prettify.exe -- extra_field.json - Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|did not expect field "bar" but got {"a": _, "foo": _, "bar": _, "b": _, "c": _, "d": _}|}) + Fatal error: exception Melange_json.Of_json_error(Json_error {|did not expect field "bar" but got {"a": _, "foo": _, "bar": _, "b": _, "c": _, "d": _}|}) [2] diff --git a/src/native/melange_json.ml b/src/native/melange_json.ml index b71f725..fdedee8 100644 --- a/src/native/melange_json.ml +++ b/src/native/melange_json.ml @@ -8,7 +8,6 @@ type json = t let classify = Classify.classify let declassify = Classify.declassify - let to_string t = Yojson.Basic.to_string t include Errors @@ -25,15 +24,10 @@ let to_json : json to_json = fun x -> x let () = Printexc.register_printer (function | Of_json_error (Json_error str) -> - Some - (sprintf - "Ppx_deriving_json_runtime.Of_json_error(Json_error {|%s|})" - str) + Some (sprintf "Melange_json.Of_json_error(Json_error {|%s|})" str) | Of_json_error (Unexpected_variant str) -> Some - (sprintf - "Ppx_deriving_json_runtime.Of_json_error(Unexpected_variant \ - {|%s|})" + (sprintf "Melange_json.Of_json_error(Unexpected_variant {|%s|})" str) | _ -> None) From 7ad275c22b7f359d673bb62a1f19374a22249677 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Tue, 11 Mar 2025 10:44:42 +0100 Subject: [PATCH 20/20] Unify move variant err outside (#59) --- CHANGES.md | 59 +++++++++------ ppx/native/common/ppx_deriving_tools.ml | 74 ++++++++++--------- ppx/test/extended_polyvar_errors.t/dune | 5 ++ .../extended_polyvar_errors.t/dune-project | 1 + .../extended_polyvar_errors.t/ok_child.json | 4 + .../extended_polyvar_errors.t/ok_parent.json | 4 + .../extended_polyvar_errors.t/prettify.ml | 24 ++++++ ppx/test/extended_polyvar_errors.t/run.t | 13 ++++ .../wrong_child_tag.json | 4 + .../wrong_parent_tag.json | 4 + ppx/test/poly.t | 60 +++++---------- ppx/test/ppx_deriving_json_js.t | 31 +++----- ppx/test/ppx_deriving_json_native.t | 31 +++----- src/__tests__/Json_decode_test.ml | 2 +- src/errors.ml | 9 +++ src/melange_json.ml | 16 ++-- src/melange_json.mli | 5 ++ 17 files changed, 203 insertions(+), 143 deletions(-) create mode 100644 ppx/test/extended_polyvar_errors.t/dune create mode 100644 ppx/test/extended_polyvar_errors.t/dune-project create mode 100644 ppx/test/extended_polyvar_errors.t/ok_child.json create mode 100644 ppx/test/extended_polyvar_errors.t/ok_parent.json create mode 100644 ppx/test/extended_polyvar_errors.t/prettify.ml create mode 100644 ppx/test/extended_polyvar_errors.t/run.t create mode 100644 ppx/test/extended_polyvar_errors.t/wrong_child_tag.json create mode 100644 ppx/test/extended_polyvar_errors.t/wrong_parent_tag.json diff --git a/CHANGES.md b/CHANGES.md index 8cbf153..77ddf49 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,23 +2,24 @@ - **[breaking]** Library, PPX: Unify runtimes (`*.ppx-runtime` libraries are removed, can use `melange-json` and `melange-json-native` instead), replace - `Json` module with `Melange_json`, deprecate `Decode` and `Encode` modules. + `Json` module with `Melange_json`, deprecate `Decode` and `Encode` modules, + introduce new decoding error type and helper function + `of_json_error_to_string`. ([#36](https://github.com/melange-community/melange-json/pull/36)) - **[breaking]** PPX: Code to decode polyvariants doesn't use an additional `_poly` function which was also generated by the PPX. Instead `Unexpected_variant` error is used to signal that next decoder should be - tried. - ([#32](https://github.com/melange-community/melange-json/pull/32)) + tried. ([#32](https://github.com/melange-community/melange-json/pull/32)) - **[breaking]** Json.Decode.DecodeError exception now contains a variant type as payload instead of a string. ([#32](https://github.com/melange-community/melange-json/pull/32)) - **[breaking]** PPX: Rename `[@json.as]` to `[@json.name]` ([#23](https://github.com/melange-community/melange-json/pull/23)) -- **[breaking]** PPX: Drop special encoding for enumeration-like variants (variants with each - constructor having no arguments). +- **[breaking]** PPX: Drop special encoding for enumeration-like variants + (variants with each constructor having no arguments). ([#26](https://github.com/melange-community/melange-json/pull/26)) -- **[breaking]** PPX: change JSON representation of polyvariants, make it compatible with - ppx_deriving_yojson and ppx_yojson_conv +- **[breaking]** PPX: change JSON representation of polyvariants, make it + compatible with ppx_deriving_yojson and ppx_yojson_conv ([#27](https://github.com/melange-community/melange-json/pull/27)) - **[breaking]** PPX: Consistent use of exceptions in runtime. ([#28](https://github.com/melange-community/melange-json/pull/28)) @@ -30,8 +31,7 @@ - PPX: Add `yojson` as runtime dep for the native version ([#15](https://github.com/melange-community/melange-json/pull/15)) - PPX: add `[@@json_string]` for deriving converters to/from JSON strings - directly - ([#30](https://github.com/melange-community/melange-json/pull/30)) + directly ([#30](https://github.com/melange-community/melange-json/pull/30)) - PPX: add support for `int64` in the runtime ([#33](https://github.com/melange-community/melange-json/pull/33)) - PPX: remove `string_to_json` usage on js side @@ -45,8 +45,7 @@ ([#11](https://github.com/melange-community/melange-json/pull/11)) - Add `melange-json-native` package ([#12](https://github.com/melange-community/melange-json/pull/12)) -- Add `[@drop_default]` attribute to drop `None` values from JSON - representation +- Add `[@drop_default]` attribute to drop `None` values from JSON representation ([#17](https://github.com/melange-community/melange-json/pull/17)) ## 1.2.0 (2024-08-16) @@ -72,47 +71,59 @@ * Added `Json.Decode.id` ### 5.0.1 -* Dual licensed as LGPL-3.0 and MPL-2.0. MPL is mostly equivalent to LGPL but relaxes its restriction on linking, which works better with the JavaScript packaging and distribution model. +* Dual licensed as LGPL-3.0 and MPL-2.0. MPL is mostly equivalent to LGPL but + relaxes its restriction on linking, which works better with the JavaScript + packaging and distribution model. ### 5.0.0 * Removed deprecated `arrayOf` encoder * Renamed `dict` encoder to `jsonDict` -* Added new `dict` encoder that takes an additional encoder argument used to encode the contained values, and so it's consistent with the respective `dict` decoder. +* Added new `dict` encoder that takes an additional encoder argument used to + encode the contained values, and so it's consistent with the respective `dict` + decoder. ### 4.0.0 -* Bumped `bs-platform` peer dependency to 5.0.4 to stop the compiler's complaining. +* Bumped `bs-platform` peer dependency to 5.0.4 to stop the compiler's + complaining. ### 3.0.0 -* Replace usage of `Js.Date.toJSON` with `Js.Date.toJSONUsafe`, which is exactly the same, just to avoid deprecation warnings for end users (Thanks Bob!) +* Replace usage of `Js.Date.toJSON` with `Js.Date.toJSONUsafe`, which is exactly + the same, just to avoid deprecation warnings for end users (Thanks Bob!) * Requires `bs-platform` >= 4.0.2 ### 2.0.0 -* Removed `Json.Decode.boolean`, `Json.Encode.boolean`, `Json.Encode.booleanArray` +* Removed `Json.Decode.boolean`, `Json.Encode.boolean`, + `Json.Encode.booleanArray` * Requires `bs-platform` >= 3.0.0 ### 1.3.1 -* Reverted commits that broke backwards compatibility despite only affecting the implementation +* Reverted commits that broke backwards compatibility despite only affecting the + implementation ### 1.3.0 -* Deprecated `Json.Decode.boolean`, `Json.Encode.boolean`, `Json.Encode.booleanArray` +* Deprecated `Json.Decode.boolean`, `Json.Encode.boolean`, + `Json.Encode.booleanArray` * Added `Json.Encode.boolArray` ### 1.2.0 * Added `Json.Encode.char` and `Json.Decode.char` ### 1.1.0 -* Added "stack traces" to higher-order decoders, making it easier to find the location of an error. +* Added "stack traces" to higher-order decoders, making it easier to find the + location of an error. ### 1.0.1 * Moved repository from `reasonml-community/bs-json` to `glennsl/bs-json` * Renamed NPM package from `bs-json` to `@glennsl/bs-json` ### 1.0.0 -* Replaced `Json.Encoder.array` with `Json.Encode.arrayOf` renamed to `array`. Deprecated `arrayOf` alias. +* Replaced `Json.Encoder.array` with `Json.Encode.arrayOf` renamed to `array`. + Deprecated `arrayOf` alias. * Added `Json.parse`, `Json.parseOrRaise`, `Json.stringify` * Added `date` encoder and decoder * Added `tuple2`/`tuple3`/`tuple4` encoders and decoders -* Fixed bug where js integers > 32-bit were rejected as integers by Json.Decode.int (#15) +* Fixed bug where js integers > 32-bit were rejected as integers by + Json.Decode.int (#15) ### 0.2.4 * Added `Json.Encode.bool` @@ -124,7 +135,8 @@ * Deprecated `Json.Encode.array` ### 0.2.3 -* Fixed embarrassing bug where an API was used that isn't available on IE (honestly more embarrassed on behalf of IE though) +* Fixed embarrassing bug where an API was used that isn't available on IE + (honestly more embarrassed on behalf of IE though) ### 0.2.2 * Added `Json.Decode.pair` @@ -134,4 +146,5 @@ ### 0.2.0 * Breaking: Renamed `Json.Encode.object_` to `Json.Encode.dict` -* Added `Json.Encode.object_` taking a list of properties instead of a Json.Dict.t as before +* Added `Json.Encode.object_` taking a list of properties instead of a + Json.Dict.t as before diff --git a/ppx/native/common/ppx_deriving_tools.ml b/ppx/native/common/ppx_deriving_tools.ml index c005786..d5e6e72 100644 --- a/ppx/native/common/ppx_deriving_tools.ml +++ b/ppx/native/common/ppx_deriving_tools.ml @@ -328,6 +328,28 @@ module Schema = struct end end +let rec get_variant_names ~loc c = + match Schema.repr_row_field c with + | `Rtag (name, ts) -> + [ + Printf.sprintf {|["%s"%s]|} name.txt + (ts |> List.map ~f:(fun _ -> ", _") |> String.concat ~sep:""); + ] + | `Rinherit (n, ts) -> ( + match Schema.repr_core_type (ptyp_constr ~loc:n.loc n ts) with + | `Ptyp_variant fields -> + List.concat_map fields ~f:(get_variant_names ~loc) + | _ -> []) + +let get_constructor_names cs = + List.map cs ~f:(fun c -> + let name = c.pcd_name in + match c.pcd_args with + | Pcstr_record _fs -> Printf.sprintf {|["%s", { _ }]|} name.txt + | Pcstr_tuple li -> + Printf.sprintf {|["%s"%s]|} name.txt + (li |> List.map ~f:(fun _ -> ", _") |> String.concat ~sep:"")) + module Conv = struct type 'ctx tuple = { tpl_loc : location; @@ -403,18 +425,7 @@ module Conv = struct | None -> let error_message = Printf.sprintf "expected %s" - (cs - |> List.map ~f:(fun c -> - let name = c.pcd_name in - match c.pcd_args with - | Pcstr_record _fs -> - Printf.sprintf {|["%s", { _ }]|} - name.txt - | Pcstr_tuple li -> - Printf.sprintf {|["%s"%s]|} name.txt - (li - |> List.map ~f:(fun _ -> ", _") - |> String.concat ~sep:"")) + (get_constructor_names cs |> String.concat ~sep:" or ") in ( [%expr @@ -489,11 +500,15 @@ module Conv = struct (match allow_any_constr with | Some allow_any_constr -> allow_any_constr x, [] | None -> + let error_message = + Printf.sprintf "expected %s" + (cs + |> List.concat_map ~f:(get_variant_names ~loc) + |> String.concat ~sep:" or ") + in ( [%expr - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))], + Melange_json.of_json_unexpected_variant ~json:x + [%e estring ~loc error_message]], [] )) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in @@ -560,18 +575,7 @@ module Conv = struct let loc = td.ptype_loc in let error_message = Printf.sprintf "expected %s" - (cs - |> List.map ~f:(fun c -> - let name = c.pcd_name in - match c.pcd_args with - | Pcstr_record _fs -> - Printf.sprintf {|["%s", { _ }]|} name.txt - | Pcstr_tuple li -> - Printf.sprintf {|["%s"%s]|} name.txt - (li - |> List.map ~f:(fun _ -> ", _") - |> String.concat ~sep:"")) - |> String.concat ~sep:" or ") + (get_constructor_names cs |> String.concat ~sep:" or ") in let cs = repr_variant_cases cs in let cs = @@ -647,11 +651,15 @@ module Conv = struct [%pat? x] --> List.fold_left (List.rev inherits) ~init: - [%expr - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))] + (let error_message = + Printf.sprintf "expected %s" + (cs + |> List.concat_map ~f:(get_variant_names ~loc) + |> String.concat ~sep:" or ") + in + [%expr + Melange_json.of_json_unexpected_variant ~json:x + [%e estring ~loc error_message]]) ~f:(fun next (n, ts) -> let maybe = self#derive_type_ref ~loc self#name n ts x diff --git a/ppx/test/extended_polyvar_errors.t/dune b/ppx/test/extended_polyvar_errors.t/dune new file mode 100644 index 0000000..3e95991 --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/dune @@ -0,0 +1,5 @@ +(executable + (name prettify) + (libraries yojson) + (preprocess + (pps melange-json-native.ppx))) diff --git a/ppx/test/extended_polyvar_errors.t/dune-project b/ppx/test/extended_polyvar_errors.t/dune-project new file mode 100644 index 0000000..b2559fa --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) \ No newline at end of file diff --git a/ppx/test/extended_polyvar_errors.t/ok_child.json b/ppx/test/extended_polyvar_errors.t/ok_child.json new file mode 100644 index 0000000..7e29d9f --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/ok_child.json @@ -0,0 +1,4 @@ +{ + "extended": [ "C", 123, "hello" ], + "not_extended": [ "C", 123, "hello" ] +} \ No newline at end of file diff --git a/ppx/test/extended_polyvar_errors.t/ok_parent.json b/ppx/test/extended_polyvar_errors.t/ok_parent.json new file mode 100644 index 0000000..fdec801 --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/ok_parent.json @@ -0,0 +1,4 @@ +{ + "extended": [ "P" ], + "not_extended": [ "C", 123, "hello" ] +} \ No newline at end of file diff --git a/ppx/test/extended_polyvar_errors.t/prettify.ml b/ppx/test/extended_polyvar_errors.t/prettify.ml new file mode 100644 index 0000000..7ac1463 --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/prettify.ml @@ -0,0 +1,24 @@ +open Melange_json.Primitives + + +type polyvar = [ `C of int * string ] +[@@deriving json] + +type parent = [ `P | polyvar ] +[@@deriving json] + +type polyvars = +{ extended : parent; + not_extended : polyvar; +} +[@@deriving json] + +let () = + In_channel.with_open_bin Sys.argv.(1) (fun file -> + file + |> In_channel.input_all + |> Yojson.Basic.from_string + |> polyvars_of_json + |> polyvars_to_json + |> Yojson.Basic.pretty_to_string + |> print_endline) diff --git a/ppx/test/extended_polyvar_errors.t/run.t b/ppx/test/extended_polyvar_errors.t/run.t new file mode 100644 index 0000000..f4380bf --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/run.t @@ -0,0 +1,13 @@ + $ dune build ./prettify.exe +Uncomment to debug +$ ocamlopt -dsource _build/default/prettify.pp.ml + $ dune exec ./prettify.exe -- ok_parent.json + { "extended": [ "P" ], "not_extended": [ "C", 123, "hello" ] } + $ dune exec ./prettify.exe -- ok_child.json + { "extended": [ "C", 123, "hello" ], "not_extended": [ "C", 123, "hello" ] } + $ dune exec ./prettify.exe -- wrong_parent_tag.json + Fatal error: exception Melange_json.Of_json_error(Unexpected_variant {|expected ["P"] but got ["Wrong"]|}) + [2] + $ dune exec ./prettify.exe -- wrong_child_tag.json + Fatal error: exception Melange_json.Of_json_error(Unexpected_variant {|expected ["P"] but got ["Wrong", 123, "hello"]|}) + [2] diff --git a/ppx/test/extended_polyvar_errors.t/wrong_child_tag.json b/ppx/test/extended_polyvar_errors.t/wrong_child_tag.json new file mode 100644 index 0000000..d079f44 --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/wrong_child_tag.json @@ -0,0 +1,4 @@ +{ + "extended": [ "Wrong", 123, "hello" ], + "not_extended": [ "A" ] +} \ No newline at end of file diff --git a/ppx/test/extended_polyvar_errors.t/wrong_parent_tag.json b/ppx/test/extended_polyvar_errors.t/wrong_parent_tag.json new file mode 100644 index 0000000..a5ce73e --- /dev/null +++ b/ppx/test/extended_polyvar_errors.t/wrong_parent_tag.json @@ -0,0 +1,4 @@ +{ + "extended": [ "Wrong" ], + "not_extended": [ "A" ] +} \ No newline at end of file diff --git a/ppx/test/poly.t b/ppx/test/poly.t index d58340c..619256d 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -17,10 +17,8 @@ We can alias poly variants: | `List ((`String "A")::[]) -> `A | `List ((`String "B")::[]) -> `B | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) : - Yojson.Basic.t -> t) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]" : Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -76,10 +74,8 @@ We can alias poly variants: "expected a JSON array of length 1" else `B) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]") else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") @@ -138,10 +134,8 @@ We can extend aliased polyvariants: | `List ((`String "A")::[]) -> `A | `List ((`String "B")::[]) -> `B | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) : - Yojson.Basic.t -> t) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]" : Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -164,10 +158,8 @@ We can extend aliased polyvariants: | x -> (x :> [ | t | `C ]) | exception Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant"))) : - Yojson.Basic.t -> u) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]") : Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -214,10 +206,8 @@ We can extend aliased polyvariants: "expected a JSON array of length 1" else `B) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]") else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") @@ -266,10 +256,8 @@ We can extend aliased polyvariants: "expected a JSON array of length 1" else `C) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]") else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") @@ -336,10 +324,8 @@ We can extend poly variants which are placed behind signatures: | `List ((`String "A")::[]) -> `A | `List ((`String "B")::[]) -> `B | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) : - Yojson.Basic.t -> t) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]" : Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -364,10 +350,8 @@ We can extend poly variants which are placed behind signatures: | x -> (x :> [ | P.t | `C ]) | exception Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant"))) : - Yojson.Basic.t -> u) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]") : Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -425,10 +409,8 @@ We can extend poly variants which are placed behind signatures: "expected a JSON array of length 1" else `B) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\"]") else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") @@ -478,10 +460,8 @@ We can extend poly variants which are placed behind signatures: "expected a JSON array of length 1" else `C) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant"))) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]") else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a string") diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index 4b27524..3b3c721 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -510,9 +510,8 @@ "expected a JSON array of length 1" else `C else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ @@ -570,10 +569,8 @@ | exception Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant - "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\", _]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ @@ -631,9 +628,8 @@ ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) ) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"P2\", _, _]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ @@ -691,9 +687,8 @@ "expected a JSON array of length 2" else `C (a_of_json (Js.Array.unsafe_get array 1)) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\", _]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ @@ -812,9 +807,8 @@ "expected a JSON array of length 2" else `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1)) else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"Fix\", _]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ @@ -934,9 +928,8 @@ "expected a JSON array of length 1" else `b else - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"a\"] or [\"b\"]" else Melange_json.of_json_error ~json:x "expected a non empty JSON array with element being a \ diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 0097756..d66857a 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -456,9 +456,8 @@ match x with | `List (`String "C" :: []) -> `C | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\"]" : Yojson.Basic.t -> other) let _ = other_of_json @@ -490,10 +489,8 @@ | exception Melange_json.Of_json_error (Melange_json.Unexpected_variant _) -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) - ) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"B\", _]") : Yojson.Basic.t -> poly) let _ = poly_of_json @@ -527,9 +524,8 @@ | `List [ `String "P2"; x_0; x_1 ] -> `P2 (int_of_json x_0, string_of_json x_1) | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"P2\", _, _]" : Yojson.Basic.t -> poly2) let _ = poly2_of_json @@ -561,9 +557,8 @@ match x with | `List [ `String "C"; x_0 ] -> `C (a_of_json x_0) | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"C\", _]" : Yojson.Basic.t -> 'a c) let _ = c_of_json @@ -628,9 +623,8 @@ | `List (`String "A" :: []) -> `A | `List [ `String "Fix"; x_0 ] -> `Fix (polyrecur_of_json x_0) | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"A\"] or [\"Fix\", _]" : Yojson.Basic.t -> polyrecur) let _ = polyrecur_of_json @@ -697,9 +691,8 @@ | `List (`String "A_aliased" :: []) -> `a | `List (`String "b" :: []) -> `b | x -> - raise - (Melange_json.Of_json_error - (Melange_json.Unexpected_variant "unexpected variant")) + Melange_json.of_json_unexpected_variant ~json:x + "expected [\"a\"] or [\"b\"]" : Yojson.Basic.t -> epoly) let _ = epoly_of_json diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index c9a4292..21ffed3 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -40,7 +40,7 @@ let wrap_exn exp = try let _ = exp () in "not called" - with Melange_json.Of_json_error (Json_error str) -> str + with Melange_json.Of_json_error str -> (Melange_json.of_json_error_to_string str) let () = describe "id" (fun () -> diff --git a/src/errors.ml b/src/errors.ml index 59eb652..1f07f57 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -99,6 +99,15 @@ let of_json_error ?(depth = 2) ?(width = 8) ~json msg = emit " but got "; emit (show_json_error ~depth ~width json))) +let of_json_msg_unexpected_variant msg = raise (Of_json_error (Unexpected_variant msg)) + +let of_json_unexpected_variant ?(depth = 2) ?(width = 8) ~json msg = + of_json_msg_unexpected_variant + (with_buffer (fun emit -> + emit msg; + emit " but got "; + emit (show_json_error ~depth ~width json))) + (* only use for cases where we need granular handling of the error (e.g. arr)*) let dangerous_of_json_error ?(depth = 2) ?(width = 8) ~json msg = of_json_msg_error diff --git a/src/melange_json.ml b/src/melange_json.ml index 4496ef5..2908bcf 100644 --- a/src/melange_json.ml +++ b/src/melange_json.ml @@ -3,7 +3,6 @@ type json = t let classify = Classify.classify let declassify = Classify.declassify - let to_json t = t let of_json t = t @@ -14,7 +13,7 @@ include Errors let of_json_error_to_string = function | Json_error msg -> msg - | Unexpected_variant tag -> "unexpected variant: " ^ tag + | Unexpected_variant msg -> "unexpected variant: " ^ msg let to_string t = Js.Json.stringify t @@ -85,9 +84,11 @@ module Of_json = struct for i = 0 to length - 1 do let value = try v_of_json (Array.unsafe_get source i) - with Of_json_error (Json_error err) -> + with Of_json_error err -> of_json_msg_error - (err ^ "\n\tin array at index " ^ string_of_int i) + (of_json_error_to_string err + ^ "\n\tin array at index " + ^ string_of_int i) in Array.unsafe_set target i value done; @@ -238,16 +239,15 @@ module Of_json = struct | [] -> let formattedErrors = "\n- " - ^ Js.Array.join ~sep:"\n- " - (Array.of_list - (List.rev_map of_json_error_to_string errors)) + ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) in of_json_msg_error ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} ^ Js.Json.stringify json) | decode :: rest -> ( try decode json - with Of_json_error e -> inner rest (e :: errors)) + with Of_json_error e -> + inner rest (of_json_error_to_string e :: errors)) in inner decoders [] diff --git a/src/melange_json.mli b/src/melange_json.mli index b606fab..eb13c85 100644 --- a/src/melange_json.mli +++ b/src/melange_json.mli @@ -126,6 +126,11 @@ val of_json_error_to_string : of_json_error -> string val of_json_error : ?depth:int -> ?width:int -> json:json -> string -> 'a val of_json_msg_error : string -> 'a +val of_json_unexpected_variant : + ?depth:int -> ?width:int -> json:json -> string -> 'a + +val of_json_msg_unexpected_variant : string -> 'a + type exn += | Of_json_error of of_json_error (** The exception raised when a decoding error occurs *)