diff --git a/dune-project b/dune-project index 3612e89..e5315d3 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,6 @@ (lang dune 2.7) (name ppx_make) -(version "0.3.4") +(version "0.4.0") (generate_opam_files true) diff --git a/src/arg_type.ml b/src/arg_type.ml index d0d316d..9ae0bd0 100644 --- a/src/arg_type.ml +++ b/src/arg_type.ml @@ -26,16 +26,16 @@ let get_attr (attrs : attribute list) = List.fold_left (fun acc (attr : attribute) -> (match attr.attr_name.txt with - | "main" | "make.main" -> Main - | "required" | "make.required" -> Required - | "default" | "make.default" -> ( - match attr.attr_payload with - | PStr [ { pstr_desc = Pstr_eval (expr, _); _ } ] -> Default expr - | _ -> - Location.raise_errorf ~loc:attr.attr_loc - "value in default attribute is not supported") - (* ignore unknown attrs *) - | _ -> No_attr) + | "main" | "make.main" -> Main + | "required" | "make.required" -> Required + | "default" | "make.default" -> ( + match attr.attr_payload with + | PStr [ { pstr_desc = Pstr_eval (expr, _); _ } ] -> Default expr + | _ -> + Location.raise_errorf ~loc:attr.attr_loc + "value in default attribute is not supported") + (* ignore unknown attrs *) + | _ -> No_attr) |> check_res ~loc:attr.attr_loc acc) No_attr attrs diff --git a/src/deriver.ml b/src/deriver.ml index 68c870b..bf16b83 100644 --- a/src/deriver.ml +++ b/src/deriver.ml @@ -16,8 +16,8 @@ let fun_expression_of_record ~loc ?choice (lds : label_declaration list) : Ast_helper.with_default_loc loc (fun () -> let arg_types = List.map - (fun { pld_loc = loc; pld_name; pld_type; pld_attributes = attrs; _ } -> - Arg_type.of_core_type ~loc ~attrs pld_name pld_type) + (fun { pld_loc = loc; pld_name; pld_type; pld_attributes = attrs; _ } + -> Arg_type.of_core_type ~loc ~attrs pld_name pld_type) lds |> List.rev in @@ -30,9 +30,9 @@ let fun_expression_of_record ~loc ?choice (lds : label_declaration list) : in arg_types |> List.map (fun (name, _, _) -> - let lid = Utils.longident_loc_of_name name in - let expr = Ast_helper.Exp.ident lid in - (lid, expr)) + let lid = Utils.longident_loc_of_name name in + let expr = Ast_helper.Exp.ident lid in + (lid, expr)) |> (fun labels -> Ast_helper.Exp.record labels None) |> Utils.add_choice_to_expr choice |> fun expr -> @@ -63,11 +63,11 @@ let fun_expression_of_tuple ~loc ?choice (cts : core_type list) : expression = in arg_types |> List.map (fun (name, _, _) -> - Ast_helper.with_default_loc name.loc (fun () -> - let lid = Utils.longident_loc_of_name name in - Ast_helper.Exp.ident lid)) + Ast_helper.with_default_loc name.loc (fun () -> + let lid = Utils.longident_loc_of_name name in + Ast_helper.Exp.ident lid)) |> (fun exprs -> - match exprs with [ expr ] -> expr | _ -> Ast_helper.Exp.tuple exprs) + match exprs with [ expr ] -> expr | _ -> Ast_helper.Exp.tuple exprs) |> Utils.add_choice_to_expr choice |> Ast_helper.Exp.fun_ Nolabel None (Ast_helper.Pat.any ()) |> fun expr -> @@ -89,8 +89,8 @@ let fun_core_type_of_record ~loc (name, params) (lds : label_declaration list) : Ast_helper.with_default_loc loc (fun () -> let arg_types = List.map - (fun { pld_loc = loc; pld_name; pld_type; pld_attributes = attrs; _ } -> - Arg_type.of_core_type ~loc ~attrs pld_name pld_type) + (fun { pld_loc = loc; pld_name; pld_type; pld_attributes = attrs; _ } + -> Arg_type.of_core_type ~loc ~attrs pld_name pld_type) lds |> List.rev in @@ -198,13 +198,13 @@ let sig_item_of_core_type (name, params) (ct : core_type) : signature_item = let loc = ct.ptyp_loc in Ast_helper.with_default_loc loc (fun () -> (match ct with - | { ptyp_desc = Ptyp_tuple cts; _ } -> - (* T1 * ... * Tn *) - fun_core_type_of_tuple ~loc (name, params) cts - | [%type: [%t? in_ct] option] | [%type: [%t? in_ct] Option.t] -> - (* T option *) - fun_core_type_of_option ~loc (name, params) in_ct - | _ -> Utils.unsupported_error "core type" name) + | { ptyp_desc = Ptyp_tuple cts; _ } -> + (* T1 * ... * Tn *) + fun_core_type_of_tuple ~loc (name, params) cts + | [%type: [%t? in_ct] option] | [%type: [%t? in_ct] Option.t] -> + (* T option *) + fun_core_type_of_option ~loc (name, params) in_ct + | _ -> Utils.unsupported_error "core type" name) |> Ast_helper.Val.mk @@ Utils.gen_make_name name |> Ast_helper.Sig.value) @@ -226,8 +226,8 @@ let sig_item_of_variant_choice (name, params) (cd : constructor_declaration) : Utils.unsupported_error "constructor declaration" name else (match cd.pcd_args with - | Pcstr_tuple cts -> fun_core_type_of_tuple ~loc (name, params) cts - | Pcstr_record lds -> fun_core_type_of_record ~loc (name, params) lds) + | Pcstr_tuple cts -> fun_core_type_of_tuple ~loc (name, params) cts + | Pcstr_record lds -> fun_core_type_of_record ~loc (name, params) lds) |> Ast_helper.Val.mk @@ Utils.gen_make_choice_name name cd.pcd_name |> Ast_helper.Sig.value) diff --git a/src/utils.ml b/src/utils.ml index 2fd0292..f6f0dd9 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -43,10 +43,16 @@ let make_type_decl_generator f = |> List.map (f ~loc rec_flag) |> List.concat) -let gen_make_name { txt = name; loc } = { txt = "make_" ^ name; loc } +let gen_make_name { txt = name; loc } = + let txt = match name with "t" -> "make" | _ -> "make_" ^ name in + { txt; loc } let gen_make_choice_name { txt = name; _ } { txt = choice_name; loc } = - let txt = String.lowercase_ascii ("make_" ^ choice_name ^ "_of_" ^ name) in + let txt = + match name with + | "t" -> String.lowercase_ascii ("make_" ^ choice_name) + | _ -> String.lowercase_ascii ("make_" ^ choice_name ^ "_of_" ^ name) + in { txt; loc } let gen_tuple_label ~loc index = { txt = "v" ^ string_of_int index; loc } diff --git a/test/misc.types.mli b/test/misc.types.mli deleted file mode 100644 index 919ea9f..0000000 --- a/test/misc.types.mli +++ /dev/null @@ -1,3 +0,0 @@ -(* https://github.com/bn-d/ppx_make/issues/12 *) -type a = { i : int } [@@deriving make, show] -and b = int diff --git a/test/misc_types.ml b/test/misc_types.ml index 919ea9f..a294094 100644 --- a/test/misc_types.ml +++ b/test/misc_types.ml @@ -1,3 +1,5 @@ (* https://github.com/bn-d/ppx_make/issues/12 *) type a = { i : int } [@@deriving make, show] and b = int + +type t = { t : int } [@@deriving make] diff --git a/test/test_make.ml b/test/test_make.ml index dc8fb97..5dab55b 100644 --- a/test/test_make.ml +++ b/test/test_make.ml @@ -2,6 +2,10 @@ let test_multiple_type_decl _ = let open Misc_types in OUnit.assert_equal { i = 1 } @@ make_a ~i:1 () +let test_t_name _ = + let open Misc_types in + OUnit.assert_equal { t = 1 } @@ make ~t:1 () + let _ = let open OUnit2 in run_test_tt_main @@ -13,4 +17,5 @@ let _ = Test_make_tuple.suite; Test_make_variant.suite; "test_multiple_type_decl" >:: test_multiple_type_decl; + "test_t_name" >:: test_t_name; ])