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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Add copy buttons to all \u003cpre\u003e\u003ccode\u003e blocks\n(function() {\n function addCopyButtons() {\n document.querySelectorAll('pre code').forEach(function(codeBlock) {\n if (codeBlock.parentElement.hasAttribute('data-copy-added')) return;\n codeBlock.parentElement.setAttribute('data-copy-added', 'true');\n \n var btn = document.createElement('button');\n btn.textContent = 'Copy';\n btn.style.cssText = 'position:absolute;top:4px;right:4px;padding:2px 8px;font-size:11px;background:#4ecdc4;border:none;border-radius:4px;color:#1a1a2e;cursor:pointer;opacity:0.7;transition:opacity 0.2s;';\n btn.onmouseover = function() { this.style.opacity = '1'; };\n btn.onmouseout = function() { this.style.opacity = '0.7'; };\n btn.onclick = function() {\n navigator.clipboard.writeText(codeBlock.textContent).then(function() {\n btn.textContent = 'Copied!';\n setTimeout(function() { btn.textContent = 'Copy'; }, 1500);\n });\n };\n codeBlock.parentElement.style.position = 'relative';\n codeBlock.parentElement.appendChild(btn);\n });\n }\n \n addCopyButtons();\n \n // Re-run on dynamic content\n var observer = new MutationObserver(addCopyButtons);\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Add Copy Buttons to Code Blocks"); } } catch(__e) { console.warn('[Userscript:Add Copy Buttons to Code Blocks]', __e); } })(); (function(){ try { var __m = "github.com"; var __re = new RegExp('^' + "github\\.com" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Force GitHub README to respect dark mode\n(function() {\n var style = document.createElement('style');\n style.textContent = '\n .markdown-body {\n color-scheme: dark light;\n }\n .markdown-body pre { background: #161b22 !important; }\n .markdown-body code { background: rgba(110, 118, 129, 0.4) !important; }\n .markdown-body table th, .markdown-body table td { border-color: #30363d !important; }\n .markdown-body img { background: #0d1117; }\n .markdown-body blockquote { border-left-color: #8b949e; }\n .markdown-body hr { border-color: #30363d; }\n ';\n document.head.appendChild(style);\n})();", "GitHub Dark Mode README Fix"); } } catch(__e) { console.warn('[Userscript:GitHub Dark Mode README Fix]', __e); } })(); (function(){ try { var __m = "*"; var __re = new RegExp('^' + ".*" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Highlight search terms from Google/DuckDuckGo/Bing referrer\n(function() {\n var ref = document.referrer;\n var terms = [];\n \n if (ref.includes('google.com') || ref.includes('duckduckgo.com') || ref.includes('bing.com')) {\n var url = new URL(ref);\n var q = url.searchParams.get('q') || url.searchParams.get('p');\n if (q) {\n terms = q.split(/\\s+/).filter(function(t) { return t.length \u003e 2; });\n }\n }\n \n if (terms.length === 0) return;\n \n var style = document.createElement('style');\n style.textContent = '.userscript-highlight { background: #fbbf24; color: #1a1a2e; padding: 1px 3px; border-radius: 2px; }';\n document.head.appendChild(style);\n \n function highlight(node) {\n if (node.nodeType === 3) { // text node\n var text = node.textContent;\n var found = false;\n terms.forEach(function(term) {\n var regex = new RegExp('(' + term.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\') + ')', 'gi');\n if (regex.test(text)) {\n found = true;\n var frag = document.createDocumentFragment();\n var parts = text.split(regex);\n parts.forEach(function(part, i) {\n if (i % 2 === 0) {\n frag.appendChild(document.createTextNode(part));\n } else {\n var span = document.createElement('span');\n span.className = 'userscript-highlight';\n span.textContent = part;\n frag.appendChild(span);\n }\n });\n node.parentNode.replaceChild(frag, node);\n }\n });\n } else if (node.nodeType === 1 && node.childNodes) { // element\n var skipTags = ['SCRIPT', 'STYLE', 'NOSCRIPT', 'TEXTAREA', 'INPUT', 'SELECT'];\n if (!skipTags.includes(node.tagName)) {\n Array.from(node.childNodes).forEach(highlight);\n }\n }\n }\n \n highlight(document.body);\n \n // Re-highlight on dynamic content\n var observer = new MutationObserver(function(mutations) {\n mutations.forEach(function(m) {\n m.addedNodes.forEach(function(node) {\n if (node.nodeType === 1 || node.nodeType === 3) highlight(node);\n });\n });\n });\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Highlight Search Terms"); } } catch(__e) { console.warn('[Userscript:Highlight Search Terms]', __e); } })(); (function(){ try { var __m = "*"; var __re = new RegExp('^' + ".*" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Strip utm_, fbclid, gclid, etc. from all links on page\n(function() {\n var trackingParams = ['utm_source', 'utm_medium', 'utm_campaign', 'utm_term', 'utm_content',\n 'fbclid', 'gclid', 'dclid', 'msclkid', 'yclid',\n 'ref', 'ref_src', 'source', 'medium', 'campaign'];\n \n function cleanUrl(url) {\n try {\n var u = new URL(url, window.location.origin);\n var changed = false;\n trackingParams.forEach(function(p) {\n if (u.searchParams.has(p)) {\n u.searchParams.delete(p);\n changed = true;\n }\n });\n return changed ? u.toString() : url;\n } catch (e) {\n return url;\n }\n }\n \n function cleanLinks() {\n document.querySelectorAll('a[href]').forEach(function(a) {\n var clean = cleanUrl(a.href);\n if (clean !== a.href) a.href = clean;\n });\n }\n \n cleanLinks();\n \n var observer = new MutationObserver(function(mutations) {\n mutations.forEach(function(m) {\n m.addedNodes.forEach(function(node) {\n if (node.nodeType === 1) {\n if (node.tagName === 'A') cleanLinks();\n node.querySelectorAll('a[href]').forEach(function(a) {\n var clean = cleanUrl(a.href);\n if (clean !== a.href) a.href = clean;\n });\n }\n });\n });\n });\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Remove Tracking Parameters from Links"); } } catch(__e) { console.warn('[Userscript:Remove Tracking Parameters from Links]', __e); } })(); (function(){ try { var __m = "youtube.com"; var __re = new RegExp('^' + "youtube\\.com" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Auto-enable theater mode on YouTube\n(function() {\n function tryTheater() {\n var btn = document.querySelector('button[aria-label=\"Theater mode\"], ytd-player #player button[title=\"Theater mode\"]');\n if (btn && !btn.classList.contains('activated')) {\n btn.click();\n }\n }\n \n // Try immediately\n tryTheater();\n \n // Try after navigation (SPA)\n var lastUrl = location.href;\n setInterval(function() {\n if (location.href !== lastUrl) {\n lastUrl = location.href;\n setTimeout(tryTheater, 500);\n }\n }, 1000);\n \n // Also try on player load\n var observer = new MutationObserver(tryTheater);\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "YouTube Theater Mode Default"); } } catch(__e) { console.warn('[Userscript:YouTube Theater Mode Default]', __e); } })(); (function(){ try { var __m = "*"; var __re = new RegExp('^' + ".*" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Remove or un-stick sticky/fixed headers that block content\n(function() {\n function unstick() {\n document.querySelectorAll('header, nav, [role=\"banner\"], .header, .navbar, .sticky, .fixed-top, [style*=\"position: fixed\"], [style*=\"position:sticky\"]').forEach(function(el) {\n if (el.style.position === 'fixed' || el.style.position === 'sticky' || \n getComputedStyle(el).position === 'fixed' || getComputedStyle(el).position === 'sticky') {\n el.style.position = 'static';\n el.style.top = 'auto';\n el.style.zIndex = 'auto';\n }\n });\n }\n \n unstick();\n \n var observer = new MutationObserver(unstick);\n observer.observe(document.body, { childList: true, subtree: true, attributes: true, attributeFilter: ['style', 'class'] });\n})();", "Kill Sticky Headers"); } } catch(__e) { console.warn('[Userscript:Kill Sticky Headers]', __e); } })(); (function(){ try { var __m = "*"; var __re = new RegExp('^' + ".*" + '
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Universal Dark Mode - works on any site\n(function() {\n var enabled = true;\n \n function applyDarkMode() {\n if (!enabled) return;\n \n // Create style element if it doesn't exist\n var style = document.getElementById('universal-dark-mode-style');\n if (!style) {\n style = document.createElement('style');\n style.id = 'universal-dark-mode-style';\n document.head.appendChild(style);\n }\n \n // Dark mode CSS - inverts colors but preserves images/video\n style.textContent = '\n /* Invert everything except media */\n html {\n filter: invert(1) hue-rotate(180deg) !important;\n background: #1a1a2e !important;\n }\n \n /* Restore images, videos, iframes, canvas */\n img, video, iframe, canvas, svg, picture, [style*=\"background-image\"] {\n filter: invert(1) hue-rotate(180deg) !important;\n }\n \n /* Preserve specific elements that should not be inverted */\n .no-dark-mode, .no-dark-mode *,\n [data-theme=\"light\"], [data-theme=\"light\"],\n .ace_editor, .ace_editor *,\n .CodeMirror, .CodeMirror *,\n .monaco-editor, .monaco-editor *,\n .markdown-body pre, .markdown-body pre *,\n .highlight, .highlight *,\n pre code, pre code * {\n filter: none !important;\n }\n \n /* Fix common UI elements */\n .modal, .popup, .dropdown-menu, .tooltip, .popover {\n filter: invert(1) hue-rotate(180deg) !important;\n background: #2d2d44 !important;\n border-color: #444 !important;\n }\n \n /* Scrollbars */\n ::-webkit-scrollbar { background: #1a1a2e !important; }\n ::-webkit-scrollbar-thumb { background: #444 !important; }\n ::-webkit-scrollbar-thumb:hover { background: #555 !important; }\n \n /* Selection */\n ::selection { background: #4ecdc4 !important; color: #1a1a2e !important; }\n ::-moz-selection { background: #4ecdc4 !important; color: #1a1a2e !important; }\n ';\n }\n \n function removeDarkMode() {\n var style = document.getElementById('universal-dark-mode-style');\n if (style) style.remove();\n }\n \n // Toggle with Alt+Shift+D\n document.addEventListener('keydown', function(e) {\n if (e.altKey && e.shiftKey && e.key === 'D') {\n e.preventDefault();\n enabled = !enabled;\n if (enabled) {\n applyDarkMode();\n console.log('[Universal Dark Mode] Enabled');\n } else {\n removeDarkMode();\n console.log('[Universal Dark Mode] Disabled');\n }\n }\n });\n \n // Apply on load\n applyDarkMode();\n \n // Re-apply on dynamic content\n var observer = new MutationObserver(function(mutations) {\n if (enabled && !document.getElementById('universal-dark-mode-style')) {\n applyDarkMode();\n }\n });\n observer.observe(document.head, { childList: true });\n \n console.log('[Universal Dark Mode] Loaded - Press Alt+Shift+D to toggle');\n})();", "Universal Dark Mode"); } } catch(__e) { console.warn('[Userscript:Universal Dark Mode]', __e); } })(); })();
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
ProgramingIsTheFuture 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 DownExpand 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff 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 numberDiff line numberDiff line change
@@ -1 +1,2 @@
let _ = Sample.abc_default ()
let _ = Sample.default_abc ()
let _ = Sample.A.default ()