diff options
author | Stephane Glondu <steph@glondu.net> | 2019-08-20 11:14:38 +0200 |
---|---|---|
committer | Stephane Glondu <steph@glondu.net> | 2019-08-20 11:14:38 +0200 |
commit | d8ec95e219762a402fea7edd51d80b462c3e839a (patch) | |
tree | ccd303f6321ebb9b00d5ab2145f17db063b14351 /src_plugins | |
parent | 5c3452d8a43e801580493edabb79538d854ff77a (diff) |
New upstream version 4.4
Diffstat (limited to 'src_plugins')
-rw-r--r-- | src_plugins/compat_macros.cppo | 11 | ||||
-rw-r--r-- | src_plugins/create/dune | 14 | ||||
-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/dune | 151 | ||||
-rw-r--r-- | src_plugins/enum/dune | 14 | ||||
-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/dune | 14 | ||||
-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/dune | 13 | ||||
-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/dune | 13 | ||||
-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/dune | 13 | ||||
-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/dune | 13 | ||||
-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/dune | 14 | ||||
-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/dune | 14 | ||||
-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/dune | 15 | ||||
-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 |