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 <trei...@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@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 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 <whitequ...@whitequark.org>" authors: [ "whitequark <whitequ...@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 _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits