Commit c8083f14 authored by Ralf Treinen's avatar Ralf Treinen

New upstream version 3.1

parent fe418b88
......@@ -2,6 +2,9 @@ language: c
env:
- OCAML=4.02.3
- OCAML=4.03.0
- OCAML=4.04.2
- OCAML=4.05.0
- OCAML=4.06.0
script:
- echo "yes" | sudo add-apt-repository ppa:avsm/ppa
- sudo apt-get update -qq
......
Changelog
=========
3.1
---
* Fix ppx_deriving_yojson.runtime META file
(#47)
Étienne Millon
* Support for inline records in variant types
(#50)
Gerd Stolpmann
* OCaml 4.06 compatibility
(#64, #66)
Leonid Rozenberg, Gabriel Scherer
3.0
---
* Use Result.result in generated code.
* Compatibility with statically linked ppx drivers.
* OCaml 4.03 compatibility.
2.3
---
......
......@@ -73,6 +73,16 @@ Variants (regular and polymorphic) are represented using arrays; the first eleme
[["A"],["B",42],["C",42,"foo"]]
```
Record variants are represented in the same way as if the nested structure was defined separately. For example:
```ocaml
# type v = X of { v: int } [@@deriving yojson];;
# print_endline (Yojson.Safe.to_string (v_to_yojson (X { v = 0 })));;
["X",{"v":0}]
```
Record variants are currently not supported for extensible variant types.
By default, objects are deserialized strictly; that is, all keys in the object have to correspond to fields of the record. Passing `strict = false` as an option to the deriver (i.e. `[@@deriving yojson { strict = false }]`) changes the behavior to ignore any unknown fields.
### Options
......
......@@ -3,3 +3,4 @@ true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string, cppo_V_OCAM
"src": include
<src/*.{ml,mli,byte,native}>: package(ppx_tools.metaquot), package(ppx_deriving.api), package(result)
<src_test/*.{ml,byte,native}>: debug, package(result), package(oUnit), package(yojson), use_yojson
true: linkall
opam-version: "1.2"
name: "ppx_deriving_yojson"
version: "3.0"
version: "3.1"
maintainer: "whitequark <whitequark@whitequark.org>"
authors: [ "whitequark <whitequark@whitequark.org>" ]
license: "MIT"
......@@ -15,15 +15,17 @@ build: [
"native-dynlink=%{ocaml-native-dynlink}%"
]
build-test: [
"ocamlbuild" "-classic-display" "-use-ocamlfind" "src_test/test_ppx_yojson.byte" "--"
"ocamlbuild" "-classic-display" "-use-ocamlfind"
"src_test/test_ppx_yojson.byte" "--"
]
depends: [
"yojson"
"result"
"ppx_deriving" {>= "4.0" & < "5.0"}
"ocamlfind" {build}
"cppo" {build}
"ocamlfind" {build}
"ocamlbuild" {build}
"cppo" {build}
"cppo_ocamlbuild" {build}
"ounit" {test}
"ppx_import" {test & >= "1.1"}
]
......@@ -10,7 +10,7 @@ exists_if = "ppx_deriving_yojson.cma"
package "runtime" (
version = "%{version}%"
description = "Runtime components of [@@deriving yojson]"
requires = "yojson result"
requires = "yojson result ppx_deriving.runtime"
archive(byte) = "ppx_deriving_yojson_runtime.cma"
archive(byte, plugin) = "ppx_deriving_yojson_runtime.cma"
archive(native) = "ppx_deriving_yojson_runtime.cmxa"
......
......@@ -6,6 +6,12 @@
#define Type_Nonrecursive Nonrecursive
#endif
#if OCAML_VERSION >= (4, 06, 0)
#define Rtag(label, attrs, has_empty, args) \
Rtag({ txt = label }, attrs, has_empty, args)
#endif
open Longident
open Location
open Asttypes
......@@ -51,11 +57,11 @@ let rec ser_expr_of_typ typ =
match attr_int_encoding typ with `String -> "String" | `Int -> "Intlit"
in
match typ with
| [%type: unit] -> [%expr fun x -> `Null]
| [%type: int] -> [%expr fun x -> `Int x]
| [%type: float] -> [%expr fun x -> `Float x]
| [%type: bool] -> [%expr fun x -> `Bool x]
| [%type: string] -> [%expr fun x -> `String x]
| [%type: unit] -> [%expr fun (x:Ppx_deriving_runtime.unit) -> `Null]
| [%type: int] -> [%expr fun (x:Ppx_deriving_runtime.int) -> `Int x]
| [%type: float] -> [%expr fun (x:Ppx_deriving_runtime.float) -> `Float x]
| [%type: bool] -> [%expr fun (x:Ppx_deriving_runtime.bool) -> `Bool x]
| [%type: string] -> [%expr fun (x:Ppx_deriving_runtime.string) -> `String x]
| [%type: bytes] -> [%expr fun x -> `String (Bytes.to_string x)]
| [%type: char] -> [%expr fun x -> `String (String.make 1 x)]
| [%type: [%t? typ] ref] -> [%expr fun x -> [%e ser_expr_of_typ typ] !x]
......@@ -88,15 +94,15 @@ let rec ser_expr_of_typ typ =
let cases =
fields |> List.map (fun field ->
match field with
| Rtag (label, attrs, true (*empty*), []) ->
| Rtag(label, attrs, true (*empty*), []) ->
Exp.case (Pat.variant label None)
[%expr `List [`String [%e str (attr_name label attrs)]]]
| Rtag (label, attrs, false, [{ ptyp_desc = Ptyp_tuple typs }]) ->
| Rtag(label, attrs, false, [{ ptyp_desc = Ptyp_tuple typs }]) ->
Exp.case (Pat.variant label (Some (ptuple (List.mapi (fun i _ -> pvar (argn i)) typs))))
[%expr `List ((`String [%e str (attr_name label attrs)]) :: [%e
list (List.mapi
(fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])]
| Rtag (label, attrs, false, [typ]) ->
| Rtag(label, attrs, false, [typ]) ->
Exp.case (Pat.variant label (Some [%pat? x]))
[%expr `List [`String [%e str (attr_name label attrs)];
[%e ser_expr_of_typ typ] x]]
......@@ -181,14 +187,14 @@ and desu_expr_of_typ ~path typ =
let inherits, tags = List.partition (function Rinherit _ -> true | _ -> false) fields in
let tag_cases = tags |> List.map (fun field ->
match field with
| Rtag (label, attrs, true (*empty*), []) ->
| Rtag(label, attrs, true (*empty*), []) ->
Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]]]
[%expr Result.Ok [%e Exp.variant label None]]
| Rtag (label, attrs, false, [{ ptyp_desc = Ptyp_tuple typs }]) ->
| Rtag(label, attrs, false, [{ ptyp_desc = Ptyp_tuple typs }]) ->
Exp.case [%pat? `List ((`String [%p pstr (attr_name label attrs)]) :: [%p
plist (List.mapi (fun i _ -> pvar (argn i)) typs)])]
(desu_fold ~path (fun x -> (Exp.variant label (Some (tuple x)))) typs)
| Rtag (label, attrs, false, [typ]) ->
| Rtag(label, attrs, false, [typ]) ->
Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]; x]]
[%expr [%e desu_expr_of_typ ~path typ] x >>= fun x ->
Result.Ok [%e Exp.variant label (Some [%expr x])]]
......@@ -233,6 +239,26 @@ let ser_type_of_decl ~options ~path type_decl =
(fun var -> [%type: [%t var] -> Yojson.Safe.json]) type_decl in
polymorphize [%type: [%t typ] -> Yojson.Safe.json]
let ser_str_of_record varname labels =
let fields =
labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
let field = Exp.field (evar varname) (mknoloc (Lident name)) in
let result = [%expr [%e str (attr_key name pld_attributes)],
[%e ser_expr_of_typ pld_type] [%e field]] in
match attr_default (pld_type.ptyp_attributes @ pld_attributes) with
| None ->
[%expr [%e result] :: fields]
| Some default ->
[%expr if [%e field] = [%e default] then fields else [%e result] :: fields])
in
let assoc =
List.fold_left
(fun expr field -> [%expr let fields = [%e field] in [%e expr]])
[%expr `Assoc fields] fields
in
[%expr let fields = [] in [%e assoc]]
let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
ignore (parse_options options);
let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
......@@ -311,28 +337,16 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
(pconstr name' (List.mapi (fun i _ -> pvar (argn i)) args))
[%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])]
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record _ ->
raise_errorf ~loc "%s: record variants are not supported" deriver
| Pcstr_record labels ->
let arg_expr = ser_str_of_record (argn 0) labels in
Exp.case
(pconstr name' [pvar(argn 0)])
[%expr `List ((`String [%e str json_name]) :: [%e list[arg_expr]])]
#endif
)
|> Exp.function_
| Ptype_record labels, _ ->
let fields =
labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
let field = Exp.field (evar "x") (mknoloc (Lident name)) in
let result = [%expr [%e str (attr_key name pld_attributes)],
[%e ser_expr_of_typ pld_type] [%e field]] in
match attr_default (pld_type.ptyp_attributes @ pld_attributes) with
| None ->
[%expr [%e result] :: fields]
| Some default ->
[%expr if [%e field] = [%e default] then fields else [%e result] :: fields])
in
let assoc =
List.fold_left (fun expr field -> [%expr let fields = [%e field] in [%e expr]])
[%expr `Assoc fields] fields
in
[%expr fun x -> let fields = [] in [%e assoc]]
[%expr fun x -> [%e ser_str_of_record "x" labels]]
| Ptype_abstract, None ->
raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
in
......@@ -371,7 +385,7 @@ let ser_str_of_type_ext ~options ~path ({ ptyext_path = { loc }} as type_ext) =
[%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])]
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record _ ->
raise_errorf ~loc "%s: record variants are not supported" deriver
raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver
#endif
in
case :: acc_cases) type_ext.ptyext_constructors []
......@@ -406,6 +420,45 @@ let desu_type_of_decl ~options ~path type_decl =
(fun var -> [%type: Yojson.Safe.json -> [%t error_or var]]) type_decl in
polymorphize [%type: Yojson.Safe.json -> [%t error_or typ]]
let desu_str_of_record ~is_strict ~error ~path wrap_record labels =
let top_error = error path in
let record =
List.fold_left
(fun expr i ->
[%expr [%e evar (argn i)] >>= fun [%p pvar (argn i)] -> [%e expr]]
)
( let r =
Exp.record (labels |>
List.mapi (fun i { pld_name = { txt = name } } ->
mknoloc (Lident name), evar (argn i)))
None in
[%expr Result.Ok [%e wrap_record r] ] )
(labels |> List.mapi (fun i _ -> i)) in
let default_case = if is_strict then top_error else [%expr loop xs _state] in
let cases =
(labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
let path = path @ [name] in
let thunks = labels |> List.mapi (fun j _ ->
if i = j then app (desu_expr_of_typ ~path pld_type) [evar "x"] else evar (argn j)) in
Exp.case [%pat? ([%p pstr (attr_key name pld_attributes)], x) :: xs]
[%expr loop xs [%e tuple thunks]])) @
[Exp.case [%pat? []] record;
Exp.case [%pat? _ :: xs] default_case]
and thunks =
labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } ->
match attr_default (pld_type.ptyp_attributes @ pld_attributes) with
| None -> error (path @ [name])
| Some x -> [%expr Result.Ok [%e x]])
in
[%expr
function
| `Assoc xs ->
let rec loop xs ([%p ptuple (List.mapi (fun i _ -> pvar (argn i)) labels)] as _state) =
[%e Exp.match_ [%expr xs] cases]
in loop xs [%e tuple thunks]
| _ -> [%e top_error]]
let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
let is_strict = parse_options options in
let path = path @ [type_decl.ptype_name.txt] in
......@@ -474,42 +527,20 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])]
(desu_fold ~path (fun x -> constr name' x) args)
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record _ ->
raise_errorf ~loc "%s: record variants are not supported" deriver
| Pcstr_record labels ->
let wrap_record r = constr name' [r] in
let sub =
desu_str_of_record ~is_strict ~error ~path wrap_record labels in
Exp.case
[%pat? `List ((`String [%p pstr (attr_name name' pcd_attributes)]) ::
[%p plist [pvar (argn 0)]])]
[%expr [%e sub] [%e evar (argn 0)] ]
#endif
) constrs
in
Exp.function_ (cases @ [Exp.case [%pat? _] top_error])
| Ptype_record labels, _ ->
let record = List.fold_left (fun expr i ->
[%expr [%e evar (argn i)] >>= fun [%p pvar (argn i)] -> [%e expr]])
[%expr Result.Ok [%e Exp.record (labels |> List.mapi (fun i { pld_name = { txt = name } } ->
mknoloc (Lident name), evar (argn i))) None]]
(labels |> List.mapi (fun i _ -> i))
in
let default_case = if is_strict then top_error else [%expr loop xs _state] in
let cases =
(labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
let path = path @ [name] in
let thunks = labels |> List.mapi (fun j _ ->
if i = j then app (desu_expr_of_typ ~path pld_type) [evar "x"] else evar (argn j)) in
Exp.case [%pat? ([%p pstr (attr_key name pld_attributes)], x) :: xs]
[%expr loop xs [%e tuple thunks]])) @
[Exp.case [%pat? []] record;
Exp.case [%pat? _ :: xs] default_case]
and thunks =
labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } ->
match attr_default (pld_type.ptyp_attributes @ pld_attributes) with
| None -> error (path @ [name])
| Some x -> [%expr Result.Ok [%e x]])
in
[%expr
function
| `Assoc xs ->
let rec loop xs ([%p ptuple (List.mapi (fun i _ -> pvar (argn i)) labels)] as _state) =
[%e Exp.match_ [%expr xs] cases]
in loop xs [%e tuple thunks]
| _ -> [%e top_error]]
desu_str_of_record ~is_strict ~error ~path (fun r -> r) labels
| Ptype_abstract, None ->
raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
in
......@@ -541,7 +572,7 @@ let desu_str_of_type_ext ~options ~path ({ ptyext_path = { loc } } as type_ext)
(desu_fold ~path (fun x -> constr name' x) args)
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record _ ->
raise_errorf ~loc "%s: record variants are not supported" deriver
raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver
#endif
in
case :: acc_cases)
......
......@@ -55,6 +55,10 @@ type v = A | B of int | C of int * string
[@@deriving show, yojson]
type r = { x : int; y : string }
[@@deriving show, yojson]
#if OCAML_VERSION >= (4, 03, 0)
type rv = RA | RB of int | RC of int * string | RD of { z : string }
[@@deriving show, yojson]
#endif
let test_unit ctxt =
assert_roundtrip pp_u u_to_yojson u_of_yojson
......@@ -176,6 +180,18 @@ let test_rec ctxt =
assert_roundtrip pp_r r_to_yojson r_of_yojson
{x=42; y="foo"} "{\"x\":42,\"y\":\"foo\"}"
#if OCAML_VERSION >= (4, 03, 0)
let test_recvar ctxt =
assert_roundtrip pp_rv rv_to_yojson rv_of_yojson
RA "[\"RA\"]";
assert_roundtrip pp_rv rv_to_yojson rv_of_yojson
(RB 42) "[\"RB\", 42]";
assert_roundtrip pp_rv rv_to_yojson rv_of_yojson
(RC(42, "foo")) "[\"RC\", 42, \"foo\"]";
assert_roundtrip pp_rv rv_to_yojson rv_of_yojson
(RD{z="foo"}) "[\"RD\", {\"z\": \"foo\"}]"
#endif
type geo = {
lat : float [@key "Latitude"] ;
lon : float [@key "Longitude"] ;
......@@ -359,6 +375,16 @@ let test_recursive ctxt =
assert_roundtrip pp_bar bar_to_yojson bar_of_yojson
{lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}"
let test_int_redefined ctxt =
let module M = struct
type int = Break_things
let x = [%to_yojson: int] 1
end
in
let expected = `Int 1 in
assert_equal ~ctxt ~printer:show_json expected M.x
let suite = "Test ppx_yojson" >::: [
"test_unit" >:: test_unit;
"test_int" >:: test_int;
......@@ -376,6 +402,9 @@ let suite = "Test ppx_yojson" >::: [
"test_pvar" >:: test_pvar;
"test_var" >:: test_var;
"test_rec" >:: test_rec;
#if OCAML_VERSION >= (4, 03, 0)
"test_recvar" >:: test_recvar;
#endif
"test_key" >:: test_key;
"test_id" >:: test_id;
"test_custvar" >:: test_custvar;
......@@ -387,6 +416,7 @@ let suite = "Test ppx_yojson" >::: [
"test_nostrict" >:: test_nostrict;
"test_opentype" >:: test_opentype;
"test_recursive" >:: test_recursive;
"test_int_redefined" >:: test_int_redefined;
]
let _ =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment