This is an automated email from the git hooks/post-receive script.
glondu pushed a commit to branch master
in repository ppx-deriving.
commit 730019fc84dc7a417f0c39796d0d68fb8ad8c560
Author: Stephane Glondu <st...@glondu.net>
Date: Fri Jul 21 17:35:15 2017 +0200
New upstream version 4.1
---
CHANGELOG.md | 10 +++++++++
opam | 2 +-
pkg/build.ml | 8 ++++++-
src/ppx_deriving.cppo.ml | 11 +++++++++-
src/ppx_deriving.mli | 7 ++++++
src_plugins/ppx_deriving_map.cppo.ml | 41 ++++++++++++++++++++---------------
src_plugins/ppx_deriving_show.cppo.ml | 4 ++--
src_test/test_deriving_map.cppo.ml | 24 ++++++++++++++++++++
src_test/test_deriving_show.cppo.ml | 14 ++++++------
9 files changed, 91 insertions(+), 30 deletions(-)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index a74809d..3bba644 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,15 @@
Changelog
=========
+4.1
+---
+
+ * Fix type error with inheritied polymorphic variant type in
+ [@@deriving map].
+ * Fix incorrect handling of multi-argument constructors in
+ [@@deriving show].
+ * Add API hooks for ppx_type_conv.
+
4.0
---
@@ -11,6 +20,7 @@ Changelog
* Add support for loading findlib packages instead of just files in
ppx_deriving_main.
* Treat types explicitly qualified with Pervasives also as builtin.
+ * Compatibility with statically linked ppx drivers.
3.1
---
diff --git a/opam b/opam
index bb157ac..d687f07 100644
--- a/opam
+++ b/opam
@@ -1,6 +1,6 @@
opam-version: "1.2"
name: "ppx_deriving"
-version: "4.0"
+version: "4.1"
maintainer: "whitequark <whitequ...@whitequark.org>"
authors: [ "whitequark <whitequ...@whitequark.org>" ]
license: "MIT"
diff --git a/pkg/build.ml b/pkg/build.ml
index 9af83d8..0296a53 100755
--- a/pkg/build.ml
+++ b/pkg/build.ml
@@ -7,8 +7,14 @@ let () =
output_string oc (if Env.native then "<*.ml>: ppx_native" else "<*.ml>:
ppx_byte");
close_out oc
+let quote_parens s =
+ if Sys.win32 then
+ s
+ else
+ "'" ^ s ^ "'"
+
let ocamlbuild =
- "ocamlbuild -use-ocamlfind -classic-display -plugin-tag
'package(cppo_ocamlbuild)'"
+ "ocamlbuild -use-ocamlfind -classic-display -plugin-tag " ^ quote_parens
"package(cppo_ocamlbuild)"
let () =
Pkg.describe "ppx_deriving" ~builder:(`Other (ocamlbuild, "_build")) [
diff --git a/src/ppx_deriving.cppo.ml b/src/ppx_deriving.cppo.ml
index 4f8e939..63197f7 100644
--- a/src/ppx_deriving.cppo.ml
+++ b/src/ppx_deriving.cppo.ml
@@ -34,7 +34,16 @@ type deriver = {
let registry : (string, deriver) Hashtbl.t
= Hashtbl.create 16
-let register d = Hashtbl.add registry d.name d
+let hooks = Queue.create ()
+
+let add_register_hook f = Queue.add f hooks
+
+let register d =
+ Hashtbl.add registry d.name d;
+ Queue.iter (fun f -> f d) hooks
+
+let derivers () =
+ Hashtbl.fold (fun _ v acc -> v::acc) registry []
let lookup name =
try Some (Hashtbl.find registry name)
diff --git a/src/ppx_deriving.mli b/src/ppx_deriving.mli
index bde079b..f4d3878 100644
--- a/src/ppx_deriving.mli
+++ b/src/ppx_deriving.mli
@@ -42,6 +42,13 @@ type deriver = {
(** [register deriver] registers [deriver] according to its [name] field. *)
val register : deriver -> unit
+(** [add_register_hook hook] adds [hook] to be executed whenever a new deriver
+ is registered. *)
+val add_register_hook : (deriver -> unit) -> unit
+
+(** [derivers ()] returns all currently registered derivers. *)
+val derivers : unit -> deriver list
+
(** Creating {!deriver} structure. *)
val create :
string ->
diff --git a/src_plugins/ppx_deriving_map.cppo.ml
b/src_plugins/ppx_deriving_map.cppo.ml
index 3a696ce..24bc446 100644
--- a/src_plugins/ppx_deriving_map.cppo.ml
+++ b/src_plugins/ppx_deriving_map.cppo.ml
@@ -29,7 +29,7 @@ let pattl labels = List.map (fun { pld_name = { txt = n } }
-> n, pvar (argl n))
let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
let constrrec name fields = constr name [ record fields]
-let rec expr_of_typ typ =
+let rec expr_of_typ ?decl typ =
let typ = Ppx_deriving.remove_pervasives ~deriver typ in
match typ with
| _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun x -> x]
@@ -37,24 +37,24 @@ let rec expr_of_typ typ =
let builtin = not (attr_nobuiltin typ.ptyp_attributes) in
begin match builtin, typ with
| true, [%type: [%t? typ] list] ->
- [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ typ]]
+ [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ ?decl typ]]
| true, [%type: [%t? typ] array] ->
- [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ typ]]
+ [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ ?decl typ]]
| true, [%type: [%t? typ] option] ->
- [%expr function None -> None | Some x -> Some ([%e expr_of_typ typ] x)]
+ [%expr function None -> None | Some x -> Some ([%e expr_of_typ ?decl
typ] x)]
| true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
[%expr
function
- | Result.Ok ok -> Result.Ok ([%e expr_of_typ ok_t] ok)
- | Result.Error err -> Result.Error ([%e expr_of_typ err_t] err)]
+ | Result.Ok ok -> Result.Ok ([%e expr_of_typ ?decl ok_t] ok)
+ | Result.Error err -> Result.Error ([%e expr_of_typ ?decl err_t] err)]
| _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid)))
- (List.map expr_of_typ args)
+ (List.map (expr_of_typ ?decl) args)
| _ -> assert false
end
| { ptyp_desc = Ptyp_tuple typs } ->
[%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] ->
- [%e tuple (List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn
i)]) typs)]];
+ [%e tuple (List.mapi (fun i typ -> app (expr_of_typ ?decl typ) [evar
(argn i)]) typs)]];
| { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
let cases =
fields |> List.map (fun field ->
@@ -63,10 +63,15 @@ let rec expr_of_typ typ =
Exp.case (Pat.variant label None) (Exp.variant label None)
| Rtag (label, _, false, [typ]) ->
Exp.case (Pat.variant label (Some [%pat? x]))
- (Exp.variant label (Some [%expr [%e expr_of_typ typ] x]))
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
- Exp.case [%pat? [%p Pat.type_ tname] as x]
- [%expr [%e expr_of_typ typ] x]
+ (Exp.variant label (Some [%expr [%e expr_of_typ ?decl typ]
x]))
+ | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> begin
+ match decl with
+ | None ->
+ raise_errorf "inheritance of polymorphic variants not supported"
+ | Some(d) ->
+ Exp.case [%pat? [%p Pat.type_ tname] as x]
+ [%expr ([%e expr_of_typ ?decl typ] x :> [%t
Ppx_deriving.core_type_of_type_decl d])]
+ end
| _ ->
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ))
@@ -74,7 +79,7 @@ let rec expr_of_typ typ =
Exp.function_ cases
| { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name)
| { ptyp_desc = Ptyp_alias (typ, name) } ->
- [%expr fun x -> [%e evar ("poly_"^name)] ([%e expr_of_typ typ] x)]
+ [%expr fun x -> [%e evar ("poly_"^name)] ([%e expr_of_typ ?decl typ] x)]
| { ptyp_loc } ->
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ)
@@ -83,19 +88,19 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as
type_decl) =
parse_options options;
let mapper =
match type_decl.ptype_kind, type_decl.ptype_manifest with
- | Ptype_abstract, Some manifest -> expr_of_typ manifest
+ | Ptype_abstract, Some manifest -> expr_of_typ ~decl:type_decl manifest
| Ptype_variant constrs, _ ->
constrs |>
List.map (fun { pcd_name = { txt = name' }; pcd_args } ->
match pcd_args with
| Pcstr_tuple(typs) ->
- let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn
i)]) typs in
+ let args = List.mapi (fun i typ -> app (expr_of_typ ~decl:type_decl
typ) [evar (argn i)]) typs in
Exp.case (pconstr name' (pattn typs))
(constr name' args)
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record(labels) ->
let args = labels |> List.map (fun { pld_name = { txt = n };
pld_type = typ } ->
- n, [%expr [%e expr_of_typ typ] [%e evar (argl n)]]) in
+ n, [%expr [%e expr_of_typ ~decl:type_decl typ] [%e
evar (argl n)]]) in
Exp.case (pconstrrec name' (pattl labels))
(constrrec name' args)
#endif
@@ -104,7 +109,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as
type_decl) =
| Ptype_record labels, _ ->
let fields =
labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
- name, [%expr [%e expr_of_typ pld_type]
+ name, [%expr [%e expr_of_typ ~decl:type_decl pld_type]
[%e Exp.field (evar "x") (mknoloc (Lident name))]])
in
[%expr fun x -> [%e record fields]]
@@ -129,7 +134,7 @@ let sig_of_type ~options ~path type_decl =
let () =
Ppx_deriving.(register (create deriver
- ~core_type: expr_of_typ
+ ~core_type: (expr_of_typ ?decl:None)
~type_decl_str: (fun ~options ~path type_decls ->
[Str.value Recursive (List.concat (List.map (str_of_type ~options ~path)
type_decls))])
~type_decl_sig: (fun ~options ~path type_decls ->
diff --git a/src_plugins/ppx_deriving_show.cppo.ml
b/src_plugins/ppx_deriving_show.cppo.ml
index 55925cc..17642b9 100644
--- a/src_plugins/ppx_deriving_show.cppo.ml
+++ b/src_plugins/ppx_deriving_show.cppo.ml
@@ -229,10 +229,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as
type_decl) =
Format.fprintf fmt "@])"]
| args ->
[%expr
- Format.fprintf fmt [%e str ("@[<2>" ^ constr_name ^ "
(@,")];
+ Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ "
(@,")];
[%e args |> Ppx_deriving.(fold_exprs
(seq_reduce ~sep:[%expr Format.fprintf fmt ",@ "]))];
- Format.fprintf fmt "@,)@]"]
+ Format.fprintf fmt "@,))@]"]
in
Exp.case (pconstr name' (pattn typs)) printer
#if OCAML_VERSION >= (4, 03, 0)
diff --git a/src_test/test_deriving_map.cppo.ml
b/src_test/test_deriving_map.cppo.ml
index d6f7e9f..6408d63 100644
--- a/src_test/test_deriving_map.cppo.ml
+++ b/src_test/test_deriving_map.cppo.ml
@@ -26,6 +26,11 @@ module T : sig
type ('a,'b) record3 = { a3 : 'a; b3 : bool; c3 : 'b } [@@deriving map,show]
+ type ('a,'b) pvar0 = [ `A of 'a | `B of ('a,'b) pvar0 | `C of 'b ]
[@@deriving map,show]
+ type ('a,'b,'c) pvar1 = [ ('a,'b) pvar0 | `D of 'c | `E of ('b,'c) pvar0 ]
[@@deriving map,show]
+ type pvar2 = [ `F | `G ] [@@deriving map,show]
+ type ('a,'b,'c) pvar3 = [ pvar2 | ('a,'b,'c) pvar1 ] [@@deriving map,show]
+
end = struct
type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf
@@ -57,6 +62,11 @@ end = struct
type ('a,'b) record3 = { a3 : 'a; b3 : bool; c3 : 'b } [@@deriving map,show]
+ type ('a,'b) pvar0 = [ `A of 'a | `B of ('a,'b) pvar0 | `C of 'b ]
[@@deriving map,show]
+ type ('a,'b,'c) pvar1 = [ ('a,'b) pvar0 | `D of 'c | `E of ('b,'c) pvar0 ]
[@@deriving map,show]
+ type pvar2 = [ `F | `G ] [@@deriving map,show]
+ type ('a,'b,'c) pvar3 = [ pvar2 | ('a,'b,'c) pvar1 ] [@@deriving map,show]
+
end
open T
@@ -118,6 +128,19 @@ let test_record3 ctxt =
assert_equal ~printer:(show_record3 fmt_int fmt_flt)
{a3=97;b3=false;c3=4.} (map_record3 Char.code float_of_int
{a3='a';b3=false;c3=4})
+let test_pvar3 ctxt =
+ let show,map = show_pvar3 fmt_str fmt_int fmt_int,
+ map_pvar3 string_of_int Char.code int_of_string
+ in
+ assert_equal ~printer:show (`A "1") (map (`A 1));
+ assert_equal ~printer:show (`B (`A "1")) (map (`B (`A 1)));
+ assert_equal ~printer:show (`B (`C 97)) (map (`B (`C 'a')));
+ assert_equal ~printer:show (`D 1) (map (`D "1"));
+ assert_equal ~printer:show (`E (`A 97)) (map (`E (`A 'a')));
+ assert_equal ~printer:show (`E (`C 9)) (map (`E (`C "9")));
+ assert_equal ~printer:show `F (map `F);
+ assert_equal ~printer:show `G (map `G)
+
type 'a result0 = ('a, bool) Result.result [@@deriving show, map]
let test_map_result ctxt =
@@ -136,6 +159,7 @@ let suite = "Test deriving(map)" >::: [
"test_record1" >:: test_record1;
"test_record2" >:: test_record2;
"test_record3" >:: test_record3;
+ "test_pvar3" >:: test_pvar3;
"test_map_result" >:: test_map_result
]
diff --git a/src_test/test_deriving_show.cppo.ml
b/src_test/test_deriving_show.cppo.ml
index da2fd10..c5c2873 100644
--- a/src_test/test_deriving_show.cppo.ml
+++ b/src_test/test_deriving_show.cppo.ml
@@ -43,9 +43,9 @@ let test_alias ctxt =
type v = Foo | Bar of int * string | Baz of string [@@deriving show]
let test_variant ctxt =
- assert_equal ~printer "Test_deriving_show.Foo" (show_v Foo);
- assert_equal ~printer "Test_deriving_show.Bar (1, \"foo\")" (show_v (Bar (1,
"foo")));
- assert_equal ~printer "(Test_deriving_show.Baz \"foo\")" (show_v (Baz
"foo"))
+ assert_equal ~printer "Test_deriving_show.Foo" (show_v Foo);
+ assert_equal ~printer "(Test_deriving_show.Bar (1, \"foo\"))" (show_v (Bar
(1, "foo")));
+ assert_equal ~printer "(Test_deriving_show.Baz \"foo\")" (show_v (Baz
"foo"))
#if OCAML_VERSION >= (4, 03, 0)
type rv = RFoo | RBar of { x: int; y: string } | RBaz of { z: string }
[@@deriving show]
@@ -126,8 +126,8 @@ let print_hi = fun fmt _ -> Format.fprintf fmt "hi!"
type polypr = (string [@printer print_hi]) btree [@polyprinter pp_btree]
[@@deriving show]
let test_polypr ctxt =
- assert_equal ~printer "Test_deriving_show.Node (Test_deriving_show.Leaf,
hi!,\n\
- \ Test_deriving_show.Leaf)"
+ assert_equal ~printer "(Test_deriving_show.Node (Test_deriving_show.Leaf,
hi!,\n\
+ \ Test_deriving_show.Leaf))"
(show_polypr (Node (Leaf, "x", Leaf)))
let test_placeholder ctxt =
@@ -176,10 +176,10 @@ let test_std_shadowing ctxt =
let e1 = ESBool (Bfoo (1, (+) 1)) in
let e2 = ESString (Sfoo ("lalala", (+) 3)) in
assert_equal ~printer
- "(Test_deriving_show.ESBool Test_deriving_show.Bfoo (1, <fun>))"
+ "(Test_deriving_show.ESBool (Test_deriving_show.Bfoo (1, <fun>)))"
(show_es e1);
assert_equal ~printer
- "(Test_deriving_show.ESString Test_deriving_show.Sfoo (\"lalala\", <fun>))"
+ "(Test_deriving_show.ESString (Test_deriving_show.Sfoo (\"lalala\",
<fun>)))"
(show_es e2)
type poly_app = float poly_abs
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-ocaml-maint/packages/ppx-deriving.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
