diff --git a/CHANGES.md b/CHANGES.md index 5a90821e..d73873f2 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,12 @@ Changelog ========= +Unreleased +---------- + +- Support for binding to js_of_ocaml runtime primitives via `@`-prefixed payloads on `[@@js.global]` and `[@@@js.scope "@..."]`, enabling generated bindings to target values supplied by the JavaScript runtime. +- Test suite updates adapted for wasm_of_ocaml. + Version 1.1.6 ------------- diff --git a/NODE_RUNTIME_BINDINGS.md b/NODE_RUNTIME_BINDINGS.md new file mode 100644 index 00000000..cb0e46c1 --- /dev/null +++ b/NODE_RUNTIME_BINDINGS.md @@ -0,0 +1,153 @@ +# Binding Node.js Modules with Runtime Primitives + +This guide shows how to use the new runtime primitive support in `gen_js_api` to bind Node.js libraries that are usually obtained with `require(...)`. The feature hinges on two additions: + +- any `[@@js.global "@primitive_name"]` binding returns an `Ojs.t` pointing to a primitive exported by the JavaScript runtime; +- a scope string that starts with `@` (for example `[@@@js.scope "@node_fs.promises"]`) resolves the first path component through the runtime primitives before following regular properties. + +Together, those tools let you keep your bindings declarative while delegating the actual `require` calls to a tiny JavaScript stub. + +## Example layout + +``` +runtime_primitives/ + dune + imports.js + imports.wat + bindings.mli + example.ml +``` + +### Step 1 - expose the runtime primitives + +Create a JavaScript file that `require`s the Node modules you need and publishes them as js_of_ocaml runtime primitives. The js_of_ocaml linker recognises `//Provides: ` comments and registers the value under that name at startup. + +```javascript +// runtime_primitives/imports.js +'use strict'; + +//Provides: node_path +var node_path = require('path'); + +//Provides: node_fs +var node_fs = require('fs'); + +//Provides: node_version +var node_version = require('process').version; + +//Provides: node_console +var node_console = console.log; + +``` + +When targeting WebAssembly you also need to expose the primitives through a `.wat` shim so that `wasm_of_ocaml` can import them at runtime: + +```wat +;; runtime_primitives/imports.wat +(global (export "_node_path") (import "js" "node_path") anyref) +(global (export "_node_fs") (import "js" "node_fs") anyref) +(global (export "_node_version") (import "js" "node_version") anyref) +(global (export "_node_console") (import "js" "node_console") anyref) +``` + +List this file in your dune stanza so that js_of_ocaml ships it with the compiled artefacts: + +``` +; runtime_primitives/dune +(rule + (targets bindings.ml) + (deps bindings.mli) + (action (run gen_js_api %{deps}))) + +(executable + (name example) + (libraries ojs) + (preprocess (pps gen_js_api.ppx)) + (modes js wasm) + (js_of_ocaml (javascript_files imports.js)) + (wasm_of_ocaml (javascript_files imports.js imports.wat))) +``` + +Adding the file to both `js_of_ocaml` and `wasm_of_ocaml` makes the primitives available in browser and wasm builds alike. + +### Step 2 - bind module functions with `[@js.scope "@..."]` + +Use `module [@js.scope "@primitive"]` blocks to call methods on runtime primitives without manually threading the module objects. The interface below covers the synchronous filesystem API used in the reference JavaScript while keeping the underlying modules abstract. + +```ocaml +(* runtime_primitives/bindings.mli *) +module [@js.scope "@node_fs"] Fs : sig + val write_file_sync : string -> string -> unit [@@js.global "writeFileSync"] + val read_file_sync : string -> encoding:string -> string [@@js.global "readFileSync"] + val readdir_sync : string -> string array [@@js.global "readdirSync"] + val append_file_sync : string -> string -> unit [@@js.global "appendFileSync"] +end + +module [@js.scope "@node_path"] Path : sig + val separator: string [@@js.global "sep"] + val join : (string list [@js.variadic]) -> string [@@js.global "join"] +end +``` +Each module-level scope starts with `@`, so the ppx turns calls like `Fs.write_file_sync` into direct invocations on the corresponding Node module (`node_fs.writeFileSync` in this case) without requiring you to pass the module object around. + +### Step 3 - bind direct values with `@`-prefixed `[@@js.global]` + +When you only need the primitive itself—such as a constant exported by a Node module—use the `@` prefix inside `[@@js.global]` to obtain it directly as an OCaml value. + +```ocaml +(* runtime_primitives/primitives_bindings.mli continued *) + +val node_version : string [@@js.global "@node_version"] +val log : string -> unit [@@js.global "@node_console"] +``` + +These expand to `Jsoo_runtime.Js.runtime_value ...` calls and convert the results to the requested OCaml types, so you can expose constants or functions alongside the scoped modules described above. + +### Step 4 - port the JavaScript example + +`main.ml` mirrors the original JavaScript snippet that writes, reads, appends, and re-reads a file while logging progress to the Node console. It relies on the scoped `Fs`/`Path` modules plus the direct `log`, `path_separator`, and `node_version` values. + +```ocaml +open Bindings + +let initial_content = "Hello, Node.js!" +let appended_line = "\nAppending a new line." +let encoding = "utf-8" +let filename = "example.txt" + +let run () = + let file = Path.join ["."; filename] in + + Fs.write_file_sync file initial_content; + + let content = Fs.read_file_sync file ~encoding in + if content <> initial_content then + failwith "Unexpected initial content"; + log ("File content: " ^ content); + + let files = Fs.readdir_sync "." |> Array.to_list in + if not (List.mem filename files) then + failwith "example.txt missing from directory listing"; + log ("Files in current directory: " ^ String.concat ", " files); + + Fs.append_file_sync file appended_line; + + let updated = Fs.read_file_sync file ~encoding in + if updated <> initial_content ^ appended_line then + failwith "Append failed"; + log ("Updated content: " ^ updated); + log ("Path separator reported by Node: " ^ Path.separator); + log ("Node.js version: " ^ node_version) + + +let () = run () +``` + +### Putting it together + +1. Declare each required Node module once in `imports.js` (and mirror them in `imports.wat` for wasm) using the js_of_ocaml `//Provides:` convention. +2. Export the files through dune so that the js_of_ocaml toolchain registers those primitives at runtime. +3. Map node modules in OCaml with `module [@js.scope "@primitive"]` blocks, and use `@`-prefixed `[@@js.global]` bindings for direct values. +4. Consume the generated modules from OCaml exactly as you would in JavaScript, as shown in `example.ml`. + +With these pieces in place you can keep writing high-level `gen_js_api` bindings while relying on the new runtime primitive support to bridge your OCaml code to Node-specific libraries provided via `require`. diff --git a/dune-project b/dune-project index 5437b37c..d23bdda7 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.0) +(lang dune 3.17) (name gen_js_api) (version 1.1.6) diff --git a/gen_js_api.opam b/gen_js_api.opam index 177f4110..15aee1d9 100644 --- a/gen_js_api.opam +++ b/gen_js_api.opam @@ -20,7 +20,7 @@ license: "MIT" homepage: "https://github.com/LexiFi/gen_js_api" bug-reports: "https://github.com/LexiFi/gen_js_api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.17"} "ocaml" {>= "4.13"} "ppxlib" {>= "0.37"} "js_of_ocaml-compiler" {with-test} diff --git a/lib/ojs.mli b/lib/ojs.mli index 817d743d..85b413da 100644 --- a/lib/ojs.mli +++ b/lib/ojs.mli @@ -163,4 +163,4 @@ module Bool : T with type t = bool module Float : T with type t = float module Array (A: T) : T with type t = A.t array module List (A: T) : T with type t = A.t list -module Option (A: T) : T with type t = A.t option \ No newline at end of file +module Option (A: T) : T with type t = A.t option diff --git a/node-test/bindings/dune b/node-test/bindings/dune index ef8c2e97..949cd381 100644 --- a/node-test/bindings/dune +++ b/node-test/bindings/dune @@ -6,7 +6,9 @@ (pps gen_js_api.ppx)) (modes byte) (js_of_ocaml - (javascript_files imports.js))) + (javascript_files imports.js)) + (wasm_of_ocaml + (javascript_files imports.js imports.wat))) (rule (targets imports.ml) diff --git a/node-test/bindings/expected/fs.ml b/node-test/bindings/expected/fs.ml index 863f1307..58569cce 100644 --- a/node-test/bindings/expected/fs.ml +++ b/node-test/bindings/expected/fs.ml @@ -84,25 +84,32 @@ let readdir : string -> string list Promise.t = fun (x39 : string) -> Promise.t_of_js (fun (x40 : Ojs.t) -> Ojs.list_of_js Ojs.string_of_js x40) - (Ojs.call (Ojs.get_prop_ascii Imports.fs "promises") "readdir" - [|(Ojs.string_to_js x39)|]) + (Ojs.call + (Ojs.get_prop_ascii (Jsoo_runtime.Js.runtime_value "node_fs") + "promises") "readdir" [|(Ojs.string_to_js x39)|]) let open_ : string -> flag:string -> FileHandle.t Promise.t = fun (x42 : string) ~flag:(x43 : string) -> Promise.t_of_js FileHandle.t_of_js - (Ojs.call (Ojs.get_prop_ascii Imports.fs "promises") "open" + (Ojs.call + (Ojs.get_prop_ascii (Jsoo_runtime.Js.runtime_value "node_fs") + "promises") "open" [|(Ojs.string_to_js x42);(Ojs.string_to_js x43)|]) let rmdir : string -> unit Promise.t = fun (x45 : string) -> Promise.t_of_js Ojs.unit_of_js - (Ojs.call (Ojs.get_prop_ascii Imports.fs "promises") "rmdir" - [|(Ojs.string_to_js x45)|]) + (Ojs.call + (Ojs.get_prop_ascii (Jsoo_runtime.Js.runtime_value "node_fs") + "promises") "rmdir" [|(Ojs.string_to_js x45)|]) let rename : string -> string -> unit Promise.t = fun (x47 : string) (x48 : string) -> Promise.t_of_js Ojs.unit_of_js - (Ojs.call (Ojs.get_prop_ascii Imports.fs "promises") "rename" + (Ojs.call + (Ojs.get_prop_ascii (Jsoo_runtime.Js.runtime_value "node_fs") + "promises") "rename" [|(Ojs.string_to_js x47);(Ojs.string_to_js x48)|]) let unlink : string -> unit Promise.t = fun (x50 : string) -> Promise.t_of_js Ojs.unit_of_js - (Ojs.call (Ojs.get_prop_ascii Imports.fs "promises") "unlink" - [|(Ojs.string_to_js x50)|]) + (Ojs.call + (Ojs.get_prop_ascii (Jsoo_runtime.Js.runtime_value "node_fs") + "promises") "unlink" [|(Ojs.string_to_js x50)|]) diff --git a/node-test/bindings/expected/imports.ml b/node-test/bindings/expected/imports.ml index e919d127..d0d4aba3 100644 --- a/node-test/bindings/expected/imports.ml +++ b/node-test/bindings/expected/imports.ml @@ -1,8 +1,3 @@ [@@@js.dummy "!! This code has been generated by gen_js_api !!"] [@@@ocaml.warning "-7-32-39"] -let path : Ojs.t = - Ojs.get_prop_ascii (Ojs.get_prop_ascii Ojs.global "__LIB__NODE__IMPORTS") - "path" -let fs : Ojs.t = - Ojs.get_prop_ascii (Ojs.get_prop_ascii Ojs.global "__LIB__NODE__IMPORTS") - "fs" +let path : Ojs.t = Jsoo_runtime.Js.runtime_value "node_path" diff --git a/node-test/bindings/fs.mli b/node-test/bindings/fs.mli index 67b4b17c..a23fe677 100644 --- a/node-test/bindings/fs.mli +++ b/node-test/bindings/fs.mli @@ -1,4 +1,4 @@ -[@@@js.scope (Imports.fs, "promises")] +[@@@js.scope "@node_fs.promises"] module Dirent : sig type t = Ojs.t diff --git a/node-test/bindings/imports.js b/node-test/bindings/imports.js index 5f63e5a7..904d9516 100644 --- a/node-test/bindings/imports.js +++ b/node-test/bindings/imports.js @@ -1,4 +1,5 @@ -globalThis.__LIB__NODE__IMPORTS = { - path: require('path'), - fs: require('fs'), -}; +//Provides: node_path +var node_path = require('path'); + +//Provides: node_fs +var node_fs = require('fs'); diff --git a/node-test/bindings/imports.mli b/node-test/bindings/imports.mli index 9438019a..8203f567 100644 --- a/node-test/bindings/imports.mli +++ b/node-test/bindings/imports.mli @@ -1,4 +1 @@ -[@@@js.scope "__LIB__NODE__IMPORTS"] - -val path: Ojs.t [@@js.global] -val fs: Ojs.t [@@js.global] +val path: Ojs.t [@@js.global "@node_path"] diff --git a/node-test/bindings/imports.wat b/node-test/bindings/imports.wat new file mode 100644 index 00000000..ba7e3d0e --- /dev/null +++ b/node-test/bindings/imports.wat @@ -0,0 +1,3 @@ + +(global (export "_node_path") (import "js" "node_path") anyref) +(global (export "_node_fs") (import "js" "node_fs") anyref) diff --git a/node-test/bindings/number.mli b/node-test/bindings/number.mli index f6126dea..d2caa78c 100644 --- a/node-test/bindings/number.mli +++ b/node-test/bindings/number.mli @@ -34,4 +34,4 @@ module Static : sig val negative_infinity: t -> float [@@js.get "NEGATIVE_INFINITY"] val positive_infinity: t -> float [@@js.get "POSITIVE_INFINITY"] end -val number: Static.t [@@js.global "Number"] \ No newline at end of file +val number: Static.t [@@js.global "Number"] diff --git a/node-test/runtime_primitives/bindings.mli b/node-test/runtime_primitives/bindings.mli new file mode 100644 index 00000000..c1d74f5f --- /dev/null +++ b/node-test/runtime_primitives/bindings.mli @@ -0,0 +1,14 @@ +module [@js.scope "@node_fs"] Fs : sig + val write_file_sync : string -> string -> unit [@@js.global "writeFileSync"] + val read_file_sync : string -> encoding:string -> string [@@js.global "readFileSync"] + val readdir_sync : string -> string array [@@js.global "readdirSync"] + val append_file_sync : string -> string -> unit [@@js.global "appendFileSync"] +end + +module [@js.scope "@node_path"] Path : sig + val separator: string [@@js.global "sep"] + val join : (string list [@js.variadic]) -> string [@@js.global "join"] +end + +val node_version : string [@@js.global "@node_version"] +val log : string -> unit [@@js.global "@node_console"] diff --git a/node-test/runtime_primitives/dune b/node-test/runtime_primitives/dune new file mode 100644 index 00000000..8f008ddb --- /dev/null +++ b/node-test/runtime_primitives/dune @@ -0,0 +1,28 @@ +(rule + (targets bindings.ml) + (deps bindings.mli) + (action + (run gen_js_api %{deps}))) + +(executable + (name example) + (libraries ojs) + (preprocess + (pps gen_js_api.ppx)) + (modes js wasm) + (js_of_ocaml + (javascript_files imports.js)) + (wasm_of_ocaml + (javascript_files imports.js imports.wat))) + +(rule + (alias runtest) + (enabled_if %{bin-available:node}) + (action + (run node %{dep:./example.bc.js}))) + +(rule + (alias runtest-wasm) + (enabled_if %{bin-available:node}) + (action + (run node %{dep:./example.bc.wasm.js}))) diff --git a/node-test/runtime_primitives/example.ml b/node-test/runtime_primitives/example.ml new file mode 100644 index 00000000..3ddd96ab --- /dev/null +++ b/node-test/runtime_primitives/example.ml @@ -0,0 +1,33 @@ +open Bindings + +let initial_content = "Hello, Node.js!" +let appended_line = "\nAppending a new line." +let encoding = "utf-8" +let filename = "example.txt" + +let run () = + let file = Path.join ["."; filename] in + + Fs.write_file_sync file initial_content; + + let content = Fs.read_file_sync file ~encoding in + if content <> initial_content then + failwith "Unexpected initial content"; + log ("File content: " ^ content); + + let files = Fs.readdir_sync "." |> Array.to_list in + if not (List.mem filename files) then + failwith "example.txt missing from directory listing"; + log ("Files in current directory: " ^ String.concat ", " files); + + Fs.append_file_sync file appended_line; + + let updated = Fs.read_file_sync file ~encoding in + if updated <> initial_content ^ appended_line then + failwith "Append failed"; + log ("Updated content: " ^ updated); + log ("Path separator reported by Node: " ^ Path.separator); + log ("Node.js version: " ^ node_version) + + +let () = run () diff --git a/node-test/runtime_primitives/imports.js b/node-test/runtime_primitives/imports.js new file mode 100644 index 00000000..f5878c0f --- /dev/null +++ b/node-test/runtime_primitives/imports.js @@ -0,0 +1,13 @@ +'use strict'; + +//Provides: node_path +var node_path = require('path'); + +//Provides: node_fs +var node_fs = require('fs'); + +//Provides: node_version +var node_version = require('process').version; + +//Provides: node_console +var node_console = console.log; diff --git a/node-test/runtime_primitives/imports.wat b/node-test/runtime_primitives/imports.wat new file mode 100644 index 00000000..c70c39d2 --- /dev/null +++ b/node-test/runtime_primitives/imports.wat @@ -0,0 +1,4 @@ +(global (export "_node_path") (import "js" "node_path") anyref) +(global (export "_node_fs") (import "js" "node_fs") anyref) +(global (export "_node_version") (import "js" "node_version") anyref) +(global (export "_node_console") (import "js" "node_console") anyref) diff --git a/node-test/test1/dune b/node-test/test1/dune index cf831ffb..b2bfbabb 100644 --- a/node-test/test1/dune +++ b/node-test/test1/dune @@ -3,8 +3,10 @@ (libraries ojs node) (preprocess (pps gen_js_api.ppx)) - (modes js) + (modes js wasm) (js_of_ocaml + (javascript_files recursive.js)) + (wasm_of_ocaml (javascript_files recursive.js))) (rule @@ -18,3 +20,9 @@ (enabled_if %{bin-available:node}) (action (run node %{dep:./test.bc.js}))) + +(rule + (alias runtest-wasm) + (enabled_if %{bin-available:node}) + (action + (run node %{dep:./test.bc.wasm.js}))) diff --git a/node-test/test1/recursive.js b/node-test/test1/recursive.js index 62086283..2a218aa1 100644 --- a/node-test/test1/recursive.js +++ b/node-test/test1/recursive.js @@ -1,3 +1,4 @@ + var Foo = /*#__PURE__*/function () { "use strict"; @@ -18,6 +19,7 @@ var Foo = /*#__PURE__*/function () { return Foo; }(); + var Bar = /*#__PURE__*/function () { "use strict"; diff --git a/node-test/test1/test.ml b/node-test/test1/test.ml index 7dadaa2b..f63996ed 100644 --- a/node-test/test1/test.ml +++ b/node-test/test1/test.ml @@ -232,29 +232,30 @@ let () = (** Arrays **) let () = - let open Arrays.StringArray in - let a = create () in - for k = 0 to 10 do - push a (string_of_int k); - done; - let s = join a "," in - List.iteri (fun k x -> + let open Arrays.StringArray in + let a = create () in + for k = 0 to 10 do + push a (string_of_int k); + done; + let s = join a "," in + List.iteri (fun k x -> assert (string_of_int k = x) ) (String.split_on_char ',' s) (** Invoking a global object **) (** https://developer.mozilla.org/ja/docs/Web/JavaScript/Reference/Global_Objects/Number/Number **) let () = - let check (a: Number.t) (b: float) = - assert (Ojs.instance_of (a :> Ojs.t) ~constr:(Number.number :> Ojs.t)); - assert (not (Ojs.instance_of (Ojs.float_to_js b) ~constr:(Number.number :> Ojs.t))); - assert (Number.valueOf a = b); - () - in - check (Number.Scoped.create "123") (Number.Scoped.invoke "123"); - check (Number.Static.create Number.number "123") (Number.Static.apply Number.number "123"); - assert (Number.Scoped.max_value = Number.Static.max_value Number.number); + let check (a: Number.t) (b: float) = + assert (Ojs.instance_of (a :> Ojs.t) ~constr:(Number.number :> Ojs.t)); + assert (not (Ojs.instance_of (Ojs.float_to_js b) ~constr:(Number.number :> Ojs.t))); + assert (Number.valueOf a = b); () + in + let s = Ojs.string_to_js "123" in + check (Number.Scoped.create s) (Number.Scoped.invoke s); + check (Number.Static.create Number.number s) (Number.Static.apply Number.number s); + assert (Number.Scoped.max_value = Number.Static.max_value Number.number); + () (** Using recursive modules **) let () = @@ -291,8 +292,8 @@ let () = let sa = join a "," in List.iteri (fun k x -> - assert (string_of_int k = x) - ) (String.split_on_char ',' sa); + assert (string_of_int k = x) + ) (String.split_on_char ',' sa); let b = let orig = List.init 11 string_of_int in diff --git a/ojs.opam b/ojs.opam index 7d8adb6f..e62e1e7f 100644 --- a/ojs.opam +++ b/ojs.opam @@ -12,7 +12,7 @@ license: "MIT" homepage: "https://github.com/LexiFi/gen_js_api" bug-reports: "https://github.com/LexiFi/gen_js_api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.17"} "ocaml" {>= "4.13"} "js_of_ocaml-compiler" {>= "4.0.0"} "odoc" {with-doc} diff --git a/ppx-lib/gen_js_api_ppx.ml b/ppx-lib/gen_js_api_ppx.ml index c18023a3..56f9ffb8 100644 --- a/ppx-lib/gen_js_api_ppx.ml +++ b/ppx-lib/gen_js_api_ppx.ml @@ -45,6 +45,7 @@ type error = | Sum_kind_args | Union_without_discriminator | Contravariant_type_parameter of string + | Cannot_set_runtime_value of string exception Error of Location.t * error @@ -181,6 +182,8 @@ let print_error ppf = function Format.fprintf ppf "Contravariant type parameter '%s is not allowed." label | Record_expected shape -> Format.fprintf ppf "Record %s expected." shape + | Cannot_set_runtime_value name -> + Format.fprintf ppf "Cannot set runtime value '%s'." name let () = Location.Error.register_error_of_exn @@ -892,54 +895,76 @@ let ojs_set o s v = else ojs "set_prop" [o; ojs "string_to_js" [str s]; v] +let split_at s = + if String.length s > 0 && s.[0] = '@' then + Some (String.sub s 1 (String.length s - 1)) + else None + +let runtime s = + let runtime_value = Exp.ident (mknoloc (longident_parse "Jsoo_runtime.Js.runtime_value")) in + Exp.apply runtime_value (nolabel [Exp.constant (Pconst_string (s, Location.none, None))]) + +let rec select_split_path o = function + | [] -> assert false + | (hd :: tl) as l -> + let o, l = + match split_at hd with + | Some s -> runtime s, tl + | None -> o, l + in + match l with + | [] -> o, None + | [x] -> o, Some x + | hd :: tl -> select_split_path (ojs_get o hd) tl + let select_path o s = - let rec select_path o = function - | [] -> assert false - | [x] -> o, x - | x :: xs -> select_path (ojs_get o x) xs - in - select_path o (split '.' s) + select_split_path o (split '.' s) let get_path global_object s = let o, x = select_path global_object s in - ojs_get o x + match x with + | None -> o + | Some x -> ojs_get o x let ojs_variable s = get_path ojs_global s -let set_path global_object s v = +let set_path ~loc global_object s v = let o, x = select_path global_object s in - ojs_set o x v + match x with + | None -> error loc (Cannot_set_runtime_value s) + | Some x -> + ojs_set o x v let def ?packages s ty body = let ty, body = match packages with | None | Some [] -> ty, body | Some packages -> - (* append module arguments *) - let folder1 (ty, body) (local_name, module_name) = - let package is_local = - let t = - if is_local then Typ.constr (mknoloc (Lident local_name)) [] - else Typ.var local_name - in - Typ.package (mknoloc (Ldot (Lident "Ojs", "T"))) [mknoloc (Lident "t"), t] in - let ty = Typ.arrow Nolabel (package false) ty in - let body = - let arg = - Pat.constraint_ - (Pat.unpack (mknoloc (Some module_name))) - (package true) + (* append module arguments *) + let folder1 (ty, body) (local_name, module_name) = + let package is_local = + let t = + if is_local then Typ.constr (mknoloc (Lident local_name)) [] + else Typ.var local_name + in + Typ.package (mknoloc (Ldot (Lident "Ojs", "T"))) [mknoloc (Lident "t"), t] in + let ty = Typ.arrow Nolabel (package false) ty in + let body = + let arg = + Pat.constraint_ + (Pat.unpack (mknoloc (Some module_name))) + (package true) + in + Ast_builder.Default.pexp_fun ~loc:Location.none Nolabel None arg body in - Ast_builder.Default.pexp_fun ~loc:Location.none Nolabel None arg body + ty, body in - ty, body - in - (* append locally abstract types *) - let folder2 (ty, body) (local_name, _) = - ty, Exp.newtype (mknoloc local_name) body - in - List.fold_left folder2 (List.fold_left folder1 (ty, body) packages) packages + (* append locally abstract types *) + let folder2 (ty, body) (local_name, _) = + ty, Exp.newtype (mknoloc local_name) body + in + List.fold_left folder2 (List.fold_left folder1 (ty, body) packages) packages in Str.value Nonrecursive [ Vb.mk ~value_constraint:(Pvc_constraint { locally_abstract_univars = []; typ = ty}) (Pat.var (mknoloc s)) body ] @@ -958,9 +983,16 @@ let ojs_apply_arr o = function | `Push arr -> ojs "call" [o; str "apply"; Exp.array [ ojs_null; arr ]] -let ojs_call_arr o s = function - | `Simple arr -> ojs "call" [o; str s; arr] - | `Push arr -> +let ojs_call_arr o s meth = + match s, meth with + | None, `Simple arr -> ojs "apply" [o; arr] + | Some s, `Simple arr -> ojs "call" [o; str s; arr] + | None, `Push arr -> + let_exp_in o + (fun o -> + ojs "call" [o; str "apply"; Exp.array [ ojs_null ; arr ]] + ) + | Some s, `Push arr -> let_exp_in o (fun o -> ojs "call" [ojs_get o s; str "apply"; Exp.array [ o; arr ]] @@ -1185,10 +1217,10 @@ and js2ml_of_variant ~variant loc ~global_attrs attrs constrs exp = let rec has_dup = function | [] | [ _ ] -> () | x :: ((y :: _) as l) -> - if compare_values x y = 0 then - error loc (Duplicate_case_value (x.loc, y.loc)) - else - has_dup l + if compare_values x y = 0 then + error loc (Duplicate_case_value (x.loc, y.loc)) + else + has_dup l in has_dup l in @@ -1238,18 +1270,18 @@ and js2ml_of_variant ~variant loc ~global_attrs attrs constrs exp = | Some m, None | None, Some m -> Some m | None, None -> None | Some _, Some _ -> - match int_default, float_default with - | _, None -> get_float_match (default_expr int_match) - | None, Some d -> - let case = - match get_int_match (default_expr (Some d.pc_rhs)) with - | None -> d - | Some int_match -> { d with pc_rhs = int_match } - in - get_float_match (Some case) - | Some d1, Some d2 -> - if d1 = d2 then get_float_match (default_expr int_match) - else error loc Multiple_default_case + match int_default, float_default with + | _, None -> get_float_match (default_expr int_match) + | None, Some d -> + let case = + match get_int_match (default_expr (Some d.pc_rhs)) with + | None -> d + | Some int_match -> { d with pc_rhs = int_match } + in + get_float_match (Some case) + | Some d1, Some d2 -> + if d1 = d2 then get_float_match (default_expr int_match) + else error loc Multiple_default_case in let string_match = gen_match ~fail_pattern:true (js2ml string_typ discriminator) string_default string_cases in let bool_match = gen_match ~fail_pattern:generate_fail_pattern_for_bool (js2ml bool_typ discriminator) bool_default bool_cases in @@ -1395,24 +1427,24 @@ and ml2js_of_variant ~variant loc ~global_attrs attrs constrs exp = | Nary args_typ -> begin match variant_kind with | `Enum | `Sum _ -> - let loc, args_field = get_string_attribute_default "js.arg" (location, "arg") attributes in - check_label loc args_field; - let xis = List.mapi (fun i typ -> i, typ, fresh()) args_typ in - let n_args = List.length xis in - Exp.case - (mkpat mlconstr (Some (Pat.tuple (List.map (fun (_, _, xi) -> Pat.var (mknoloc xi)) xis)))) - (let args = fresh() in - Exp.let_ Nonrecursive - [Vb.mk (Pat.var (mknoloc args)) (ojs "array_make" [int n_args])] - (List.fold_left - (fun e (i, typi, xi) -> - Exp.sequence - (ojs "array_set" [var args; int i; ml2js typi (var xi)]) e) - (mkobj [pair args_field Js (var args)]) - xis)) + let loc, args_field = get_string_attribute_default "js.arg" (location, "arg") attributes in + check_label loc args_field; + let xis = List.mapi (fun i typ -> i, typ, fresh()) args_typ in + let n_args = List.length xis in + Exp.case + (mkpat mlconstr (Some (Pat.tuple (List.map (fun (_, _, xi) -> Pat.var (mknoloc xi)) xis)))) + (let args = fresh() in + Exp.let_ Nonrecursive + [Vb.mk (Pat.var (mknoloc args)) (ojs "array_make" [int n_args])] + (List.fold_left + (fun e (i, typi, xi) -> + Exp.sequence + (ojs "array_set" [var args; int i; ml2js typi (var xi)]) e) + (mkobj [pair args_field Js (var args)]) + xis)) | `Union _ -> (* treat it as a tuple of the constructor arguments *) - let x = fresh() in - Exp.case (mkpat mlconstr (Some (Pat.var (mknoloc x)))) (ml2js (Tuple args_typ) (var x)) + let x = fresh() in + Exp.case (mkpat mlconstr (Some (Pat.var (mknoloc x)))) (ml2js (Tuple args_typ) (var x)) end | Record args -> let x = fresh() in @@ -1552,7 +1584,7 @@ and gen_typ ?(packaged_type_as_type_var = false) = function in let tl = if unit_arg then tl @ [{lab=Arg;att=[];typ=Unit none}] else tl in List.fold_right (fun {lab; att=_; typ} t2 -> - Typ.arrow (arg_label lab) (gen_typ ~packaged_type_as_type_var typ) t2) tl (gen_typ ~packaged_type_as_type_var ty_res) + Typ.arrow (arg_label lab) (gen_typ ~packaged_type_as_type_var typ) t2) tl (gen_typ ~packaged_type_as_type_var ty_res) | Variant {location = _; global_attrs = _; attributes = _; constrs} -> let f {mlconstr; arg; attributes = _; location = _} = let mlconstr = mknoloc mlconstr in @@ -1568,8 +1600,8 @@ and gen_typ ?(packaged_type_as_type_var = false) = function Typ.tuple (List.map (gen_typ ~packaged_type_as_type_var) typs) | Typ_var label -> Typ.var label | Packaged_type { local_name; _ } -> - if packaged_type_as_type_var then Typ.var local_name - else Typ.constr (mknoloc (Lident local_name)) [] + if packaged_type_as_type_var then Typ.var local_name + else Typ.constr (mknoloc (Lident local_name)) [] and mkfun ?typ ?eta f = let s = fresh () in @@ -1602,15 +1634,17 @@ let global_object ~global_attrs = | hd :: tl -> begin match get_expr_attribute "js.scope" [hd] with | None -> traverse tl - | Some {pexp_desc=Pexp_constant (Pconst_string (prop, _, _)); _} -> ojs_get (traverse tl) prop + | Some {pexp_desc=Pexp_constant (Pconst_string (prop, _, _)); _} -> + get_path (traverse tl) prop + | Some {pexp_desc=Pexp_tuple path; _} -> - let init = traverse tl in - let folder state pexp = - match pexp.pexp_desc with - | Pexp_constant (Pconst_string (prop, _, _)) -> ojs_get state prop - | _ -> pexp (* global object *) - in - List.fold_left folder init path + let init = traverse tl in + let folder state pexp = + match pexp.pexp_desc with + | Pexp_constant (Pconst_string (prop, _, _)) -> get_path state prop + | _ -> pexp (* global object *) + in + List.fold_left folder init path | Some global_object -> global_object end in @@ -1738,31 +1772,31 @@ and gen_funs ~global_attrs p = match body with | None -> None | Some body -> - let params = - List.concat [ - List.map - (fun label -> + let params = + List.concat [ + List.map + (fun label -> { pparam_loc = loc; pparam_desc = Pparam_newtype - ({ label with txt = local_type_of_type_var label.txt})} - ) ctx_withloc; - List.map - (fun label -> + ({ label with txt = local_type_of_type_var label.txt})} + ) ctx_withloc; + List.map + (fun label -> let name = (local_type_of_type_var label)^suffix in let label = Name (local_type_of_type_var label, []) in { pparam_loc = loc; pparam_desc = Pparam_val (Nolabel, None, (Pat.constraint_ (Pat.var (mknoloc name)) (gen_typ (typ label))))} - ) ctx - ] - in - match params with - | [] -> Some body - | params -> - Some - ( - Ast_builder.Default.pexp_function ~loc - params - None (Pfunction_body body)) + ) ctx + ] + in + match params with + | [] -> Some body + | params -> + Some + ( + Ast_builder.Default.pexp_function ~loc + params + None (Pfunction_body body)) in let f (name, input_typs, ret_typ, code) = match code with @@ -1772,14 +1806,14 @@ and gen_funs ~global_attrs p = (Vb.mk ~loc:p.ptype_loc ~value_constraint:( Pvc_constraint { - locally_abstract_univars = []; - typ = - (poly - (gen_typ (Arrow - { - ty_args = (List.map (fun typ -> {lab=Arg; att=[]; typ}) input_typs); - ty_vararg = None; unit_arg = false; ty_res = ret_typ - })))}) + locally_abstract_univars = []; + typ = + (poly + (gen_typ (Arrow + { + ty_args = (List.map (fun typ -> {lab=Arg; att=[]; typ}) input_typs); + ty_vararg = None; unit_arg = false; ty_res = ret_typ + })))}) (Pat.var (mknoloc name)) code) in @@ -1879,7 +1913,7 @@ and gen_class_field x = function mkfun (fun arg -> ojs_set (var x) s (ml2js typ arg)) | MethodCall s, Arrow {ty_args; ty_vararg; unit_arg; ty_res} -> let formal_args, concrete_args = prepare_args ty_args ty_vararg in - let res = ojs_call_arr (var x) s concrete_args in + let res = ojs_call_arr (var x) (Some s) concrete_args in func formal_args unit_arg (js2ml_unit ty_res res) | MethodCall s, ty_res -> js2ml_unit ty_res (ojs "call" [var x; str s; Exp.array []]) @@ -1953,12 +1987,12 @@ and gen_def ~global_object loc decl ty = mkfun ~typ:ty_this (fun this -> mkfun ~typ:ty_arg (fun arg -> res this arg)) | PropSet s, Arrow {ty_args = [{lab = Arg; att = _; typ = ty_arg}]; ty_vararg = None; unit_arg = false; ty_res = Unit _} -> - mkfun ~typ:ty_arg (fun arg -> set_path global_object s (ml2js ty_arg arg)) + mkfun ~typ:ty_arg (fun arg -> set_path ~loc:arg.pexp_loc global_object s (ml2js ty_arg arg)) | MethCall s, Arrow {ty_args = {lab=Arg; att=_; typ} :: ty_args; ty_vararg; unit_arg; ty_res} -> let formal_args, concrete_args = prepare_args ty_args ty_vararg in - let res this = ojs_call_arr (ml2js typ this) s concrete_args in + let res this = ojs_call_arr (ml2js typ this) (Some s) concrete_args in mkfun ~typ (fun this -> func formal_args unit_arg (js2ml_unit ty_res (res this))) | New name, Arrow {ty_args; ty_vararg; unit_arg; ty_res} ->