summaryrefslogtreecommitdiff
path: root/src_plugins
diff options
context:
space:
mode:
authorStephane Glondu <steph@glondu.net>2019-08-20 11:14:38 +0200
committerStephane Glondu <steph@glondu.net>2019-08-20 11:14:38 +0200
commitd8ec95e219762a402fea7edd51d80b462c3e839a (patch)
treeccd303f6321ebb9b00d5ab2145f17db063b14351 /src_plugins
parent5c3452d8a43e801580493edabb79538d854ff77a (diff)
New upstream version 4.4
Diffstat (limited to 'src_plugins')
-rw-r--r--src_plugins/compat_macros.cppo11
-rw-r--r--src_plugins/create/dune14
-rw-r--r--src_plugins/create/ppx_deriving_create.cppo.ml (renamed from src_plugins/ppx_deriving_create.cppo.ml)2
-rw-r--r--src_plugins/dune151
-rw-r--r--src_plugins/enum/dune14
-rw-r--r--src_plugins/enum/ppx_deriving_enum.cppo.ml (renamed from src_plugins/ppx_deriving_enum.cppo.ml)41
-rw-r--r--src_plugins/eq/dune14
-rw-r--r--src_plugins/eq/ppx_deriving_eq.cppo.ml (renamed from src_plugins/ppx_deriving_eq.cppo.ml)27
-rw-r--r--src_plugins/fold/dune13
-rw-r--r--src_plugins/fold/ppx_deriving_fold.cppo.ml (renamed from src_plugins/ppx_deriving_fold.cppo.ml)23
-rw-r--r--src_plugins/iter/dune13
-rw-r--r--src_plugins/iter/ppx_deriving_iter.cppo.ml (renamed from src_plugins/ppx_deriving_iter.cppo.ml)23
-rw-r--r--src_plugins/make/dune13
-rw-r--r--src_plugins/make/ppx_deriving_make.cppo.ml (renamed from src_plugins/ppx_deriving_make.cppo.ml)2
-rw-r--r--src_plugins/map/dune13
-rw-r--r--src_plugins/map/ppx_deriving_map.cppo.ml (renamed from src_plugins/ppx_deriving_map.cppo.ml)23
-rw-r--r--src_plugins/ord/dune14
-rw-r--r--src_plugins/ord/ppx_deriving_ord.cppo.ml (renamed from src_plugins/ppx_deriving_ord.cppo.ml)38
-rw-r--r--src_plugins/show/dune14
-rw-r--r--src_plugins/show/ppx_deriving_show.cppo.ml (renamed from src_plugins/ppx_deriving_show.cppo.ml)25
-rw-r--r--src_plugins/std/dune15
-rw-r--r--src_plugins/std/ppx_deriving_std.ml (renamed from src_plugins/ppx_deriving_std.ml)0
22 files changed, 268 insertions, 235 deletions
diff --git a/src_plugins/compat_macros.cppo b/src_plugins/compat_macros.cppo
new file mode 100644
index 0000000..7869e1c
--- /dev/null
+++ b/src_plugins/compat_macros.cppo
@@ -0,0 +1,11 @@
+#if OCAML_VERSION < (4, 03, 0)
+#define Pcstr_tuple(core_types) core_types
+#endif
+
+#if OCAML_VERSION < (4, 08, 0)
+#define Rtag_patt(label, constant, args) Rtag(label, _, constant, args)
+#define Rinherit_patt(typ) Rinherit(typ)
+#else
+#define Rtag_patt(label, constant, args) {prf_desc = Rtag(label, constant, args); _}
+#define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _}
+#endif
diff --git a/src_plugins/create/dune b/src_plugins/create/dune
new file mode 100644
index 0000000..fc5e81e
--- /dev/null
+++ b/src_plugins/create/dune
@@ -0,0 +1,14 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_create.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version}
+ %{dep:ppx_deriving_create.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_create)
+ (public_name ppx_deriving.create)
+ (synopsis "[@@deriving create]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_create.cppo.ml b/src_plugins/create/ppx_deriving_create.cppo.ml
index f49a3d6..f9a3ff9 100644
--- a/src_plugins/ppx_deriving_create.cppo.ml
+++ b/src_plugins/create/ppx_deriving_create.cppo.ml
@@ -1,3 +1,5 @@
+#include "../compat_macros.cppo"
+
open Longident
open Location
open Asttypes
diff --git a/src_plugins/dune b/src_plugins/dune
index 06085ea..e69de29 100644
--- a/src_plugins/dune
+++ b/src_plugins/dune
@@ -1,151 +0,0 @@
-(rule
- (deps ppx_deriving_show.cppo.ml)
- (targets ppx_deriving_show.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_show)
- (public_name ppx_deriving.show)
- (synopsis "[@@deriving show]")
- (modules ppx_deriving_show)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_create.cppo.ml)
- (targets ppx_deriving_create.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_create)
- (public_name ppx_deriving.create)
- (synopsis "[@@deriving create]")
- (modules ppx_deriving_create)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_enum.cppo.ml)
- (targets ppx_deriving_enum.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_enum)
- (public_name ppx_deriving.enum)
- (synopsis "[@@deriving enum]")
- (modules ppx_deriving_enum)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_eq.cppo.ml)
- (targets ppx_deriving_eq.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_eq)
- (public_name ppx_deriving.eq)
- (synopsis "[@@deriving eq]")
- (modules ppx_deriving_eq)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_fold.cppo.ml)
- (targets ppx_deriving_fold.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_fold)
- (public_name ppx_deriving.fold)
- (synopsis "[@@deriving fold]")
- (modules ppx_deriving_fold)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_iter.cppo.ml)
- (targets ppx_deriving_iter.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_iter)
- (public_name ppx_deriving.iter)
- (synopsis "[@@deriving iter]")
- (modules ppx_deriving_iter)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_make.cppo.ml)
- (targets ppx_deriving_make.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_make)
- (public_name ppx_deriving.make)
- (synopsis "[@@deriving make]")
- (modules ppx_deriving_make)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_map.cppo.ml)
- (targets ppx_deriving_map.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_map)
- (public_name ppx_deriving.map)
- (synopsis "[@@deriving map]")
- (modules ppx_deriving_map)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(rule
- (deps ppx_deriving_ord.cppo.ml)
- (targets ppx_deriving_ord.ml)
- (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
-
-(library
- (name ppx_deriving_ord)
- (public_name ppx_deriving.ord)
- (synopsis "[@@deriving ord]")
- (modules ppx_deriving_ord)
- (preprocess
- (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
- (libraries compiler-libs.common ppx_tools ppx_deriving.api)
- (kind ppx_deriver))
-
-(library
- (name ppx_deriving_std)
- (public_name ppx_deriving.std)
- (synopsis "Meta-package for all built-in derivers")
- (modules ppx_deriving_std)
- (libraries
- ppx_deriving_ord
- ppx_deriving_map
- ppx_deriving_iter
- ppx_deriving_enum
- ppx_deriving_show
- ppx_deriving_eq
- ppx_deriving_make
- ppx_deriving_create
- ppx_deriving_fold)
- (kind ppx_deriver))
diff --git a/src_plugins/enum/dune b/src_plugins/enum/dune
new file mode 100644
index 0000000..21ff948
--- /dev/null
+++ b/src_plugins/enum/dune
@@ -0,0 +1,14 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_enum.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version}
+ %{dep:ppx_deriving_enum.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_enum)
+ (public_name ppx_deriving.enum)
+ (synopsis "[@@deriving enum]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml
index aec3fbc..ba71510 100644
--- a/src_plugins/ppx_deriving_enum.cppo.ml
+++ b/src_plugins/enum/ppx_deriving_enum.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -41,19 +39,36 @@ let mappings_of_type type_decl =
| Ptype_abstract, Some { ptyp_desc = Ptyp_variant (constrs, Closed, None); ptyp_loc } ->
`Polymorphic,
List.fold_left (fun (acc, mappings) row_field ->
- (* TODO: use row_field location instead of ptyp_loc when fixed in Parsetree *)
- match row_field with
- | Rinherit _ ->
+ let error_inherit loc =
raise_errorf ~loc:ptyp_loc
- "%s cannot be derived for inherited variant cases" deriver
+ "%s cannot be derived for inherited variant cases"
+ deriver
+ in
+ let error_arguments loc =
+ raise_errorf ~loc:ptyp_loc
+ "%s can be derived only for argumentless constructors"
+ deriver
+ in
+#if OCAML_VERSION < (4, 08, 0)
+ let loc = ptyp_loc in
+ match row_field with
+ | Rinherit _ -> error_inherit loc
| Rtag (name, attrs, true, []) ->
-#if OCAML_VERSION < (4, 06, 0)
- let name = mkloc name ptyp_loc in
-#endif
+ #if OCAML_VERSION < (4, 06, 0)
+ let name = mkloc name loc in
+ #endif
map acc mappings attrs name
- | Rtag _ ->
- raise_errorf ~loc:ptyp_loc
- "%s can be derived only for argumentless constructors" deriver)
+ | Rtag _ -> error_arguments loc
+#else
+ let loc = row_field.prf_loc in
+ let attrs = row_field.prf_attributes in
+ match row_field.prf_desc with
+ | Rinherit _ -> error_inherit loc
+ | Rtag (name, true, []) ->
+ map acc mappings attrs name
+ | Rtag _ -> error_arguments loc
+#endif
+)
(0, []) constrs
| _ -> raise_errorf ~loc:type_decl.ptype_loc
"%s can be derived only for variants" deriver
diff --git a/src_plugins/eq/dune b/src_plugins/eq/dune
new file mode 100644
index 0000000..9bf478b
--- /dev/null
+++ b/src_plugins/eq/dune
@@ -0,0 +1,14 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_eq.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version}
+ %{dep:ppx_deriving_eq.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_eq)
+ (public_name ppx_deriving.eq)
+ (synopsis "[@@deriving eq]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml
index 67efcb1..3646c01 100644
--- a/src_plugins/ppx_deriving_eq.cppo.ml
+++ b/src_plugins/eq/ppx_deriving_eq.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -56,8 +54,14 @@ let rec exprn quoter typs =
app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)])
and exprl quoter typs =
- typs |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
- app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)])
+ typs |> List.map (fun ({ pld_name = { txt = n }; pld_loc; _ } as pld) ->
+ with_default_loc pld_loc @@ fun () ->
+ app (expr_of_label_decl quoter pld)
+ [evar (argl `lhs n); evar (argl `rhs n)])
+
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
and expr_of_typ quoter typ =
let typ = Ppx_deriving.remove_pervasives ~deriver typ in
@@ -129,12 +133,12 @@ and expr_of_typ quoter typ =
#endif
in
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (pdup (fun _ -> variant label None)) [%expr true]
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (pdup (fun var -> variant label (Some (pvar var))))
(app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var)))
(app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
| _ ->
@@ -178,13 +182,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]]
| Ptype_record labels, _ ->
let exprs =
- labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes; pld_loc } ->
+ labels |> List.map (fun ({ pld_loc; pld_name = { txt = name }; _ } as pld) ->
with_default_loc pld_loc @@ fun () ->
(* combine attributes of type and label *)
- let attrs = pld_type.ptyp_attributes @ pld_attributes in
- let pld_type = {pld_type with ptyp_attributes=attrs} in
let field obj = Exp.field obj (mknoloc (Lident name)) in
- app (expr_of_typ quoter pld_type) [field (evar "lhs"); field (evar "rhs")])
+ app (expr_of_label_decl quoter pld)
+ [field (evar "lhs"); field (evar "rhs")])
in
[%expr fun lhs rhs -> [%e exprs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]]
| Ptype_abstract, None ->
diff --git a/src_plugins/fold/dune b/src_plugins/fold/dune
new file mode 100644
index 0000000..ee6912b
--- /dev/null
+++ b/src_plugins/fold/dune
@@ -0,0 +1,13 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_fold.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_fold.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_fold)
+ (public_name ppx_deriving.fold)
+ (synopsis "[@@deriving fold]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml
index c3b8d6f..a20c51b 100644
--- a/src_plugins/ppx_deriving_fold.cppo.ml
+++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -71,12 +69,12 @@ let rec expr_of_typ typ =
#endif
in
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (variant label None) [%expr acc]
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (variant label (Some [%pat? x]))
[%expr [%e expr_of_typ typ] acc x]
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case [%pat? [%p Pat.type_ tname] as x]
[%expr [%e expr_of_typ typ] acc x]
| _ ->
@@ -91,6 +89,10 @@ let rec expr_of_typ typ =
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ)
+and expr_of_label_decl { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ { pld_type with ptyp_attributes = attrs }
+
let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
parse_options options;
let mapper =
@@ -106,8 +108,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args)
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record(labels) ->
- let args = labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
- [%expr [%e expr_of_typ typ] acc [%e evar (argl n)]]) in
+ let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+ [%expr [%e expr_of_label_decl pld]
+ acc [%e evar (argl n)]]) in
Exp.case (pconstrrec name' (pattl labels))
Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args)
#endif
@@ -116,8 +119,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%expr fun acc -> [%e Exp.function_ cases]]
| Ptype_record labels, _ ->
let fields =
- labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
- [%expr [%e expr_of_typ pld_type] acc
+ labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+ [%expr [%e expr_of_label_decl pld] acc
[%e Exp.field (evar "x") (mknoloc (Lident name))]])
in
[%expr fun acc x -> [%e Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc fields)]]
diff --git a/src_plugins/iter/dune b/src_plugins/iter/dune
new file mode 100644
index 0000000..591b2b7
--- /dev/null
+++ b/src_plugins/iter/dune
@@ -0,0 +1,13 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_iter.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_iter.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_iter)
+ (public_name ppx_deriving.iter)
+ (synopsis "[@@deriving iter]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml
index 0c53c53..a6ec273 100644
--- a/src_plugins/ppx_deriving_iter.cppo.ml
+++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -68,12 +66,12 @@ let rec expr_of_typ typ =
#endif
in
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (variant label None) [%expr ()]
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (variant label (Some [%pat? x]))
[%expr [%e expr_of_typ typ] x]
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case [%pat? [%p Pat.type_ tname] as x]
[%expr [%e expr_of_typ typ] x]
| _ ->
@@ -88,6 +86,10 @@ let rec expr_of_typ typ =
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ)
+and expr_of_label_decl { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ { pld_type with ptyp_attributes = attrs }
+
let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
parse_options options;
let iterator =
@@ -107,8 +109,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
Exp.case (pconstr name' (pattn typs)) result
#if OCAML_VERSION >= (4, 03, 0)
| Pcstr_record(labels) ->
- let args = labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
- [%expr [%e expr_of_typ typ] [%e evar (argl n)]]) in
+ let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+ [%expr [%e expr_of_label_decl pld] [%e evar (argl n)]]) in
Exp.case (pconstrrec name' (pattl labels))
(Ppx_deriving.(fold_exprs seq_reduce) args)
#endif
@@ -116,8 +118,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
Exp.function_
| Ptype_record labels, _ ->
let fields =
- labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
- [%expr [%e expr_of_typ pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))]])
+ labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+ [%expr [%e expr_of_label_decl pld]
+ [%e Exp.field (evar "x") (mknoloc (Lident name))]])
in
[%expr fun x -> [%e Ppx_deriving.(fold_exprs seq_reduce) fields]]
| Ptype_abstract, None ->
diff --git a/src_plugins/make/dune b/src_plugins/make/dune
new file mode 100644
index 0000000..3323a49
--- /dev/null
+++ b/src_plugins/make/dune
@@ -0,0 +1,13 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_make.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_make.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_make)
+ (public_name ppx_deriving.make)
+ (synopsis "[@@deriving make]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_make.cppo.ml b/src_plugins/make/ppx_deriving_make.cppo.ml
index 77c49fb..5e55ab1 100644
--- a/src_plugins/ppx_deriving_make.cppo.ml
+++ b/src_plugins/make/ppx_deriving_make.cppo.ml
@@ -1,3 +1,5 @@
+#include "../compat_macros.cppo"
+
open Longident
open Location
open Asttypes
diff --git a/src_plugins/map/dune b/src_plugins/map/dune
new file mode 100644
index 0000000..08ca955
--- /dev/null
+++ b/src_plugins/map/dune
@@ -0,0 +1,13 @@
+(rule
+ (deps ppx_deriving_map.cppo.ml)
+ (targets ppx_deriving_map.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
+
+(library
+ (name ppx_deriving_map)
+ (public_name ppx_deriving.map)
+ (synopsis "[@@deriving map]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml
index 8539937..c35f5c5 100644
--- a/src_plugins/ppx_deriving_map.cppo.ml
+++ b/src_plugins/map/ppx_deriving_map.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -74,12 +72,12 @@ let rec expr_of_typ ?decl typ =
#endif
in
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (pat_variant label None) (exp_variant label None)
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (pat_variant label (Some [%pat? x]))
(exp_variant label (Some [%expr [%e expr_of_typ ?decl typ] x]))
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> begin
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> begin
match decl with
| None ->
raise_errorf "inheritance of polymorphic variants not supported"
@@ -99,6 +97,10 @@ let rec expr_of_typ ?decl typ =
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ)
+and expr_of_label_decl ?decl { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ ?decl { pld_type with ptyp_attributes = attrs }
+
let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
parse_options options;
let mapper =
@@ -114,8 +116,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
(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 ~decl:type_decl typ] [%e evar (argl n)]]) in
+ let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+ n, [%expr [%e expr_of_label_decl ~decl:type_decl pld]
+ [%e evar (argl n)]]) in
Exp.case (pconstrrec name' (pattl labels))
(constrrec name' args)
#endif
@@ -123,8 +126,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
Exp.function_
| Ptype_record labels, _ ->
let fields =
- labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
- name, [%expr [%e expr_of_typ ~decl:type_decl pld_type]
+ labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+ name, [%expr [%e expr_of_label_decl ~decl:type_decl pld]
[%e Exp.field (evar "x") (mknoloc (Lident name))]])
in
let annot_typ = Ppx_deriving.core_type_of_type_decl type_decl in
diff --git a/src_plugins/ord/dune b/src_plugins/ord/dune
new file mode 100644
index 0000000..0139269
--- /dev/null
+++ b/src_plugins/ord/dune
@@ -0,0 +1,14 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_ord.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version}
+ %{dep:ppx_deriving_ord.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_ord)
+ (public_name ppx_deriving.ord)
+ (synopsis "[@@deriving ord]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml
index 5c5e0be..89998ee 100644
--- a/src_plugins/ppx_deriving_ord.cppo.ml
+++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -40,7 +38,7 @@ let reduce_compare l =
let wildcard_case int_cases =
Exp.case [%pat? _] [%expr
let to_int = [%e Exp.function_ int_cases] in
- Pervasives.compare (to_int lhs) (to_int rhs)]
+ Ppx_deriving_runtime.compare (to_int lhs) (to_int rhs)]
let pattn side typs =
List.mapi (fun i _ -> pvar (argn side i)) typs
@@ -56,8 +54,13 @@ let rec exprn quoter typs =
app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)])
and exprl quoter typs =
- typs |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
- app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)])
+ typs |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+ app (expr_of_label_decl quoter pld)
+ [evar (argl `lhs n); evar (argl `rhs n)])
+
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
and expr_of_typ quoter typ =
let expr_of_typ = expr_of_typ quoter in
@@ -78,7 +81,7 @@ and expr_of_typ quoter typ =
| [%type: int64] | [%type: Int64.t] | [%type: nativeint]
| [%type: Nativeint.t] | [%type: float] | [%type: bool]
| [%type: char] | [%type: string] | [%type: bytes]) ->
- let compare_fn = [%expr fun (a:[%t typ]) b -> Pervasives.compare a b] in
+ let compare_fn = [%expr fun (a:[%t typ]) b -> Ppx_deriving_runtime.compare a b] in
Ppx_deriving.quote quoter compare_fn
| true, [%type: [%t? typ] ref] ->
[%expr fun a b -> [%e expr_of_typ typ] !a !b]
@@ -100,7 +103,7 @@ and expr_of_typ quoter typ =
[%expr [%e expr_of_typ typ] x.(i) y.(i)]]
in
[%e compare_reduce [%expr loop 0]
- [%expr Pervasives.compare (Array.length x) (Array.length y)]]]
+ [%expr Ppx_deriving_runtime.compare (Array.length x) (Array.length y)]]]
| true, [%type: [%t? typ] option] ->
[%expr fun x y ->
match x, y with
@@ -140,12 +143,12 @@ and expr_of_typ quoter typ =
fields |> List.map (fun field ->
let pdup f = ptuple [f "lhs"; f "rhs"] in
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (pdup (fun _ -> variant label None)) [%expr 0]
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (pdup (fun var -> variant label (Some (pvar var))))
(app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var)))
(app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
| _ ->
@@ -155,11 +158,11 @@ and expr_of_typ quoter typ =
let int_cases =
fields |> List.mapi (fun i field ->
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
Exp.case (variant label None) (int i)
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
Exp.case (variant label (Some [%pat? _])) (int i)
- | Rinherit { ptyp_desc = Ptyp_constr (tname, []) } ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, []) }) ->
Exp.case (Pat.type_ tname) (int i)
| _ -> assert false)
in
@@ -213,11 +216,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]]
| Ptype_record labels, _ ->
let exprs =
- labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } ->
- let attrs = pld_attributes @ pld_type.ptyp_attributes in
- let pld_type = {pld_type with ptyp_attributes=attrs} in
+ labels |> List.map (fun ({ pld_name = { txt = name }; _ } as pld) ->
let field obj = Exp.field obj (mknoloc (Lident name)) in
- app (expr_of_typ quoter pld_type) [field (evar "lhs"); field (evar "rhs")])
+ app (expr_of_label_decl quoter pld)
+ [field (evar "lhs"); field (evar "rhs")])
in
[%expr fun lhs rhs -> [%e reduce_compare exprs]]
| Ptype_abstract, None ->
diff --git a/src_plugins/show/dune b/src_plugins/show/dune
new file mode 100644
index 0000000..3bebba7
--- /dev/null
+++ b/src_plugins/show/dune
@@ -0,0 +1,14 @@
+(rule
+ (deps ../compat_macros.cppo)
+ (targets ppx_deriving_show.ml)
+ (action (run %{bin:cppo} -V OCAML:%{ocaml_version}
+ %{dep:ppx_deriving_show.cppo.ml} -o %{targets})))
+
+(library
+ (name ppx_deriving_show)
+ (public_name ppx_deriving.show)
+ (synopsis "[@@deriving show]")
+ (preprocess
+ (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
+ (libraries compiler-libs.common ppx_tools ppx_deriving.api)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml
index 12935a1..9e76224 100644
--- a/src_plugins/ppx_deriving_show.cppo.ml
+++ b/src_plugins/show/ppx_deriving_show.cppo.ml
@@ -1,6 +1,4 @@
-#if OCAML_VERSION < (4, 03, 0)
-#define Pcstr_tuple(core_types) core_types
-#endif
+#include "../compat_macros.cppo"
open Longident
open Location
@@ -175,13 +173,13 @@ let rec expr_of_typ quoter typ =
let cases =
fields |> List.map (fun field ->
match field with
- | Rtag (label, _, true (*empty*), []) ->
+ | Rtag_patt(label, true (*empty*), []) ->
#if OCAML_VERSION >= (4, 06, 0)
let label = label.txt in
#endif
Exp.case (Pat.variant label None)
[%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str ("`" ^ label)]]
- | Rtag (label, _, false, [typ]) ->
+ | Rtag_patt(label, false, [typ]) ->
#if OCAML_VERSION >= (4, 06, 0)
let label = label.txt in
#endif
@@ -189,7 +187,7 @@ let rec expr_of_typ quoter typ =
[%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("`" ^ label ^ " (@[<hov>")];
[%e expr_of_typ typ] x;
Ppx_deriving_runtime.Format.fprintf fmt "@])"]
- | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
+ | Rinherit_patt({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case [%pat? [%p Pat.type_ tname] as x]
[%expr [%e expr_of_typ typ] x]
| _ ->
@@ -203,6 +201,10 @@ let rec expr_of_typ quoter typ =
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ)
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+ let attrs = pld_type.ptyp_attributes @ pld_attributes in
+ expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
+
let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
let show_opts = parse_options options in
let quoter = Ppx_deriving.create_quoter () in
@@ -263,10 +265,11 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
#if OCAML_VERSION >= (4, 03, 0)
| None, Pcstr_record(labels) ->
let args =
- labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
+ labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
[%expr
Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n];
- [%e expr_of_typ quoter typ] [%e evar (argl n)];
+ [%e expr_of_label_decl quoter pld]
+ [%e evar (argl n)];
Ppx_deriving_runtime.Format.fprintf fmt "@]"
])
in
@@ -284,12 +287,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%expr fun fmt -> [%e Exp.function_ cases]]
| Ptype_record labels, _ ->
let fields =
- labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
+ labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) ->
let field_name = if i = 0 then expand_path show_opts ~path name else name in
- let pld_type = {pld_type with ptyp_attributes=pld_attributes@pld_type.ptyp_attributes} in
[%expr
Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name];
- [%e expr_of_typ quoter pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))];
+ [%e expr_of_label_decl quoter pld]
+ [%e Exp.field (evar "x") (mknoloc (Lident name))];
Ppx_deriving_runtime.Format.fprintf fmt "@]"
])
in
diff --git a/src_plugins/std/dune b/src_plugins/std/dune
new file mode 100644
index 0000000..42662a2
--- /dev/null
+++ b/src_plugins/std/dune
@@ -0,0 +1,15 @@
+(library
+ (name ppx_deriving_std)
+ (public_name ppx_deriving.std)
+ (synopsis "Meta-package for all built-in derivers")
+ (libraries
+ ppx_deriving_ord
+ ppx_deriving_map
+ ppx_deriving_iter
+ ppx_deriving_enum
+ ppx_deriving_show
+ ppx_deriving_eq
+ ppx_deriving_make
+ ppx_deriving_create
+ ppx_deriving_fold)
+ (kind ppx_deriver))
diff --git a/src_plugins/ppx_deriving_std.ml b/src_plugins/std/ppx_deriving_std.ml
index e3ea20e..e3ea20e 100644
--- a/src_plugins/ppx_deriving_std.ml
+++ b/src_plugins/std/ppx_deriving_std.ml