From 2e4db4000cdc5a74cdd4951c7ea2415f62584596 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 09:33:59 +0300 Subject: [PATCH 01/17] Register plugins directly with ppxlib --- .../create/ppx_deriving_create.cppo.ml | 20 ++++++++------ src_plugins/enum/ppx_deriving_enum.cppo.ml | 20 ++++++++------ src_plugins/eq/ppx_deriving_eq.cppo.ml | 22 +++++++++------- src_plugins/fold/ppx_deriving_fold.cppo.ml | 22 +++++++++------- src_plugins/iter/ppx_deriving_iter.cppo.ml | 22 +++++++++------- src_plugins/make/ppx_deriving_make.cppo.ml | 20 ++++++++------ src_plugins/map/ppx_deriving_map.cppo.ml | 22 +++++++++------- src_plugins/ord/ppx_deriving_ord.cppo.ml | 22 +++++++++------- src_plugins/show/ppx_deriving_show.cppo.ml | 26 +++++++++++-------- src_test/deriving/test_ppx_deriving.ml | 9 ++++--- 10 files changed, 121 insertions(+), 84 deletions(-) diff --git a/src_plugins/create/ppx_deriving_create.cppo.ml b/src_plugins/create/ppx_deriving_create.cppo.ml index a62ee9dc..39b73ebc 100644 --- a/src_plugins/create/ppx_deriving_create.cppo.ml +++ b/src_plugins/create/ppx_deriving_create.cppo.ml @@ -118,11 +118,15 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -let () = - Ppx_deriving.(register (create deriver - ~type_decl_str: (fun ~options ~path type_decls -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) - ~type_decl_sig: (fun ~options ~path type_decls -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/enum/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml index 40d847ec..e8e8a572 100644 --- a/src_plugins/enum/ppx_deriving_enum.cppo.ml +++ b/src_plugins/enum/ppx_deriving_enum.cppo.ml @@ -119,11 +119,15 @@ let sig_of_type ~options ~path type_decl = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl)) [%type: Ppx_deriving_runtime.int -> [%t typ] Ppx_deriving_runtime.option])] -let () = - Ppx_deriving.(register (create deriver - ~type_decl_str: (fun ~options ~path type_decls -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) - ~type_decl_sig: (fun ~options ~path type_decls -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index 559bbf10..fa45f1e8 100644 --- a/src_plugins/eq/ppx_deriving_eq.cppo.ml +++ b/src_plugins/eq/ppx_deriving_eq.cppo.ml @@ -203,12 +203,16 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (Pat.constraint_ eq_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: (Ppx_deriving.with_quoter expr_of_typ) - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc:_ ~path:_ -> Ppx_deriving.with_quoter expr_of_typ) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml index 65be6947..e800207e 100644 --- a/src_plugins/fold/ppx_deriving_fold.cppo.ml +++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml @@ -142,12 +142,16 @@ let sig_of_type ~options ~path type_decl = [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc) (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: expr_of_typ - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml index 340db0ae..48797ef0 100644 --- a/src_plugins/iter/ppx_deriving_iter.cppo.ml +++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml @@ -134,12 +134,16 @@ let sig_of_type ~options ~path type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize [%type: [%t typ] -> Ppx_deriving_runtime.unit]))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: expr_of_typ - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/make/ppx_deriving_make.cppo.ml b/src_plugins/make/ppx_deriving_make.cppo.ml index 907f906b..1a9122aa 100644 --- a/src_plugins/make/ppx_deriving_make.cppo.ml +++ b/src_plugins/make/ppx_deriving_make.cppo.ml @@ -134,11 +134,15 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -let () = - Ppx_deriving.(register (create deriver - ~type_decl_str: (fun ~options ~path type_decls -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) - ~type_decl_sig: (fun ~options ~path type_decls -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml index 41ac1f43..aa597347 100644 --- a/src_plugins/map/ppx_deriving_map.cppo.ml +++ b/src_plugins/map/ppx_deriving_map.cppo.ml @@ -141,12 +141,16 @@ let sig_of_type ~options ~path type_decl = let typ = List.fold_right arrow poly_fns (arrow typ_arg typ_ret) in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -let () = - Ppx_deriving.(register (create deriver - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ ?decl:None) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index c36d57d6..8c1148e0 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -239,12 +239,16 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (Pat.constraint_ out_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: (Ppx_deriving.with_quoter expr_of_typ) - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc:_ ~path:_ -> Ppx_deriving.with_quoter expr_of_typ) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 7b0f5742..0c9c54d0 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -317,14 +317,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] -let () = - let loc = !Ast_helper.default_loc in - Ppx_deriving.(register (create deriver - ~core_type: (Ppx_deriving.with_quoter (fun quoter typ -> - [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) - ~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 -> - List.concat (List.map (sig_of_type ~options ~path) type_decls)) - () - )) +(* TODO: remove always [] ~options argument *) +let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path:[path]) type_decls))]) (* TODO: path is list? *) + +let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> + List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) + +(* TODO: Args *) +let deriving: Deriving.t = + Deriving.add + deriver + ~extension:(fun ~loc ~path:_ -> (Ppx_deriving.with_quoter (fun quoter typ -> + [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x]))) + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator diff --git a/src_test/deriving/test_ppx_deriving.ml b/src_test/deriving/test_ppx_deriving.ml index 5e2125c5..ca69a720 100644 --- a/src_test/deriving/test_ppx_deriving.ml +++ b/src_test/deriving/test_ppx_deriving.ml @@ -1,16 +1,17 @@ open OUnit2 let test_inline ctxt = - let sort = List.sort [%derive.ord: int * int] in - assert_equal ~printer:[%derive.show: (int * int) list] + let sort = List.sort [%ord: int * int] in (* TODO: support derive.org again *) + assert_equal ~printer:[%show: (int * int) list] (* TODO: support derive.show again *) [(1,1);(2,0);(3,5)] (sort [(2,0);(3,5);(1,1)]) let test_inline_shorthand ctxt = assert_equal ~printer:(fun x -> x) "[(1, 1); (2, 0)]" ([%show: (int * int) list] [(1,1); (2,0)]) -type optional_deriver = string -[@@deriving missing { optional = true }] +(* TODO: how did this work and why did it break now? *) +(* type optional_deriver = string +[@@deriving missing { optional = true }] *) type prefix = { field : int [@deriving.eq.compare fun _ _ -> true] From 5cd7fa817152f54f8bd45d8e2cece8f311fdbaae Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 10:11:31 +0300 Subject: [PATCH 02/17] Add ppxlib-based with_path arg to show plugin --- src/api/ppx_deriving.cppo.mli | 2 ++ src_plugins/show/ppx_deriving_show.cppo.ml | 36 +++++++++++++++++----- 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index d31e998b..1930b859 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -386,3 +386,5 @@ module Ast_convenience : sig val optional : string -> arg_label end end + +val module_from_input_name: unit -> label list diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 0c9c54d0..36bb9c9b 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -15,8 +15,9 @@ type options = { with_path : bool } field.) By default, this option is [true], which means that full paths are shown. *) -let expand_path show_opts ~path name = - let path = if show_opts.with_path then path else [] in +(* TODO: remove show_opts *) +let expand_path show_opts ~with_path ~path name = + let path = if with_path then path else [] in Ppx_deriving.expand_path ~path name let parse_options options = @@ -202,7 +203,7 @@ 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 str_of_type ~options ~with_path ~path ({ ptype_loc = loc } as type_decl) = let show_opts = parse_options options in let quoter = Ppx_deriving.create_quoter () in let path = Ppx_deriving.path_of_type_decl ~path type_decl in @@ -214,7 +215,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let cases = constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> let constr_name = - expand_path show_opts ~path name' + expand_path show_opts ~with_path ~path name' in match attr_printer pcd_attributes, pcd_args with @@ -281,7 +282,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 }; _} as pld) -> - let field_name = if i = 0 then expand_path show_opts ~path name else name in + let field_name = if i = 0 then expand_path show_opts ~with_path ~path name else name in [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_label_decl quoter pld] @@ -317,14 +318,33 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] +(* TODO: add to ppxlib? *) +let ebool: _ Ast_pattern.t -> _ Ast_pattern.t = + Ast_pattern.map1 ~f:(fun e -> + match Ppx_deriving.Arg.bool e with + | Ok b -> b + | Error _ -> failwith "not bool") +let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) +(* TODO: add arg_default to ppxlib? *) + (* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path:[path]) type_decls))]) (* TODO: path is list? *) +let impl_generator = Deriving.Generator.V2.make (args ()) (fun ~ctxt (_, type_decls) with_path -> + let path = + (* based on https://github.com/thierry-martinez/ppx_show/blob/db00365470bcbf602d931c1bfd155be459379c5c/src/ppx_show.ml#L384-L387 *) + let code_path = Ppxlib.Expansion_context.Deriver.code_path ctxt in + (* main_module_name contains ".cppo" due to #line directives? *) + (* Ppxlib.Code_path.(main_module_name code_path :: submodule_path code_path) *) + Ppxlib.Code_path.(Ppx_deriving.module_from_input_name () @ submodule_path code_path) + in + let with_path = match with_path with + | Some with_path -> with_path + | None -> true (* true by default *) + in + [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~with_path ~path) type_decls))]) let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) -(* TODO: Args *) let deriving: Deriving.t = Deriving.add deriver From 8e1e68f1972f2761064ae568ee6603174ae70e53 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 10:23:38 +0300 Subject: [PATCH 03/17] Remove unused ~options and ~path arguments from plugins --- .../create/ppx_deriving_create.cppo.ml | 20 +++------ src_plugins/enum/ppx_deriving_enum.cppo.ml | 20 +++------ src_plugins/eq/ppx_deriving_eq.cppo.ml | 27 ++++-------- src_plugins/fold/ppx_deriving_fold.cppo.ml | 20 +++------ src_plugins/iter/ppx_deriving_iter.cppo.ml | 20 +++------ src_plugins/make/ppx_deriving_make.cppo.ml | 20 +++------ src_plugins/map/ppx_deriving_map.cppo.ml | 20 +++------ src_plugins/ord/ppx_deriving_ord.cppo.ml | 26 ++++------- src_plugins/show/ppx_deriving_show.cppo.ml | 44 ++++++------------- 9 files changed, 68 insertions(+), 149 deletions(-) diff --git a/src_plugins/create/ppx_deriving_create.cppo.ml b/src_plugins/create/ppx_deriving_create.cppo.ml index 39b73ebc..d7e6520b 100644 --- a/src_plugins/create/ppx_deriving_create.cppo.ml +++ b/src_plugins/create/ppx_deriving_create.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "create" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_default attrs = Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) @@ -29,8 +24,7 @@ let find_main labels = main, label :: labels) (None, []) labels -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let creator = match type_decl.ptype_kind with @@ -78,8 +72,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let wrap_predef_option typ = typ -let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let sig_of_type ({ ptype_loc = loc } as type_decl) = let typ = Ppx_deriving.core_type_of_type_decl type_decl in let typ = match type_decl.ptype_kind with @@ -118,12 +111,11 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/enum/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml index e8e8a572..e81fe0b7 100644 --- a/src_plugins/enum/ppx_deriving_enum.cppo.ml +++ b/src_plugins/enum/ppx_deriving_enum.cppo.ml @@ -11,11 +11,6 @@ module Stdlib = Pervasives let deriver = "enum" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_value attrs = Ppx_deriving.(attrs |> attr ~deriver "value" |> Arg.(get_attr ~deriver int)) @@ -77,8 +72,7 @@ let mappings_of_type type_decl = mappings |> List.stable_sort (fun (a,_) (b,_) -> Stdlib.compare a b) |> check_dup; kind, mappings -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let str_of_type ({ ptype_loc = loc } as type_decl) = let kind, mappings = mappings_of_type type_decl in let patt name = match kind with @@ -106,9 +100,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl)) (Exp.function_ from_enum_cases)] -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = let loc = type_decl.ptype_loc in - parse_options options; let typ = Ppx_deriving.core_type_of_type_decl type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "min") type_decl)) [%type: Ppx_deriving_runtime.int]); @@ -119,12 +112,11 @@ let sig_of_type ~options ~path type_decl = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl)) [%type: Ppx_deriving_runtime.int -> [%t typ] Ppx_deriving_runtime.option])] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index fa45f1e8..0002d5a3 100644 --- a/src_plugins/eq/ppx_deriving_eq.cppo.ml +++ b/src_plugins/eq/ppx_deriving_eq.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "eq" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -33,19 +28,17 @@ let pattl side labels = let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] -let core_type_of_decl ~options ~path type_decl = +let core_type_of_decl type_decl = let loc = !Ast_helper.default_loc in - parse_options options; let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.bool]) type_decl [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.bool] -let sig_of_type ~options ~path type_decl = - parse_options options; +let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl)) - (core_type_of_decl ~options ~path type_decl))] + (core_type_of_decl type_decl))] let rec exprn quoter typs = typs |> List.mapi (fun i typ -> @@ -146,8 +139,7 @@ and expr_of_typ quoter typ = raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let comparator = match type_decl.ptype_kind, type_decl.ptype_manifest with @@ -196,19 +188,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in let out_type = Ppx_deriving.strong_type_of_type @@ - core_type_of_decl ~options ~path type_decl in + core_type_of_decl type_decl in let eq_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ eq_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml index e800207e..3500ea84 100644 --- a/src_plugins/fold/ppx_deriving_fold.cppo.ml +++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "fold" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -89,8 +84,7 @@ 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 str_of_type ({ ptype_loc = loc } as type_decl) = let mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest @@ -128,8 +122,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] -let sig_of_type ~options ~path type_decl = - parse_options options; +let sig_of_type type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let vars = @@ -142,12 +135,11 @@ let sig_of_type ~options ~path type_decl = [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc) (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml index 48797ef0..9de101c9 100644 --- a/src_plugins/iter/ppx_deriving_iter.cppo.ml +++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "iter" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -84,8 +79,7 @@ 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 str_of_type ({ ptype_loc = loc } as type_decl) = let iterator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest @@ -125,21 +119,19 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize iterator)] -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = let loc = !Ast_helper.default_loc in - parse_options options; let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Ppx_deriving_runtime.unit]) type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize [%type: [%t typ] -> Ppx_deriving_runtime.unit]))] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/make/ppx_deriving_make.cppo.ml b/src_plugins/make/ppx_deriving_make.cppo.ml index 1a9122aa..07091eaf 100644 --- a/src_plugins/make/ppx_deriving_make.cppo.ml +++ b/src_plugins/make/ppx_deriving_make.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "make" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_default attrs = Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) @@ -41,8 +36,7 @@ let is_optional { pld_name = { txt = name }; pld_type; pld_attributes } = | [%type: [%t? _] option] -> true | _ -> false) -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let creator = match type_decl.ptype_kind with @@ -93,8 +87,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let wrap_predef_option typ = typ -let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let sig_of_type ({ ptype_loc = loc } as type_decl) = let typ = Ppx_deriving.core_type_of_type_decl type_decl in let typ = match type_decl.ptype_kind with @@ -134,12 +127,11 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml index aa597347..28af0b29 100644 --- a/src_plugins/map/ppx_deriving_map.cppo.ml +++ b/src_plugins/map/ppx_deriving_map.cppo.ml @@ -7,11 +7,6 @@ open Ppx_deriving.Ast_convenience let deriver = "map" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -91,8 +86,7 @@ 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 str_of_type ({ ptype_loc = loc } as type_decl) = let mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ ~decl:type_decl manifest @@ -130,9 +124,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = let loc = type_decl.ptype_loc in - parse_options options; let typ_arg, var_arg, bound = Ppx_deriving.instantiate [] type_decl in let typ_ret, var_ret, _ = Ppx_deriving.instantiate bound type_decl in let arrow = Typ.arrow Label.nolabel in @@ -141,12 +134,11 @@ let sig_of_type ~options ~path type_decl = let typ = List.fold_right arrow poly_fns (arrow typ_arg typ_ret) in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index 8c1148e0..469d8ce2 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -8,11 +8,6 @@ open Ppx_deriving.Ast_convenience let deriver = "ord" let raise_errorf = Ppx_deriving.raise_errorf -let parse_options options = - options |> List.iter (fun (name, expr) -> - match name with - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -170,20 +165,18 @@ and expr_of_typ quoter typ = raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) -let core_type_of_decl ~options ~path type_decl = - parse_options options; +let core_type_of_decl type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.int]) type_decl in (polymorphize [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.int]) -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl)) - (core_type_of_decl ~options ~path type_decl))] + (core_type_of_decl type_decl))] -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - parse_options options; +let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let comparator = match type_decl.ptype_kind, type_decl.ptype_manifest with @@ -232,19 +225,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = in let out_type = Ppx_deriving.strong_type_of_type @@ - core_type_of_decl ~options ~path type_decl in + core_type_of_decl type_decl in let out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ out_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] -(* TODO: remove always [] ~options argument *) -let impl_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~path) type_decls))]) +let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 36bb9c9b..3080d36d 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -7,27 +7,16 @@ open Ppx_deriving.Ast_convenience let deriver = "show" let raise_errorf = Ppx_deriving.raise_errorf -type options = { with_path : bool } - (* The option [with_path] controls whether a full path should be displayed as part of data constructor names and record field names. (In the case of record fields, it is displayed only as part of the name of the first field.) By default, this option is [true], which means that full paths are shown. *) -(* TODO: remove show_opts *) -let expand_path show_opts ~with_path ~path name = +let expand_path ~with_path ~path name = let path = if with_path then path else [] in Ppx_deriving.expand_path ~path name -let parse_options options = - let with_path = ref true in - options |> List.iter (fun (name, expr) -> - match name with - | "with_path" -> with_path := Ppx_deriving.Arg.(get_expr ~deriver bool) expr - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); - { with_path = !with_path } - let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) @@ -53,30 +42,27 @@ let wrap_printer quoter printer = Ppx_deriving.quote ~quoter [%expr (let fprintf = Ppx_deriving_runtime.Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] -let pp_type_of_decl ~options ~path type_decl = +let pp_type_of_decl type_decl = let loc = type_decl.ptype_loc in - let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] -let show_type_of_decl ~options ~path type_decl = +let show_type_of_decl type_decl = let loc = type_decl.ptype_loc in - let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] -let sig_of_type ~options ~path type_decl = - let _ = parse_options options in +let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) - (pp_type_of_decl ~options ~path type_decl)); + (pp_type_of_decl type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) - (show_type_of_decl ~options ~path type_decl))] + (show_type_of_decl type_decl))] let rec expr_of_typ quoter typ = let loc = typ.ptyp_loc in @@ -203,8 +189,7 @@ 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 ~with_path ~path ({ ptype_loc = loc } as type_decl) = - let show_opts = parse_options options in +let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let path = Ppx_deriving.path_of_type_decl ~path type_decl in let prettyprinter = @@ -215,7 +200,7 @@ let str_of_type ~options ~with_path ~path ({ ptype_loc = loc } as type_decl) = let cases = constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> let constr_name = - expand_path show_opts ~with_path ~path name' + expand_path ~with_path ~path name' in match attr_printer pcd_attributes, pcd_args with @@ -282,7 +267,7 @@ let str_of_type ~options ~with_path ~path ({ ptype_loc = loc } as type_decl) = | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) -> - let field_name = if i = 0 then expand_path show_opts ~with_path ~path name else name in + let field_name = if i = 0 then expand_path ~with_path ~path name else name in [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_label_decl quoter pld] @@ -305,10 +290,10 @@ let str_of_type ~options ~with_path ~path ({ ptype_loc = loc } as type_decl) = let stringprinter = [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" [%e pp_poly_apply] x] in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let pp_type = - Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~options ~path type_decl in + Ppx_deriving.strong_type_of_type @@ pp_type_of_decl type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ - show_type_of_decl ~options ~path type_decl in + show_type_of_decl type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = @@ -327,7 +312,6 @@ let ebool: _ Ast_pattern.t -> _ Ast_pattern.t = let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) (* TODO: add arg_default to ppxlib? *) -(* TODO: remove always [] ~options argument *) let impl_generator = Deriving.Generator.V2.make (args ()) (fun ~ctxt (_, type_decls) with_path -> let path = (* based on https://github.com/thierry-martinez/ppx_show/blob/db00365470bcbf602d931c1bfd155be459379c5c/src/ppx_show.ml#L384-L387 *) @@ -340,10 +324,10 @@ let impl_generator = Deriving.Generator.V2.make (args ()) (fun ~ctxt (_, type_de | Some with_path -> with_path | None -> true (* true by default *) in - [Str.value Recursive (List.concat (List.map (str_of_type ~options:[] ~with_path ~path) type_decls))]) + [Str.value Recursive (List.concat (List.map (str_of_type ~with_path ~path) type_decls))]) -let intf_generator = Deriving.Generator.make_noarg (fun ~loc:_ ~path (_, type_decls) -> - List.concat (List.map (sig_of_type ~options:[] ~path) type_decls)) +let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> + List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add From 1ff769bcea5de9f724696b38be5261ae703719bc Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 11:08:26 +0300 Subject: [PATCH 04/17] Declare plugin attributes directly with ppxlib --- .../create/ppx_deriving_create.cppo.ml | 55 +++++++++++----- src_plugins/enum/ppx_deriving_enum.cppo.ml | 16 +++-- src_plugins/eq/ppx_deriving_eq.cppo.ml | 15 +++-- src_plugins/fold/ppx_deriving_fold.cppo.ml | 9 ++- src_plugins/iter/ppx_deriving_iter.cppo.ml | 9 ++- src_plugins/make/ppx_deriving_make.cppo.ml | 66 +++++++++++++------ src_plugins/map/ppx_deriving_map.cppo.ml | 9 ++- src_plugins/ord/ppx_deriving_ord.cppo.ml | 15 +++-- src_plugins/show/ppx_deriving_show.cppo.ml | 37 +++++++---- 9 files changed, 153 insertions(+), 78 deletions(-) diff --git a/src_plugins/create/ppx_deriving_create.cppo.ml b/src_plugins/create/ppx_deriving_create.cppo.ml index d7e6520b..c8ba4c43 100644 --- a/src_plugins/create/ppx_deriving_create.cppo.ml +++ b/src_plugins/create/ppx_deriving_create.cppo.ml @@ -7,16 +7,33 @@ open Ppx_deriving.Ast_convenience let deriver = "create" let raise_errorf = Ppx_deriving.raise_errorf -let attr_default attrs = - Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) +let attr_default context = Attribute.declare "deriving.create.default" context + Ast_pattern.(single_expr_payload __) (fun e -> e) +let ct_attr_default = attr_default Attribute.Context.core_type +let label_attr_default = attr_default Attribute.Context.label_declaration -let attr_split attrs = - Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver) +let attr_split context = Attribute.declare "deriving.create.split" context + Ast_pattern.(pstr nil) () +let ct_attr_split = attr_split Attribute.Context.core_type +let label_attr_split = attr_split Attribute.Context.label_declaration + +let attr_main context = Attribute.declare "deriving.create.main" context + Ast_pattern.(pstr nil) () +let ct_attr_main = attr_main Attribute.Context.core_type +let label_attr_main = attr_main Attribute.Context.label_declaration + +let attribute_get2 attr1 x1 attr2 x2 = + match Attribute.get attr1 x1, Attribute.get attr2 x2 with + | Some _ as y, _ -> y + | None, y -> y let find_main labels = List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) -> - if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> - attr ~deriver "main" |> Arg.get_flag ~deriver) then + let is_main = match attribute_get2 ct_attr_main pld_type label_attr_main label with + | Some () -> true + | None -> false + in + if is_main then match main with | Some _ -> raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" deriver | None -> Some label, labels @@ -40,14 +57,17 @@ let str_of_type ({ ptype_loc = loc } as type_decl) = | None -> Exp.fun_ Label.nolabel None (punit ()) (record fields) in - List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } -> - let attrs = pld_attributes @ pld_type.ptyp_attributes in - let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in - match attr_default attrs with + List.fold_left (fun accum ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) -> + match attribute_get2 label_attr_default label ct_attr_default pld_type with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> - if attr_split attrs then + let split = match attribute_get2 label_attr_split label ct_attr_split pld_type with + | Some () -> true + | None -> false + in + let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in + if split then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in @@ -85,13 +105,16 @@ let sig_of_type ({ ptype_loc = loc } as type_decl) = | None -> Typ.arrow Label.nolabel (tconstr "unit" []) typ in - List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } -> - let attrs = pld_type.ptyp_attributes @ pld_attributes in - let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in - match attr_default attrs with + List.fold_left (fun accum ({ pld_name = { txt = name; loc }; pld_type; pld_attributes } as label) -> + match attribute_get2 ct_attr_default pld_type label_attr_default label with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> - if attr_split attrs then + let split = match attribute_get2 ct_attr_split pld_type label_attr_split label with + | Some () -> true + | None -> false + in + let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in + if split then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in diff --git a/src_plugins/enum/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml index e81fe0b7..206f56c2 100644 --- a/src_plugins/enum/ppx_deriving_enum.cppo.ml +++ b/src_plugins/enum/ppx_deriving_enum.cppo.ml @@ -11,13 +11,15 @@ module Stdlib = Pervasives let deriver = "enum" let raise_errorf = Ppx_deriving.raise_errorf -let attr_value attrs = - Ppx_deriving.(attrs |> attr ~deriver "value" |> Arg.(get_attr ~deriver int)) +let attr_value context = Attribute.declare "deriving.enum.value" context + Ast_pattern.(single_expr_payload (eint __)) (fun i -> i) +let constr_attr_value = attr_value Attribute.Context.constructor_declaration +let rtag_attr_value = attr_value Attribute.Context.rtag let mappings_of_type type_decl = - let map acc mappings attrs constr_name = + let map acc mappings attr_value x attrs constr_name = let value = - match attr_value attrs with + match Attribute.get attr_value x with | Some idx -> idx | None -> acc in (value + 1, (value, constr_name) :: mappings) @@ -26,11 +28,11 @@ let mappings_of_type type_decl = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_variant constrs, _ -> `Regular, - List.fold_left (fun (acc, mappings) { pcd_name; pcd_args; pcd_attributes; pcd_loc } -> + List.fold_left (fun (acc, mappings) ({ pcd_name; pcd_args; pcd_attributes; pcd_loc } as constr) -> if pcd_args <> Pcstr_tuple([]) then raise_errorf ~loc:pcd_loc "%s can be derived only for argumentless constructors" deriver; - map acc mappings pcd_attributes pcd_name) + map acc mappings constr_attr_value constr pcd_attributes pcd_name) (0, []) constrs | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (constrs, Closed, None); ptyp_loc } -> `Polymorphic, @@ -50,7 +52,7 @@ let mappings_of_type type_decl = match row_field.prf_desc with | Rinherit _ -> error_inherit loc | Rtag (name, true, []) -> - map acc mappings attrs name + map acc mappings rtag_attr_value row_field attrs name | Rtag _ -> error_arguments loc ) (0, []) constrs diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index 0002d5a3..7114cfcf 100644 --- a/src_plugins/eq/ppx_deriving_eq.cppo.ml +++ b/src_plugins/eq/ppx_deriving_eq.cppo.ml @@ -7,11 +7,11 @@ open Ppx_deriving.Ast_convenience let deriver = "eq" let raise_errorf = Ppx_deriving.raise_errorf -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.eq.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () -let attr_equal attrs = - Ppx_deriving.(attrs |> attr ~deriver "equal" |> Arg.(get_attr ~deriver expr)) +let ct_attr_equal = Attribute.declare "deriving.eq.equal" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) let argn kind = Printf.sprintf (match kind with `lhs -> "lhs%d" | `rhs -> "rhs%d") @@ -58,13 +58,16 @@ and expr_of_typ quoter typ = let loc = !Ast_helper.default_loc in let typ = Ppx_deriving.remove_pervasives ~deriver typ in let expr_of_typ = expr_of_typ quoter in - match attr_equal typ.ptyp_attributes with + match Attribute.get ct_attr_equal typ with | Some fn -> Ppx_deriving.quote ~quoter fn | None -> match typ with | [%type: _] -> [%expr fun _ _ -> true] | { ptyp_desc = Ptyp_constr _ } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: unit] -> [%expr fun (_:unit) (_:unit) -> true] diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml index 3500ea84..6ffec935 100644 --- a/src_plugins/fold/ppx_deriving_fold.cppo.ml +++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml @@ -7,8 +7,8 @@ open Ppx_deriving.Ast_convenience let deriver = "fold" let raise_errorf = Ppx_deriving.raise_errorf -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.fold.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -28,7 +28,10 @@ let rec expr_of_typ typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun acc _ -> acc] | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: [%t? typ] ref] -> [%expr fun acc x -> [%e expr_of_typ typ] acc !x] | true, [%type: [%t? typ] list] -> diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml index 9de101c9..9aafa8f3 100644 --- a/src_plugins/iter/ppx_deriving_iter.cppo.ml +++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml @@ -7,8 +7,8 @@ open Ppx_deriving.Ast_convenience let deriver = "iter" let raise_errorf = Ppx_deriving.raise_errorf -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.iter.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -24,7 +24,10 @@ let rec expr_of_typ typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun _ -> ()] | { ptyp_desc = Ptyp_constr _ } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: [%t? typ] ref] -> [%expr fun x -> [%e expr_of_typ typ] !x] diff --git a/src_plugins/make/ppx_deriving_make.cppo.ml b/src_plugins/make/ppx_deriving_make.cppo.ml index 07091eaf..07df1a96 100644 --- a/src_plugins/make/ppx_deriving_make.cppo.ml +++ b/src_plugins/make/ppx_deriving_make.cppo.ml @@ -7,16 +7,33 @@ open Ppx_deriving.Ast_convenience let deriver = "make" let raise_errorf = Ppx_deriving.raise_errorf -let attr_default attrs = - Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) +let attr_default context = Attribute.declare "deriving.make.default" context + Ast_pattern.(single_expr_payload __) (fun e -> e) +let ct_attr_default = attr_default Attribute.Context.core_type +let label_attr_default = attr_default Attribute.Context.label_declaration -let attr_split attrs = - Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver) +let attr_split context = Attribute.declare "deriving.make.split" context + Ast_pattern.(pstr nil) () +let ct_attr_split = attr_split Attribute.Context.core_type +let label_attr_split = attr_split Attribute.Context.label_declaration + +let attr_main context = Attribute.declare "deriving.make.main" context + Ast_pattern.(pstr nil) () +let ct_attr_main = attr_main Attribute.Context.core_type +let label_attr_main = attr_main Attribute.Context.label_declaration + +let attribute_get2 attr1 x1 attr2 x2 = + match Attribute.get attr1 x1, Attribute.get attr2 x2 with + | Some _ as y, _ -> y + | None, y -> y let find_main labels = List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) -> - if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> - attr ~deriver "main" |> Arg.get_flag ~deriver) then + let is_main = match attribute_get2 ct_attr_main pld_type label_attr_main label with + | Some () -> true + | None -> false + in + if is_main then match main with | Some _ -> raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" deriver | None -> Some label, labels @@ -25,12 +42,15 @@ let find_main labels = (None, []) labels -let is_optional { pld_name = { txt = name }; pld_type; pld_attributes } = - let attrs = pld_attributes @ pld_type.ptyp_attributes in - match attr_default attrs with +let is_optional ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) = + match attribute_get2 label_attr_default label ct_attr_default pld_type with | Some _ -> true | None -> - attr_split attrs || + let split = match attribute_get2 label_attr_split label ct_attr_split pld_type with + | Some () -> true + | None -> false + in + split || (match Ppx_deriving.remove_pervasives ~deriver pld_type with | [%type: [%t? _] list] | [%type: [%t? _] option] -> true @@ -55,14 +75,17 @@ let str_of_type ({ ptype_loc = loc } as type_decl) = | None -> record fields in - List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } -> - let attrs = pld_attributes @ pld_type.ptyp_attributes in - let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in - match attr_default attrs with + List.fold_left (fun accum ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) -> + match attribute_get2 label_attr_default label ct_attr_default pld_type with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> - if attr_split attrs then + let split = match attribute_get2 label_attr_split label ct_attr_split pld_type with + | Some () -> true + | None -> false + in + let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in + if split then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in @@ -101,13 +124,16 @@ let sig_of_type ({ ptype_loc = loc } as type_decl) = | None when has_option -> Typ.arrow Label.nolabel (tconstr "unit" []) typ | None -> typ in - List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } -> - let attrs = pld_type.ptyp_attributes @ pld_attributes in - let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in - match attr_default attrs with + List.fold_left (fun accum ({ pld_name = { txt = name; loc }; pld_type; pld_attributes } as label) -> + match attribute_get2 ct_attr_default pld_type label_attr_default label with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> - if attr_split attrs then + let split = match attribute_get2 ct_attr_split pld_type label_attr_split label with + | Some () -> true + | None -> false + in + let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in + if split then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml index 28af0b29..e3bfd73f 100644 --- a/src_plugins/map/ppx_deriving_map.cppo.ml +++ b/src_plugins/map/ppx_deriving_map.cppo.ml @@ -7,8 +7,8 @@ open Ppx_deriving.Ast_convenience let deriver = "map" let raise_errorf = Ppx_deriving.raise_errorf -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.map.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -25,7 +25,10 @@ let rec expr_of_typ ?decl typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun x -> x] | { ptyp_desc = Ptyp_constr _ } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: [%t? typ] list] -> [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ ?decl typ]] diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index 469d8ce2..aec6d023 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -8,11 +8,11 @@ open Ppx_deriving.Ast_convenience let deriver = "ord" let raise_errorf = Ppx_deriving.raise_errorf -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.ord.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () -let attr_compare attrs = - Ppx_deriving.(attrs |> attr ~deriver "compare" |> Arg.(get_attr ~deriver expr)) +let ct_attr_compare = Attribute.declare "deriving.ord.compare" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) let argn kind = Printf.sprintf (match kind with `lhs -> "lhs%d" | `rhs -> "rhs%d") @@ -61,14 +61,17 @@ and expr_of_label_decl quoter { pld_type; pld_attributes } = and expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in - match attr_compare typ.ptyp_attributes with + match Attribute.get ct_attr_compare typ with | Some fn -> Ppx_deriving.quote ~quoter fn | None -> let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ _ -> 0] | { ptyp_desc = Ptyp_constr _ } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: _] -> [%expr fun _ _ -> 0] diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 3080d36d..e1d3cab8 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -17,17 +17,19 @@ let expand_path ~with_path ~path name = let path = if with_path then path else [] in Ppx_deriving.expand_path ~path name -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare "deriving.show.nobuiltin" Attribute.Context.core_type + Ast_pattern.(pstr nil) () -let attr_printer attrs = - Ppx_deriving.(attrs |> attr ~deriver "printer" |> Arg.(get_attr ~deriver expr)) +let attr_printer context = Attribute.declare "deriving.show.printer" context + Ast_pattern.(single_expr_payload __) (fun e -> e) +let ct_attr_printer = attr_printer Attribute.Context.core_type +let constr_attr_printer = attr_printer Attribute.Context.constructor_declaration -let attr_polyprinter attrs = - Ppx_deriving.(attrs |> attr ~deriver "polyprinter" |> Arg.(get_attr ~deriver expr)) +let ct_attr_polyprinter = Attribute.declare "deriving.show.polyprinter" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) -let attr_opaque attrs = - Ppx_deriving.(attrs |> attr ~deriver "opaque" |> Arg.get_flag ~deriver) +let ct_attr_opaque = Attribute.declare "deriving.show.opaque" Attribute.Context.core_type + Ast_pattern.(pstr nil) () let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -67,10 +69,14 @@ let sig_of_type type_decl = let rec expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in - match attr_printer typ.ptyp_attributes with + match Attribute.get ct_attr_printer typ with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> - if attr_opaque typ.ptyp_attributes then + let opaque = match Attribute.get ct_attr_opaque typ with + | Some () -> true + | None -> false + in + if opaque then [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] else let format x = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str x]] in @@ -88,7 +94,10 @@ let rec expr_of_typ quoter typ = | { ptyp_desc = Ptyp_arrow _ } -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] | { ptyp_desc = Ptyp_constr _ } -> - let builtin = not (attr_nobuiltin typ.ptyp_attributes) in + let builtin = match Attribute.get ct_attr_nobuiltin typ with + | Some () -> false + | None -> true + in begin match builtin, typ with | true, [%type: unit] -> [%expr fun () -> Ppx_deriving_runtime.Format.pp_print_string fmt "()"] | true, [%type: int] -> format "%d" @@ -140,7 +149,7 @@ let rec expr_of_typ quoter typ = | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let args_pp = List.map (fun typ -> [%expr fun fmt -> [%e expr_of_typ typ]]) args in let printer = - match attr_polyprinter typ.ptyp_attributes with + match Attribute.get ct_attr_polyprinter typ with | Some printer -> wrap_printer quoter printer | None -> let printer = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "pp") lid)) in @@ -198,12 +207,12 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = [%expr fun fmt -> [%e expr_of_typ quoter manifest]] | Ptype_variant constrs, _ -> let cases = - constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> + constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> let constr_name = expand_path ~with_path ~path name' in - match attr_printer pcd_attributes, pcd_args with + match Attribute.get constr_attr_printer constr, pcd_args with | Some printer, Pcstr_tuple(args) -> let rec range from_idx to_idx = if from_idx = to_idx From 2c08bedc3288f2c23322e71178c843005aa60ede Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 11:38:51 +0300 Subject: [PATCH 05/17] Delegate to Ppxlib.Quoter --- ppx_deriving.opam | 2 +- src/api/ppx_deriving.cppo.ml | 29 +++++++---------------------- 2 files changed, 8 insertions(+), 23 deletions(-) diff --git a/ppx_deriving.opam b/ppx_deriving.opam index d56732ff..dcdcb4d4 100644 --- a/ppx_deriving.opam +++ b/ppx_deriving.opam @@ -19,7 +19,7 @@ depends: [ "cppo" {build} "ocamlfind" "ppx_derivers" - "ppxlib" {>= "0.20.0"} + "ppxlib" {>= "0.27.0"} "result" "ounit2" {with-test} ] diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index b212fc9e..7fdeffbe 100644 --- a/src/api/ppx_deriving.cppo.ml +++ b/src/api/ppx_deriving.cppo.ml @@ -309,39 +309,24 @@ let attr_warning expr = attr_loc = loc; } -type quoter = { - mutable next_id : int; - mutable bindings : value_binding list; -} +type quoter = Quoter.t -let create_quoter () = { next_id = 0; bindings = [] } +let create_quoter () = Quoter.create () let quote ~quoter expr = - let loc = !Ast_helper.default_loc in - let name = "__" ^ string_of_int quoter.next_id in - let (binding_body, quoted_expr) = match expr with - (* Optimize identifier quoting by avoiding closure. - See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *) - | { pexp_desc = Pexp_ident _; _ } -> - (expr, evar name) - | _ -> - ([%expr fun () -> [%e expr]], [%expr [%e evar name] ()]) - in - quoter.bindings <- (Vb.mk (pvar name) binding_body) :: quoter.bindings; - quoter.next_id <- quoter.next_id + 1; - quoted_expr + Quoter.quote quoter expr let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr = + let loc = !Ast_helper.default_loc in let body = - let loc = !Ast_helper.default_loc in let attrs = [attr_warning [%expr "-A"]] in let modname = { txt = module_; loc } in Exp.open_ ~loc ~attrs (Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname)) expr in - match quoter.bindings with - | [] -> body - | bindings -> Exp.let_ Nonrecursive bindings body + let sanitized = Quoter.sanitize quoter body in + (* ppxlib quoter uses Recursive, ppx_deriving's used Nonrecursive - silence warning *) + { sanitized with pexp_attributes = attr_warning [%expr "-39"] :: sanitized.pexp_attributes} let with_quoter fn a = let quoter = create_quoter () in From 9a46e102dfd6214bc81ae66af0698d3811583ddc Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 11:39:04 +0300 Subject: [PATCH 06/17] Fix typo org -> ord --- src_test/deriving/test_ppx_deriving.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src_test/deriving/test_ppx_deriving.ml b/src_test/deriving/test_ppx_deriving.ml index ca69a720..c46e407c 100644 --- a/src_test/deriving/test_ppx_deriving.ml +++ b/src_test/deriving/test_ppx_deriving.ml @@ -1,7 +1,7 @@ open OUnit2 let test_inline ctxt = - let sort = List.sort [%ord: int * int] in (* TODO: support derive.org again *) + let sort = List.sort [%ord: int * int] in (* TODO: support derive.ord again *) assert_equal ~printer:[%show: (int * int) list] (* TODO: support derive.show again *) [(1,1);(2,0);(3,5)] (sort [(2,0);(3,5);(1,1)]) From 4c9178c8ba48980f444a0ff9d3d66d3b65f2cadb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 11:55:34 +0300 Subject: [PATCH 07/17] Deprecate non-ppxlib derivers and attributes --- src/api/ppx_deriving.cppo.mli | 4 ++++ src_plugins/show/ppx_deriving_show.cppo.ml | 8 ++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index 1930b859..a60498cb 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -44,6 +44,7 @@ type deriver = { (** [register deriver] registers [deriver] according to its [name] field. *) val register : deriver -> unit +[@@deprecated] (** [add_register_hook hook] adds [hook] to be executed whenever a new deriver is registered. *) @@ -71,6 +72,7 @@ val create : path:string list -> module_type_declaration -> signature) -> unit -> deriver +[@@deprecated] (** [lookup name] looks up a deriver called [name]. *) val lookup : string -> deriver option @@ -169,6 +171,7 @@ let deriver = "index" in error messages. *) val get_expr : deriver:string -> 'a conv -> expression -> 'a end +[@@deprecated] (** {2 Hygiene} *) @@ -227,6 +230,7 @@ val mangle_lid : ?fixpoint:string -> or [\[\@deriver.attr\]] if any attribute with name starting with [\@deriver] exists, or [\[\@attr\]] otherwise. *) val attr : deriver:string -> string -> attributes -> attribute option +[@@deprecated] (** [attr_warning expr] builds the attribute [\@ocaml.warning expr] *) val attr_warning: expression -> attribute diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index e1d3cab8..73ed91c6 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -314,10 +314,10 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (* TODO: add to ppxlib? *) let ebool: _ Ast_pattern.t -> _ Ast_pattern.t = - Ast_pattern.map1 ~f:(fun e -> - match Ppx_deriving.Arg.bool e with - | Ok b -> b - | Error _ -> failwith "not bool") + Ast_pattern.map1 ~f:(function + | [%expr true] -> true + | [%expr false] -> false + | _ -> failwith "not bool") let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) (* TODO: add arg_default to ppxlib? *) From 9171d9a7031242b1e5e30322eafa94d7656a87c6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 19 Jul 2022 21:04:55 +0300 Subject: [PATCH 08/17] Restore "derive"-prefixed extensions via custom extension --- src_plugins/eq/ppx_deriving_eq.cppo.ml | 10 +++++++++- src_plugins/fold/ppx_deriving_fold.cppo.ml | 10 +++++++++- src_plugins/iter/ppx_deriving_iter.cppo.ml | 11 ++++++++++- src_plugins/map/ppx_deriving_map.cppo.ml | 9 +++++++++ src_plugins/ord/ppx_deriving_ord.cppo.ml | 10 +++++++++- src_plugins/show/ppx_deriving_show.cppo.ml | 14 ++++++++++++-- src_test/deriving/test_ppx_deriving.ml | 4 ++-- 7 files changed, 60 insertions(+), 8 deletions(-) diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index 7114cfcf..ce526976 100644 --- a/src_plugins/eq/ppx_deriving_eq.cppo.ml +++ b/src_plugins/eq/ppx_deriving_eq.cppo.ml @@ -207,6 +207,14 @@ let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decl let deriving: Deriving.t = Deriving.add deriver - ~extension:(fun ~loc:_ ~path:_ -> Ppx_deriving.with_quoter expr_of_typ) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.eq" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> Ppx_deriving.with_quoter expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml index 6ffec935..f706f5b2 100644 --- a/src_plugins/fold/ppx_deriving_fold.cppo.ml +++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml @@ -147,6 +147,14 @@ let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decl let deriving: Deriving.t = Deriving.add deriver - ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.fold" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml index 9aafa8f3..e94b8f9c 100644 --- a/src_plugins/iter/ppx_deriving_iter.cppo.ml +++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml @@ -139,6 +139,15 @@ let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decl let deriving: Deriving.t = Deriving.add deriver - ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.iter" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml index e3bfd73f..9d28428c 100644 --- a/src_plugins/map/ppx_deriving_map.cppo.ml +++ b/src_plugins/map/ppx_deriving_map.cppo.ml @@ -149,3 +149,12 @@ let deriving: Deriving.t = ~extension:(fun ~loc:_ ~path:_ -> expr_of_typ ?decl:None) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.map" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ ?decl:None) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index aec6d023..fee8c9dd 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -244,6 +244,14 @@ let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decl let deriving: Deriving.t = Deriving.add deriver - ~extension:(fun ~loc:_ ~path:_ -> Ppx_deriving.with_quoter expr_of_typ) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.ord" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> Ppx_deriving.with_quoter expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 73ed91c6..40dd939f 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -341,7 +341,17 @@ let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decl let deriving: Deriving.t = Deriving.add deriver - ~extension:(fun ~loc ~path:_ -> (Ppx_deriving.with_quoter (fun quoter typ -> - [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x]))) ~str_type_decl:impl_generator ~sig_type_decl:intf_generator + +(* custom extension such that "derive"-prefixed also works *) +let derive_extension = + Extension.V3.declare "derive.show" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + Ppx_deriving.with_quoter (fun quoter typ -> + [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_test/deriving/test_ppx_deriving.ml b/src_test/deriving/test_ppx_deriving.ml index c46e407c..b8950696 100644 --- a/src_test/deriving/test_ppx_deriving.ml +++ b/src_test/deriving/test_ppx_deriving.ml @@ -1,8 +1,8 @@ open OUnit2 let test_inline ctxt = - let sort = List.sort [%ord: int * int] in (* TODO: support derive.ord again *) - assert_equal ~printer:[%show: (int * int) list] (* TODO: support derive.show again *) + let sort = List.sort [%derive.ord: int * int] in + assert_equal ~printer:[%derive.show: (int * int) list] [(1,1);(2,0);(3,5)] (sort [(2,0);(3,5);(1,1)]) let test_inline_shorthand ctxt = From 3359fea7c8e3cb6908b1d6da398a8dce2467bba9 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 20 Jul 2022 14:02:51 +0300 Subject: [PATCH 09/17] Use input_name from ppxlib for show deriver path --- src/api/ppx_deriving.cppo.mli | 2 -- src_plugins/show/ppx_deriving_show.cppo.ml | 20 +++++++++++++++----- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index a60498cb..8a1678ae 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -390,5 +390,3 @@ module Ast_convenience : sig val optional : string -> arg_label end end - -val module_from_input_name: unit -> label list diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 40dd939f..d991130e 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -323,11 +323,21 @@ let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) let impl_generator = Deriving.Generator.V2.make (args ()) (fun ~ctxt (_, type_decls) with_path -> let path = - (* based on https://github.com/thierry-martinez/ppx_show/blob/db00365470bcbf602d931c1bfd155be459379c5c/src/ppx_show.ml#L384-L387 *) - let code_path = Ppxlib.Expansion_context.Deriver.code_path ctxt in - (* main_module_name contains ".cppo" due to #line directives? *) - (* Ppxlib.Code_path.(main_module_name code_path :: submodule_path code_path) *) - Ppxlib.Code_path.(Ppx_deriving.module_from_input_name () @ submodule_path code_path) + let code_path = Expansion_context.Deriver.code_path ctxt in + (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) + (* Ppx_deriving.module_from_input_name ported to ppxlib. *) + let main_module_path = match Expansion_context.Deriver.input_name ctxt with + | "" + | "_none_" -> [] + | input_name -> + match Filename.chop_suffix input_name ".ml" with + | exception _ -> + (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) + [] + | path -> + [String.capitalize_ascii (Filename.basename path)] + in + main_module_path @ Code_path.submodule_path code_path in let with_path = match with_path with | Some with_path -> with_path From f9a1e632b8617581689d140d9fdd4876083744a5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Mar 2023 19:49:20 +0200 Subject: [PATCH 10/17] Adapt quoter to ppxlib 0.29.0 --- ppx_deriving.opam | 2 +- src/api/ppx_deriving.cppo.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ppx_deriving.opam b/ppx_deriving.opam index dcdcb4d4..aad4963f 100644 --- a/ppx_deriving.opam +++ b/ppx_deriving.opam @@ -19,7 +19,7 @@ depends: [ "cppo" {build} "ocamlfind" "ppx_derivers" - "ppxlib" {>= "0.27.0"} + "ppxlib" {>= "0.29.0"} "result" "ounit2" {with-test} ] diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index 7fdeffbe..63b0c056 100644 --- a/src/api/ppx_deriving.cppo.ml +++ b/src/api/ppx_deriving.cppo.ml @@ -309,12 +309,12 @@ let attr_warning expr = attr_loc = loc; } -type quoter = Quoter.t +type quoter = Expansion_helpers.Quoter.t -let create_quoter () = Quoter.create () +let create_quoter () = Expansion_helpers.Quoter.create () let quote ~quoter expr = - Quoter.quote quoter expr + Expansion_helpers.Quoter.quote quoter expr let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr = let loc = !Ast_helper.default_loc in @@ -324,7 +324,7 @@ let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) Exp.open_ ~loc ~attrs (Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname)) expr in - let sanitized = Quoter.sanitize quoter body in + let sanitized = Expansion_helpers.Quoter.sanitize quoter body in (* ppxlib quoter uses Recursive, ppx_deriving's used Nonrecursive - silence warning *) { sanitized with pexp_attributes = attr_warning [%expr "-39"] :: sanitized.pexp_attributes} From a69c7a2b46c3da48dea7cb48f80e1250037ce7d4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Mar 2023 19:53:28 +0200 Subject: [PATCH 11/17] Remove unused attrs argument in enum plugin Co-authored-by: panglesd --- src_plugins/enum/ppx_deriving_enum.cppo.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src_plugins/enum/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml index 206f56c2..4be9ebdf 100644 --- a/src_plugins/enum/ppx_deriving_enum.cppo.ml +++ b/src_plugins/enum/ppx_deriving_enum.cppo.ml @@ -17,7 +17,7 @@ let constr_attr_value = attr_value Attribute.Context.constructor_declaration let rtag_attr_value = attr_value Attribute.Context.rtag let mappings_of_type type_decl = - let map acc mappings attr_value x attrs constr_name = + let map acc mappings attr_value x constr_name = let value = match Attribute.get attr_value x with | Some idx -> idx | None -> acc @@ -32,7 +32,7 @@ let mappings_of_type type_decl = if pcd_args <> Pcstr_tuple([]) then raise_errorf ~loc:pcd_loc "%s can be derived only for argumentless constructors" deriver; - map acc mappings constr_attr_value constr pcd_attributes pcd_name) + map acc mappings constr_attr_value constr pcd_name) (0, []) constrs | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (constrs, Closed, None); ptyp_loc } -> `Polymorphic, @@ -48,11 +48,10 @@ let mappings_of_type type_decl = deriver in 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 rtag_attr_value row_field attrs name + map acc mappings rtag_attr_value row_field name | Rtag _ -> error_arguments loc ) (0, []) constrs From 8ad6cc4cb4c95741a87efff6ae065604a6f3a723 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Mar 2023 20:52:08 +0200 Subject: [PATCH 12/17] Replace failwith with raise_errorf Co-authored-by: panglesd --- src_plugins/show/ppx_deriving_show.cppo.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index d991130e..a1cb6ed7 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -314,10 +314,10 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (* TODO: add to ppxlib? *) let ebool: _ Ast_pattern.t -> _ Ast_pattern.t = - Ast_pattern.map1 ~f:(function + Ast_pattern.map1' ~f:(fun loc -> function | [%expr true] -> true | [%expr false] -> false - | _ -> failwith "not bool") + | _ -> Location.raise_errorf ~loc "with_path should be a boolean") let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) (* TODO: add arg_default to ppxlib? *) From dc74b49caa375eef3c5068944996713db221b70b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 23 Mar 2023 09:53:26 +0200 Subject: [PATCH 13/17] Revert "Deprecate non-ppxlib derivers and attributes" This reverts commit 4c9178c8ba48980f444a0ff9d3d66d3b65f2cadb. --- src/api/ppx_deriving.cppo.mli | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index 8a1678ae..d31e998b 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -44,7 +44,6 @@ type deriver = { (** [register deriver] registers [deriver] according to its [name] field. *) val register : deriver -> unit -[@@deprecated] (** [add_register_hook hook] adds [hook] to be executed whenever a new deriver is registered. *) @@ -72,7 +71,6 @@ val create : path:string list -> module_type_declaration -> signature) -> unit -> deriver -[@@deprecated] (** [lookup name] looks up a deriver called [name]. *) val lookup : string -> deriver option @@ -171,7 +169,6 @@ let deriver = "index" in error messages. *) val get_expr : deriver:string -> 'a conv -> expression -> 'a end -[@@deprecated] (** {2 Hygiene} *) @@ -230,7 +227,6 @@ val mangle_lid : ?fixpoint:string -> or [\[\@deriver.attr\]] if any attribute with name starting with [\@deriver] exists, or [\[\@attr\]] otherwise. *) val attr : deriver:string -> string -> attributes -> attribute option -[@@deprecated] (** [attr_warning expr] builds the attribute [\@ocaml.warning expr] *) val attr_warning: expression -> attribute From e4a900e08d46f0d773fac6ec13a82d92fd07073c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 23 Mar 2023 10:02:26 +0200 Subject: [PATCH 14/17] Update test TODO about optional --- src_test/deriving/test_ppx_deriving.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src_test/deriving/test_ppx_deriving.ml b/src_test/deriving/test_ppx_deriving.ml index b8950696..fb6831ec 100644 --- a/src_test/deriving/test_ppx_deriving.ml +++ b/src_test/deriving/test_ppx_deriving.ml @@ -9,7 +9,7 @@ let test_inline_shorthand ctxt = assert_equal ~printer:(fun x -> x) "[(1, 1); (2, 0)]" ([%show: (int * int) list] [(1,1); (2,0)]) -(* TODO: how did this work and why did it break now? *) +(* TODO: optional is incompatible with ppxlib derivers: https://github.com/ocaml-ppx/ppx_deriving/issues/247 *) (* type optional_deriver = string [@@deriving missing { optional = true }] *) From ccfa83064afeaac322bc6573bdf798053bb5e7f0 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 23 Mar 2023 10:13:42 +0200 Subject: [PATCH 15/17] Add PR #263 to CHANGELOG --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index a3d885e2..66379c1c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ (unreleased) ------------ +* Port standard plugins to ppxlib registration and attributes + #263 + (Simmo Saan) + * Introduce `Ppx_deriving_runtime.Stdlib` with OCaml >= 4.07. This module already exists in OCaml < 4.07 but was missing otherwise. From 12e4e4139482b64c610f089c8b3a09a0efd8e50a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 23 Mar 2023 11:43:10 +0200 Subject: [PATCH 16/17] Remove unnecessary unit argument from show plugin args --- src_plugins/show/ppx_deriving_show.cppo.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index a1cb6ed7..a19a092f 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -318,10 +318,10 @@ let ebool: _ Ast_pattern.t -> _ Ast_pattern.t = | [%expr true] -> true | [%expr false] -> false | _ -> Location.raise_errorf ~loc "with_path should be a boolean") -let args () = Deriving.Args.(empty +> arg "with_path" (ebool __)) +let args = Deriving.Args.(empty +> arg "with_path" (ebool __)) (* TODO: add arg_default to ppxlib? *) -let impl_generator = Deriving.Generator.V2.make (args ()) (fun ~ctxt (_, type_decls) with_path -> +let impl_generator = Deriving.Generator.V2.make args (fun ~ctxt (_, type_decls) with_path -> let path = let code_path = Expansion_context.Deriver.code_path ctxt in (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) From 7dbaf97f797d127cd6d23aa11863e480febac289 Mon Sep 17 00:00:00 2001 From: Shon Feder Date: Fri, 23 Feb 2024 21:20:30 -0500 Subject: [PATCH 17/17] Add regression test for #272 Tests behavior when deriving on mutually recursive types https://github.com/ocaml-ppx/ppx_deriving/issues/272 --- src_test/make/test_deriving_make.ml | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src_test/make/test_deriving_make.ml b/src_test/make/test_deriving_make.ml index 51c8a675..506f8aa6 100644 --- a/src_test/make/test_deriving_make.ml +++ b/src_test/make/test_deriving_make.ml @@ -21,6 +21,14 @@ module M : sig c1 : int; c2 : string } [@@deriving show, make] + + type principle_recursive_type = + { prt1 : int + ; prt2 : secondary_recursive_type + } [@@deriving show, make] + + and secondary_recursive_type = string + [@@deriving show] end = struct type a = { a1 : int option; @@ -42,6 +50,18 @@ end = struct c1 : int; c2 : string } [@@deriving show, make] + + (* Generate make for a record that is part of a mutually recursive type declaration. + Generation should succeed, and not try to generate `make` for non-annotated types. + + Regression test for https://github.com/ocaml-ppx/ppx_deriving/issues/272 *) + type principle_recursive_type = + { prt1 : int + ; prt2 : secondary_recursive_type + } [@@deriving show, make] + + and secondary_recursive_type = string + [@@deriving show] end let test_no_main ctxt = @@ -65,10 +85,16 @@ let test_no_unit ctxt = { M.c1 = 0; M.c2 = "" } (M.make_c ~c1:0 ~c2:"") +let test_recursive_types ctxt = + assert_equal ~printer:M.show_principle_recursive_type + { M.prt1 = 0; M.prt2 = "" } + (M.make_principle_recursive_type ~prt1:0 ~prt2:"") + let suite = "Test deriving(make)" >::: [ "test_no_main" >:: test_no_main; "test_main" >:: test_main; - "test_no_unit" >:: test_no_unit + "test_no_unit" >:: test_no_unit; + "test_recursive_types" >:: test_recursive_types; ] let _ = run_test_tt_main suite