From 8775cfef8ca1c0feb0dfa98bcd227643a2964f22 Mon Sep 17 00:00:00 2001 From: Francisco Santos Date: Sat, 5 Oct 2024 17:38:29 +0100 Subject: [PATCH] Add poly support --- README.md | 45 +++++++++++++- ppx_default.ml | 128 +++++++++++++++++++++++++-------------- tests/lib_test/other.ml | 26 ++++++++ tests/lib_test/other.mli | 5 ++ tests/lib_test/sample.ml | 6 +- tests/sample/abc.ml | 3 +- 6 files changed, 162 insertions(+), 51 deletions(-) diff --git a/README.md b/README.md index ab95e2f..6cbf8d2 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,46 @@ # ppx_default -The idea is to generate the default value of any record (and inductive types). +Generate a default value based on the type definition. -Check tests to see how it works :) +```ocaml +type 'a t = { + poly_field: 'a; +}[@@deriving default] + +type ind = + | Abc of int + | Efg of string + [@@deriving default] + +let int_t = default 5 () (* { poly_field = 5 } *) +let ind_value = default_ind () (* (Abc 0) *) +``` + +```ocaml +type abc = { + test_me : int; + name : string; + tup : int * string; + calculate : string -> int -> float -> int; + arr : string array; + l : int list; +} +[@@deriving show, default] + +let _ = default_abc () (* { Sample.test_me = 0; name = ""; tup = (0, ""); calculate = ; arr = [||]; l = [] } *) +``` + +# Features missing + +- use of polymorphic inside a record/inductive type + +Eg: +```ocaml +type 'a d = + D of 'a + [@@deriving show, default] + +type 'a f = { + my_field : 'a d +}[@@deriving show, default] +``` diff --git a/ppx_default.ml b/ppx_default.ml index d78bbd6..2525e82 100644 --- a/ppx_default.ml +++ b/ppx_default.ml @@ -7,45 +7,46 @@ let url = "github.com/ProgramingIsTheFuture/ppx_default" let not_supported_error e = failwith (Format.sprintf "%s. Create an issue at %s" e url) +let fun_names txt = + if txt = "t" then "default" + else "default_" ^ txt + let rec default_value_by_type ~loc core_type = match core_type.ptyp_desc with | Ptyp_constr (({ txt = Ldot (_, _); loc } as l), _) -> let l = match l.txt with - | Ldot (a, l) -> { txt = Ldot (a, l ^ "_default"); loc } + | Ldot (a, l) -> { txt = Ldot (a, fun_names l); loc } | _ -> l in let f = Ast_helper.Exp.ident l in Ast_builder.Default.pexp_apply ~loc f [ (Nolabel, pexp_construct ~loc { txt = lident "()"; loc } None) ] - | Ptyp_constr ({ txt = Lident s; loc }, _) -> ( + | Ptyp_constr ({ txt = Lident s; loc }, _) -> begin (* Handling constants *) - match s with - | "int" -> - Ast_builder.Default.pexp_constant ~loc (Pconst_integer ("0", None)) - | "int64" -> - Ast_builder.Default.pexp_constant ~loc - (Ast_helper.Const.int64 Int64.zero) - | "string" -> - Ast_builder.Default.pexp_constant ~loc (Pconst_string ("", loc, None)) - | "float" -> - Ast_builder.Default.pexp_constant ~loc (Pconst_float ("0.0", None)) - | "char" -> Ast_builder.Default.pexp_constant ~loc (Pconst_char ' ') - | "array" -> Ast_builder.Default.pexp_array ~loc [] - | "list" -> - Ast_builder.Default.pexp_construct ~loc - { txt = lident "[]"; loc } - None - | _ -> - let expr = - not_supported_error - (Format.sprintf - "The value %s was not defined, try adding the [@@deriving \ - default]" - (s ^ "_default")) - in - Ast_builder.Default.pexp_apply ~loc expr - [ (Nolabel, pexp_construct ~loc { txt = lident "()"; loc } None) ]) + match s with + | "int" -> + Ast_builder.Default.pexp_constant ~loc (Pconst_integer ("0", None)) + | "int64" -> + Ast_builder.Default.pexp_constant ~loc + (Ast_helper.Const.int64 Int64.zero) + | "string" -> + Ast_builder.Default.pexp_constant ~loc (Pconst_string ("", loc, None)) + | "float" -> + Ast_builder.Default.pexp_constant ~loc (Pconst_float ("0.0", None)) + | "char" -> Ast_builder.Default.pexp_constant ~loc (Pconst_char ' ') + | "array" -> Ast_builder.Default.pexp_array ~loc [] + | "list" -> + Ast_builder.Default.pexp_construct ~loc + { txt = lident "[]"; loc } + None + | _ -> + let expr = + Ast_builder.Default.pexp_ident ~loc { txt = lident (fun_names s); loc } + in + Ast_builder.Default.pexp_apply ~loc expr + [ (Nolabel, pexp_construct ~loc { txt = lident "()"; loc } None) ] + end | Ptyp_arrow (l, _, t2) -> (* Handling arrow types Gen a function that ignores all params and return the right expr *) @@ -56,8 +57,25 @@ let rec default_value_by_type ~loc core_type = (* Handling tuples *) Ast_builder.Default.pexp_tuple ~loc (List.map cl ~f:(default_value_by_type ~loc)) - | Ptyp_package _ | Ptyp_poly _ | Ptyp_variant _ | Ptyp_extension _ - | Ptyp_class _ | Ptyp_alias _ | Ptyp_object _ | Ptyp_var _ | Ptyp_any | _ -> + | Ptyp_alias (core_type, _) -> + default_value_by_type ~loc core_type + | Ptyp_variant ({ prf_desc; prf_loc; _ } :: _, _, _) -> begin + match prf_desc with + | Rtag ({ txt; loc } +, true, []) -> + Ast_builder.Default.pexp_variant ~loc txt None + | Rtag ({ txt; loc }, _, l) -> + Ast_builder.Default.pexp_variant + ~loc + txt + (Option.some @@ Ast_builder.Default.pexp_tuple ~loc (List.map ~f:(default_value_by_type ~loc) l)) + | Rinherit core_type -> + Ast_builder.Default.pexp_variant ~loc "" (Option.some @@ default_value_by_type ~loc:prf_loc core_type) + end + | Ptyp_var l -> + Ast_builder.Default.pexp_ident ~loc { txt = lident l; loc } + | Ptyp_package _ | Ptyp_extension _ + | Ptyp_class _ | Ptyp_object _ | Ptyp_any | _ -> not_supported_error "Type is not supported" let default_field ~loc field = @@ -65,17 +83,30 @@ let default_field ~loc field = let default_value = default_value_by_type ~loc field.pld_type in (label, default_value) -let default_fun ~loc ~ptype_name expr = +let default_fun ~loc ~ptype_name ~ptype_params expr = + let name = + let i = ref 0 in + fun () -> + let c = Char.chr (97 + !i) in + incr i; + Char.escaped c + in let expr = - pexp_fun ~loc Nolabel None + List.fold_left ~f:(fun f ({ ptyp_loc=loc; _ }, _) -> + pexp_fun ~loc Nolabel None + (ppat_var ~loc { txt = (name ()); loc }) + f + ) + ~init:(pexp_fun ~loc Nolabel None (ppat_construct ~loc { txt = lident "()"; loc } None) - expr + expr) + ptype_params in pstr_value ~loc Nonrecursive [ { pvb_pat = - ppat_var ~loc { ptype_name with txt = ptype_name.txt ^ "_default" }; + ppat_var ~loc { ptype_name with txt = fun_names ptype_name.txt }; pvb_expr = expr; pvb_attributes = []; pvb_loc = loc; @@ -104,11 +135,12 @@ let generate_impl ~ctxt (_rec_flag, type_declarations) = ptype_loc; ptype_name; ptype_manifest = Some core_t; + ptype_params; _; } -> let expr = default_value_by_type ~loc:ptype_loc core_t in - default_fun ~loc:ptype_loc ~ptype_name expr - | { ptype_kind = Ptype_variant constl; ptype_loc; ptype_name; _ } -> ( + default_fun ~loc:ptype_loc ~ptype_name ~ptype_params expr + | { ptype_kind = Ptype_variant constl; ptype_loc; ptype_name; ptype_params; _ } -> ( let l = List.find_opt ~f:(fun a -> @@ -123,7 +155,7 @@ let generate_impl ~ctxt (_rec_flag, type_declarations) = let expr = Ast_builder.Default.pexp_construct ~loc:ptype_loc s None in - default_fun ~loc:ptype_loc ~ptype_name expr + default_fun ~loc:ptype_loc ~ptype_name ~ptype_params expr | None -> ( let l = List.hd constl in match l.pcd_args with @@ -142,7 +174,7 @@ let generate_impl ~ctxt (_rec_flag, type_declarations) = Ast_builder.Default.pexp_construct ~loc:ptype_loc s (Some expr) in - default_fun ~loc:ptype_loc ~ptype_name expr + default_fun ~loc:ptype_loc ~ptype_name ~ptype_params expr | Pcstr_record fields -> let s = { txt = lident l.pcd_name.txt; loc = ptype_loc } in let expr = default_impl ~fields ~ptype_loc:l.pcd_loc in @@ -150,9 +182,9 @@ let generate_impl ~ctxt (_rec_flag, type_declarations) = Ast_builder.Default.pexp_construct ~loc:ptype_loc s (Some expr) in - default_fun ~loc ~ptype_name expr)) - | { ptype_kind = Ptype_record fields; ptype_name; ptype_loc; _ } -> - default_impl ~fields ~ptype_loc |> default_fun ~loc ~ptype_name + default_fun ~loc ~ptype_name expr ~ptype_params)) + | { ptype_kind = Ptype_record fields; ptype_name; ptype_loc; ptype_params; _ } -> + default_impl ~fields ~ptype_loc |> default_fun ~loc ~ptype_name ~ptype_params | { ptype_loc; ptype_name; _ } -> let ext = Location.error_extensionf ~loc:ptype_loc @@ -160,14 +192,18 @@ let generate_impl ~ctxt (_rec_flag, type_declarations) = in Ast_builder.Default.pstr_extension ~loc ext []) -let default_intf ~ptype_name ~loc = +let default_intf ~ptype_name ~loc ~ptype_params () = psig_value ~loc { - pval_name = { ptype_name with txt = ptype_name.txt ^ "_default" }; + pval_name = { ptype_name with txt = fun_names ptype_name.txt }; pval_type = - ptyp_arrow ~loc Nolabel + List.fold_left ~f:(fun f (core_typ, _) -> + ptyp_arrow ~loc Nolabel + core_typ + f + ) ~init:(ptyp_arrow ~loc Nolabel (ptyp_constr ~loc { loc; txt = lident "unit" } []) - (ptyp_constr ~loc { loc; txt = lident ptype_name.txt } []); + (ptyp_constr ~loc { loc; txt = lident ptype_name.txt } (List.map ~f:fst ptype_params))) ptype_params; pval_attributes = []; pval_loc = loc; pval_prim = []; @@ -176,7 +212,7 @@ let default_intf ~ptype_name ~loc = let generate_intf ~ctxt:_ (_rec_flag, type_declarations) = List.map type_declarations ~f:(fun (td : type_declaration) -> match td with - | { ptype_name; ptype_loc; _ } -> default_intf ~ptype_name ~loc:ptype_loc) + | { ptype_name; ptype_loc; ptype_params; _ } -> default_intf ~ptype_name ~loc:ptype_loc ~ptype_params ()) let impl_generator = Deriving.Generator.V2.make_noarg generate_impl let intf_generator = Deriving.Generator.V2.make_noarg generate_intf diff --git a/tests/lib_test/other.ml b/tests/lib_test/other.ml index dd18e71..d89af5c 100644 --- a/tests/lib_test/other.ml +++ b/tests/lib_test/other.ml @@ -1 +1,27 @@ type binding = { error_here : int } [@@deriving show, default] + +type 'a poly_record = { + poly_field: 'a; +}[@@deriving show, default] + +module A = struct + type 'a r = { + example: 'a; + }[@@deriving show, default] + + type e = + E of int + [@@deriving show, default] + + type t = + [ + | `Abc of e + | `Some of string + ][@@deriving show, default] +end + +let () = + let t = A.default () in + let a = default_poly_record 10 () in + Format.printf "%s@.\n" @@ A.show t; + Format.printf "%s@." @@ show_poly_record (fun f a -> Format.fprintf f "%d" a) a diff --git a/tests/lib_test/other.mli b/tests/lib_test/other.mli index d37fa89..b3c15c0 100644 --- a/tests/lib_test/other.mli +++ b/tests/lib_test/other.mli @@ -1 +1,6 @@ type binding [@@deriving show, default] + +module A : sig + type t[@@deriving show, default] + type 'a r[@@deriving show, default] +end diff --git a/tests/lib_test/sample.ml b/tests/lib_test/sample.ml index aa9d046..c540117 100644 --- a/tests/lib_test/sample.ml +++ b/tests/lib_test/sample.ml @@ -1,7 +1,9 @@ +include Other + type hehe = { name : Other.binding } [@@deriving show, default] let _ = - hehe_default () |> show_hehe |> print_string |> print_newline |> flush_all + default_hehe () |> show_hehe |> print_string |> print_newline |> flush_all type abc = { test_me : int; @@ -14,5 +16,5 @@ type abc = { [@@deriving show, default] let _ = - let abc = abc_default () in + let abc = default_abc () in abc |> show_abc |> print_string |> print_newline |> flush_all diff --git a/tests/sample/abc.ml b/tests/sample/abc.ml index 7846a40..dfce88e 100644 --- a/tests/sample/abc.ml +++ b/tests/sample/abc.ml @@ -1 +1,2 @@ -let _ = Sample.abc_default () +let _ = Sample.default_abc () +let _ = Sample.A.default ()