Skip to content

Add poly support #2

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open

Add poly support #2

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
45 changes: 43 additions & 2 deletions README.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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 = <fun>; 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]
```
128 changes: 82 additions & 46 deletions ppx_default.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
Expand All @@ -56,26 +57,56 @@ 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 =
let label = field.pld_name in
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;
Expand Down Expand Up @@ -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 ->
Expand All @@ -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
Expand All @@ -142,32 +174,36 @@ 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
let expr =
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
"Not yet implemented to default this types: %s" ptype_name.txt
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 = [];
Expand All @@ -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
Expand Down
26 changes: 26 additions & 0 deletions tests/lib_test/other.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
5 changes: 5 additions & 0 deletions tests/lib_test/other.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1 +1,6 @@
type binding [@@deriving show, default]

module A : sig
type t[@@deriving show, default]
type 'a r[@@deriving show, default]
end
6 changes: 4 additions & 2 deletions tests/lib_test/sample.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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;
Expand All @@ -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
3 changes: 2 additions & 1 deletion tests/sample/abc.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()