[Pkg-ocaml-maint-commits] [ppx-deriving-yojson] 01/07: New upstream version 3.1
Ralf Treinen
treinen at moszumanska.debian.org
Wed Mar 28 20:19:48 UTC 2018
This is an automated email from the git hooks/post-receive script.
treinen pushed a commit to branch master
in repository ppx-deriving-yojson.
commit c8083f140691c8973ae02eeb5e19d3b42aef6184
Author: Ralf Treinen <treinen at debian.org>
Date: Thu Dec 14 20:13:05 2017 +0100
New upstream version 3.1
---
.travis.yml | 3 +
CHANGELOG.md | 14 ++
README.md | 10 ++
_tags | 1 +
opam | 12 +-
pkg/META.in | 2 +-
src/ppx_deriving_yojson.cppo.ml | 155 ++++++++++++---------
...{test_ppx_yojson.ml => test_ppx_yojson.cppo.ml} | 30 ++++
8 files changed, 159 insertions(+), 68 deletions(-)
diff --git a/.travis.yml b/.travis.yml
index 8b882bc..3a54c7e 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -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
diff --git a/CHANGELOG.md b/CHANGELOG.md
index a8c36df..2600c8a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,11 +1,25 @@
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
---
diff --git a/README.md b/README.md
index cbb42af..985897a 100644
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/_tags b/_tags
index 43658b4..16037ac 100644
--- a/_tags
+++ b/_tags
@@ -3,3 +3,4 @@ true: warn(@5 at 8@10 at 11@12 at 14@23 at 24@26 at 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
diff --git a/opam b/opam
index ad869d7..f9ef582 100644
--- a/opam
+++ b/opam
@@ -1,6 +1,6 @@
opam-version: "1.2"
name: "ppx_deriving_yojson"
-version: "3.0"
+version: "3.1"
maintainer: "whitequark <whitequark at whitequark.org>"
authors: [ "whitequark <whitequark at 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"}
]
-
diff --git a/pkg/META.in b/pkg/META.in
index c2814e7..e7b0a78 100644
--- a/pkg/META.in
+++ b/pkg/META.in
@@ -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"
diff --git a/src/ppx_deriving_yojson.cppo.ml b/src/ppx_deriving_yojson.cppo.ml
index f8c34ed..2c334fb 100644
--- a/src/ppx_deriving_yojson.cppo.ml
+++ b/src/ppx_deriving_yojson.cppo.ml
@@ -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)
diff --git a/src_test/test_ppx_yojson.ml b/src_test/test_ppx_yojson.cppo.ml
similarity index 93%
rename from src_test/test_ppx_yojson.ml
rename to src_test/test_ppx_yojson.cppo.ml
index d66d5de..7f05646 100644
--- a/src_test/test_ppx_yojson.ml
+++ b/src_test/test_ppx_yojson.cppo.ml
@@ -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 _ =
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/ppx-deriving-yojson.git
More information about the Pkg-ocaml-maint-commits
mailing list