From 8939157238ccf644e584a44853c6808758993206 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Sat, 1 Jun 2024 04:50:33 +0200 Subject: [PATCH 1/3] Add `[@js.dict]` --- TYPES.md | 17 +++++++++++++++++ examples/test/test_bindings.mli | 4 ++++ lib/ojs.ml | 10 ++++++++++ lib/ojs.mli | 2 ++ ppx-lib/gen_js_api_ppx.ml | 13 +++++++++++++ 5 files changed, 46 insertions(+) diff --git a/TYPES.md b/TYPES.md index 67db38e8..4ca89c02 100644 --- a/TYPES.md +++ b/TYPES.md @@ -16,6 +16,9 @@ The following types are supported out-of-the-box: - Sequences of JS-able types: `array` and `list`, both mapped to JS arrays (which are assumed to be indexed by integers 0..length-1). + - Dictionaries of JS-able types: `(string * 'a) list` mapped to + a JS object. + - Options on JS-able types. They are mapped to the same type as their parameter: `None` is mapped to JS `null` value, and both `null` and `undefined` are mapped back to `None`. This encoding @@ -205,6 +208,20 @@ implementation). Mutually recursive type declarations are supported. - Sum type declaration with non constant constructors, mapped to records with a discriminator field (see Sum types section). + +- Association lists, mapped to JS objects + + It is possible to annotate an OCaml type declaration of the form + ``` + (string * ty) list + ``` + (where `ty` is any JS-able type) with `[@js.dict]`. When this is done, values + of this type will be mapped to JS objects in the obvious way. + + ```ocaml + type t = { headers: ((string * string) list [@js.dict]) } + ``` + - Arbitrary type with custom mappings If you want to use a type that is not supported by gen_js_api, you can make it JS-able by providing diff --git a/examples/test/test_bindings.mli b/examples/test/test_bindings.mli index 210e4221..6829c682 100644 --- a/examples/test/test_bindings.mli +++ b/examples/test/test_bindings.mli @@ -352,3 +352,7 @@ module Variants : sig end end + +module Dict : sig + type t = { h : ((string * int) list [@js.dict]) } +end diff --git a/lib/ojs.ml b/lib/ojs.ml index f9a5b523..139c6e3f 100644 --- a/lib/ojs.ml +++ b/lib/ojs.ml @@ -121,6 +121,16 @@ external iter_properties_untyped : t -> t -> unit = "caml_ojs_iterate_properties let iter_properties x f = iter_properties_untyped x (fun_to_js 1 (fun x -> f (string_of_js x))) +let dict_of_js f t = + let l = ref [] in + iter_properties t (fun k -> l := (k, f (get_prop_ascii t k)) :: !l); + !l + +let dict_to_js f x = + let t = empty_obj () in + List.iter (fun (k, v) -> set_prop_ascii t k (f v)) x; + t + let apply_arr o arr = call o "apply" [| null; arr |] let call_arr o s arr = call (get_prop o (string_to_js s)) "apply" [| o; arr |] diff --git a/lib/ojs.mli b/lib/ojs.mli index 817d743d..ce6473f4 100644 --- a/lib/ojs.mli +++ b/lib/ojs.mli @@ -42,6 +42,8 @@ val option_to_js: ('a -> t) -> 'a option -> t val unit_of_js: t -> unit val unit_to_js: unit -> t +val dict_of_js: (t -> 'a) -> t -> (string * 'a) list +val dict_to_js: ('a -> t) -> (string * 'a) list -> t (** {2 Wrap OCaml functions as JS functions} *) diff --git a/ppx-lib/gen_js_api_ppx.ml b/ppx-lib/gen_js_api_ppx.ml index 877a79cf..39f5ba86 100644 --- a/ppx-lib/gen_js_api_ppx.ml +++ b/ppx-lib/gen_js_api_ppx.ml @@ -247,6 +247,7 @@ type typ = global_attrs:attributes; attributes:attributes; constrs:constructor list } + | Dict of typ | Tuple of typ list | Typ_var of string | Packaged_type of { local_name: string; (* `a` specified by `(type a)`*) @@ -442,6 +443,11 @@ and parse_typ ~variance ctx ~global_attrs ty = begin match String.concat "." (Longident.flatten_exn lid), tl with | "unit", [] -> Unit ty.ptyp_loc | "Ojs.t", [] -> Js + | "list", [{ptyp_desc = + Ptyp_tuple + [{ptyp_desc = Ptyp_constr ({txt = Lident "string"; _}, []); _}; t]; + _}] when has_attribute "js.dict" ty.ptyp_attributes -> + Dict (parse_typ ~variance ctx ~global_attrs t) | s, tl -> Name (s, List.map (parse_typ ~variance ctx ~global_attrs) tl) end | Ptyp_variant (rows, Closed, None) -> @@ -1087,6 +1093,8 @@ let rec js2ml ty exp = app (var ("Obj.magic")) (nolabel ([exp])) false | Packaged_type { module_name; _ } -> app (var (module_name ^ ".t_of_js")) (nolabel [exp]) false + | Dict typ -> + app (var "Ojs.dict_of_js") (nolabel [js2ml_fun ~eta:true typ; exp]) false and js2ml_of_variant ~variant loc ~global_attrs attrs constrs exp = let variant_kind = get_variant_kind loc attrs in @@ -1343,6 +1351,8 @@ and ml2js ty exp = app (var ("Obj.magic")) (nolabel ([exp])) false | Packaged_type { module_name; _ } -> app (var (module_name ^ ".t_to_js")) (nolabel [exp]) false + | Dict typ -> + app (var "Ojs.dict_to_js") (nolabel [ml2js_fun ~eta:true typ; exp]) false and ml2js_discriminator ~global_attrs mlconstr attributes = match get_js_constr ~global_attrs mlconstr attributes with @@ -1567,6 +1577,9 @@ and gen_typ ?(packaged_type_as_type_var = false) = function | Packaged_type { local_name; _ } -> if packaged_type_as_type_var then Typ.var local_name else Typ.constr (mknoloc (Lident local_name)) [] + | Dict typ -> + Typ.constr (mknoloc (Lident "list")) + [gen_typ ~packaged_type_as_type_var (Tuple [Name ("string", []); typ])] and mkfun ?typ ?eta f = let s = fresh () in From e3a7ecc71203a5996b50f6276e633208a28f393b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Sun, 2 Jun 2024 22:32:37 +0200 Subject: [PATCH 2/3] Add `[@@@js.require]` --- VALUES.md | 22 ++++++++++++ examples/test/main.ml | 6 ++++ examples/test/test_bindings.mli | 7 ++++ ppx-lib/gen_js_api_ppx.ml | 63 +++++++++++++++++++-------------- 4 files changed, 71 insertions(+), 27 deletions(-) diff --git a/VALUES.md b/VALUES.md index 37365a6c..2b10703b 100644 --- a/VALUES.md +++ b/VALUES.md @@ -363,6 +363,28 @@ For instance, the following annotated modules will generate the same code: end [@js.scope "inner"] [@js.scope "outer"] ``` +Require +------- + +The signature attribute `[@@@js.require "name"]` is equivalent to making the +current global object the result of `require("name")`. This is useful to bind +Node libraries. For instance, + +```ocaml +module C: sig + [@@@js.require "crypto"] + type hash + val create_hash: unit -> hash [@@js.global] +end +``` + +will bind the `createHash` function of the Node library `crypto`, somewhat as if +we had written +``` +const { createHash } = require("crypto") +``` +in Node. + First-class modules ------------------- diff --git a/examples/test/main.ml b/examples/test/main.ml index 55b751e8..63615d55 100644 --- a/examples/test/main.ml +++ b/examples/test/main.ml @@ -341,3 +341,9 @@ let () = | hd :: tl -> Cons (hd, of_list tl) in Console3.log ([%js.of: int t] (of_list [1;2;3])) + +include [%js: + [@@@js.require "elephant"] + val x : int [@@js.global] + val y : string [@@js.global] + ] diff --git a/examples/test/test_bindings.mli b/examples/test/test_bindings.mli index 6829c682..b3539f7f 100644 --- a/examples/test/test_bindings.mli +++ b/examples/test/test_bindings.mli @@ -356,3 +356,10 @@ end module Dict : sig type t = { h : ((string * int) list [@js.dict]) } end + +module X : sig + [@@@js.require "foo"] + + val x : int -> int [@@js.global] + val y : string [@@js.global] +end diff --git a/ppx-lib/gen_js_api_ppx.ml b/ppx-lib/gen_js_api_ppx.ml index 39f5ba86..d773bba6 100644 --- a/ppx-lib/gen_js_api_ppx.ml +++ b/ppx-lib/gen_js_api_ppx.ml @@ -376,12 +376,41 @@ type decl = | Open of Parsetree.open_description | Include of Parsetree.module_expr Parsetree.include_infos +(** Utilities for code generation *) + +let longident_parse x = Longident.parse x [@@ocaml.alert "-deprecated"] + +let var x = Exp.ident (mknoloc (longident_parse x)) +let str s = Exp.constant (Pconst_string (s, Location.none, None)) +let int_of_repr n = Exp.constant (Pconst_integer (n, None)) +let int n = int_of_repr (string_of_int n) +let float_of_repr f = Exp.constant (Pconst_float (f, None)) +let bool b = Exp.construct (mknoloc (longident_parse (if b then "true" else "false"))) None +let pat_int n = Pat.constant (Pconst_integer (n, None)) +let pat_float f = Pat.constant (Pconst_float (f, None)) +let pat_str s = Pat.constant (Pconst_string (s, Location.none, None)) +let pat_bool b = Pat.construct (mknoloc (longident_parse (if b then "true" else "false"))) None + +let attr s e = (Attr.mk (mknoloc s) (PStr [Str.eval e])) + +let nolabel args = List.map (function x -> Nolabel, x) args + +let ojs_typ = Typ.constr (mknoloc (Ldot (Lident "Ojs", "t"))) [] + +let ojs_var s = Exp.ident (mknoloc (Ldot (Lident "Ojs", s))) + +let ojs s args = Exp.apply (ojs_var s) (nolabel args) + +let ojs_null = ojs_var "null" + +let node_require e = + ojs "apply" [ojs "variable" [str "require"]; Exp.array [ojs "string_to_js" [e]]] + (** Parsing *) let local_type_of_type_var label = "__"^label - let neg_variance = function | -1 -> 1 | 0 | 1 -> -1 @@ -671,6 +700,12 @@ let rec parse_sig_item ~global_attrs rest s = RecModule (List.map mapper mds) :: rest ~global_attrs | Psig_class cs -> Class (List.map (parse_class_decl ~global_attrs) cs) :: rest ~global_attrs | Psig_attribute ({attr_payload = PStr str; _} as attribute) when filter_attr_name "js.implem" attribute -> Implem str :: rest ~global_attrs + | Psig_attribute ({attr_payload = + PStr [{pstr_desc = Pstr_eval (e, _); _}]; _} as attribute) when filter_attr_name "js.require" attribute -> + let name = "__require" in + (* There can be only one in scope at any given time, so no possibility of shadowing. *) + let global_attrs = attr "js.scope" (Exp.ident (mknoloc (Lident name))) :: global_attrs in + Implem [Str.value Nonrecursive [Vb.mk (Pat.var (mknoloc name)) (node_require e)]] :: rest ~global_attrs | Psig_attribute attribute -> let global_attrs = attribute :: global_attrs in rest ~global_attrs @@ -782,21 +817,6 @@ and parse_class_field ~global_attrs = function (** Code generation *) -let longident_parse x = Longident.parse x [@@ocaml.alert "-deprecated"] - -let var x = Exp.ident (mknoloc (longident_parse x)) -let str s = Exp.constant (Pconst_string (s, Location.none, None)) -let int_of_repr n = Exp.constant (Pconst_integer (n, None)) -let int n = int_of_repr (string_of_int n) -let float_of_repr f = Exp.constant (Pconst_float (f, None)) -let bool b = Exp.construct (mknoloc (longident_parse (if b then "true" else "false"))) None -let pat_int n = Pat.constant (Pconst_integer (n, None)) -let pat_float f = Pat.constant (Pconst_float (f, None)) -let pat_str s = Pat.constant (Pconst_string (s, Location.none, None)) -let pat_bool b = Pat.construct (mknoloc (longident_parse (if b then "true" else "false"))) None - -let attr s e = (Attr.mk (mknoloc s) (PStr [Str.eval e])) - let disable_warnings = Str.attribute (attr "ocaml.warning" (str "-7-32-39")) (* 7: method overridden. 32: unused value declarations (when *_of_js, *_to_js are not needed) @@ -808,16 +828,6 @@ let incl = function | [x] -> x | str -> Str.include_ (Incl.mk (Mod.structure str)) -let nolabel args = List.map (function x -> Nolabel, x) args - -let ojs_typ = Typ.constr (mknoloc (longident_parse "Ojs.t")) [] - -let ojs_var s = Exp.ident (mknoloc (Ldot (Lident "Ojs", s))) - -let ojs s args = Exp.apply (ojs_var s) (nolabel args) - -let ojs_null = ojs_var "null" - let list_iter f x = Exp.apply (Exp.ident (mknoloc (longident_parse "List.iter"))) (nolabel [f; x]) @@ -1605,7 +1615,6 @@ let process_fields ctx ~global_attrs l = jsname, (* JS name *) parse_typ ctx ~global_attrs typ - let global_object ~global_attrs = let rec traverse = function | [] -> ojs_global From 58ce3fc4da364ef9e926cb2cd13c50f09cdedde6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Mon, 3 Jun 2024 09:19:13 +0200 Subject: [PATCH 3/3] Add `[@js.capitalize]` and `[@@js.capitalize]` --- TYPES.md | 11 +++++++---- examples/test/test_bindings.mli | 3 ++- ppx-lib/gen_js_api_ppx.ml | 4 ++-- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/TYPES.md b/TYPES.md index 4ca89c02..4b30235c 100644 --- a/TYPES.md +++ b/TYPES.md @@ -181,14 +181,18 @@ implementation). Mutually recursive type declarations are supported. be mutable (but conversions still create copies). Polymorphic fields are not yet supported. - OCaml record values of this type are mapped to JS objects (one - property per field). By default, property names are equal to OCaml - labels, but this can be changed manually with a `[@js]` attribute. + OCaml record values of this type are mapped to JS objects (one property per + field). By default, property names are equal to the OCaml labels converted to + camelCase, but this can be changed manually with a `[@js]` attribute. ```ocaml type myType = { x : int; y : int [@js "Y"]} ``` + If one needs the JS labels to be capitalized (ie `CamelCase` instead of + `camelCase`) this can be achieved by adding the `[@js.capitalize]` attribute + to a record label or `[@@js.capitalize]` to the whole record type declaration. + - Parametrized Type: It is allowed to parametrize types processed by gen_js_api as long as @@ -492,4 +496,3 @@ end You can also create safe bindings manually with the low level functions provided by `Ojs` module. See the [section on manually created bindings](LOW_LEVEL_BINDING.md) for more information. - diff --git a/examples/test/test_bindings.mli b/examples/test/test_bindings.mli index b3539f7f..2031b165 100644 --- a/examples/test/test_bindings.mli +++ b/examples/test/test_bindings.mli @@ -354,7 +354,8 @@ module Variants : sig end module Dict : sig - type t = { h : ((string * int) list [@js.dict]) } + type t = { item_chosen : ((string * int) list [@js.dict]) } [@@js.capitalize] + type s = { foo: int [@js.capitalize]; bar: string } end module X : sig diff --git a/ppx-lib/gen_js_api_ppx.ml b/ppx-lib/gen_js_api_ppx.ml index d773bba6..759f1327 100644 --- a/ppx-lib/gen_js_api_ppx.ml +++ b/ppx-lib/gen_js_api_ppx.ml @@ -208,7 +208,7 @@ let js_name ~global_attrs ?(capitalize = false) name = else let n = String.length name in let buf = Buffer.create n in - let capitalize = ref capitalize in + let capitalize = ref (has_attribute "js.capitalize" global_attrs || capitalize) in for i = 0 to n-1 do let c = name.[i] in if c = '_' then capitalize := true @@ -1607,7 +1607,7 @@ let process_fields ctx ~global_attrs l = let typ = l.pld_type in let jsname = match get_string_attribute "js" attrs with - | None -> js_name ~global_attrs mlname + | None -> js_name ~global_attrs ~capitalize:(has_attribute "js.capitalize" attrs) mlname | Some s -> s in loc,