Add ppx tests setup

Makefile

@@ -2,7 +2,7 @@
 # See the attached LICENSE file.
 # Copyright 2015 by LexiFi.
 
-.PHONY: all examples clean install uninstall doc
+.PHONY: all examples test test-promote clean install uninstall doc
 
 all:
 	dune build @install @DEFAULT
@@ -13,6 +13,12 @@ examples:
 doc:
 	dune build @doc
 
+test:
+	dune build @runtest
+
+test-promote:
+	dune build @runtest --auto-promote
+
 clean:
 	dune clean
 

TODO.md

@@ -1,16 +1,13 @@
 TODO list for gen_js_api
 ========================
 
-- Create reasonnably complete bindings for Javascript's stdlib
+- Create reasonably complete bindings for Javascript's stdlib
   (string, regexp), for the DOM, for jQuery, etc.
 
 - Add a safe mode, where the generated code is augmented with explicit
   checks (e.g. when casting a JS value to a string or integer, when
   accessing a property, etc).
 
-- Support sum types / polymorphic variants with non constant constructors
-  (mapped to objects with a discriminator field).
-
 - Optimize generated code (for instance, lift calls to string_of_js on
   literals).
 
@@ -74,22 +71,3 @@ TODO list for gen_js_api
   function.  One could interpret it as calling the bar method on
   object foo, which would have the effect of assigning `this` during
   the function evaluation.
-
-
-- Extend default heuristic for simplifying binding to "singleton objects", e.g.:
-
-
-  ```ocaml
-  module Console : sig
-    [@@@js.singleton "Console"]
-
-    val log: string -> unit
-  end
-  ```
-
-  The `[@@js.singleton]` attribute would change the automatic heuristic
-  (until the end of the current structure) so that the declaration
-  above is interpreted as `[@@js.global "Console.log"]` (i.e. functions
-  are interpreted as calling methods on the object specified
-  in the `singleton` attribute).
-

VALUES.md

@@ -41,10 +41,10 @@ Supported forms
   passed to it.
 
   By default, the name of the class on the JS side is derived from the
-  name of the OCaml value (`myClass` above): in this case, the value
-  name must start with the `new_` prefix which is dropped to obtain
-  the class name.  It is also possible to specify a custom name
-  explicitly.
+  name of the OCaml value (`MyClass` above): in this case, the value
+  name must start with the `new_` prefix which is dropped and the
+  remaining name is capitalize to obtain the class name.  It is
+  also possible to specify a custom name explicitly.
 
   ```ocaml
   val f: T1 -> ... -> Tn -> t

gen_js_api.opam

@@ -10,7 +10,10 @@ homepage: "https://github.com/LexiFi/gen_js_api"
 bug-reports: "https://github.com/LexiFi/gen_js_api/issues"
 license: "MIT"
 dev-repo: "git+https://github.com/LexiFi/gen_js_api.git"
-build: [["dune" "build" "-p" name "-j" jobs]]
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
 depends: [
   "ocaml" {>= "4.08.0"}
   "dune" {>= "2.0"}

ppx-lib/gen_js_api_ppx.ml

@@ -434,11 +434,11 @@ let auto ~global_attrs s ty =
   match ty with
   | _ when derived_from_type s ty -> Ignore
   | Arrow {ty_args = [_]; ty_vararg = None; unit_arg = false; ty_res = Unit _} when has_prefix ~prefix:"set_" s -> PropSet (in_global_scope ~global_attrs (js_name ~global_attrs (drop_prefix ~prefix:"set_" s)))
+  | Arrow {ty_args = [{lab=Arg; att=_; typ=Name _}; _]; ty_vararg = None; unit_arg = false; ty_res = Unit _} when has_prefix ~prefix:"set_" s -> PropSet (js_name ~global_attrs (drop_prefix ~prefix:"set_" s))
+  | Arrow {ty_args = _; ty_vararg = None; unit_arg = _; ty_res = Name _} when has_prefix ~prefix:"new_" s -> New (in_global_scope ~global_attrs (js_name ~capitalize:true ~global_attrs (drop_prefix ~prefix:"new_" s)))
   | Arrow {ty_args = [{lab=Arg; att=_; typ=Name _}]; ty_vararg = None; unit_arg = false; ty_res = Unit _} -> methcall s
   | Arrow {ty_args = [{lab=Arg; att=_; typ=Name _}]; ty_vararg = None; unit_arg = false; ty_res = _} -> PropGet (js_name ~global_attrs s)
   | Arrow {ty_args = []; ty_vararg = None; unit_arg = true; ty_res = _} -> PropGet (in_global_scope ~global_attrs (js_name ~global_attrs s))
-  | Arrow {ty_args = [{lab=Arg; att=_; typ=Name _}; _]; ty_vararg = None; unit_arg = false; ty_res = Unit _} when has_prefix ~prefix:"set_" s -> PropSet (js_name ~global_attrs (drop_prefix ~prefix:"set_" s))
-  | Arrow {ty_args = _; ty_vararg = None; unit_arg = false; ty_res = Name _} when has_prefix ~prefix:"new_" s -> New (in_global_scope ~global_attrs (js_name ~global_attrs (drop_prefix ~prefix:"new_" s)))
   | Arrow {ty_args = {lab=Arg; att=_; typ=Name _} :: _; ty_vararg = _; unit_arg = _; ty_res = _} -> methcall s
   | _ -> Global (in_global_scope ~global_attrs (js_name ~global_attrs s))
 
@@ -1296,7 +1296,7 @@ and gen_funs ~global_attrs p =
     | Ptype_abstract ->
         let ty =
           match p.ptype_manifest with
-          | None -> assert false (* rewrite_typ_decl makes this case impossible *)
+          | None -> Js
           | Some ty -> parse_typ ~global_attrs ty
         in
         (fun label -> typvar_occurs loc 0 label ty),
@@ -1486,11 +1486,7 @@ and gen_def loc decl ty =
           let this, s = qualified_path s in
           let formal_args, concrete_args = prepare_args [] ty_args ty_vararg in
           let res this = ojs_call_arr (ml2js [] Js this) (str s) concrete_args in
-          begin match ty_args, ty_vararg, unit_arg with
-          | [], None, false -> js2ml_unit [] ty_res (res this)
-          | [], _, _
-          | _ :: _, _, _ -> func formal_args unit_arg (js2ml_unit [] ty_res (res this))
-          end
+          func formal_args unit_arg (js2ml_unit [] ty_res (res this))
       | _ -> js2ml [] ty_res (ojs_get_global s)
       end
 

ppx-test/binding.mli

@@ -0,0 +1,30 @@
+(* The gen_js_api is released under the terms of an MIT-like license.     *)
+(* See the attached LICENSE file.                                         *)
+(* Copyright 2015 by LexiFi.                                              *)
+module M : sig
+  type t = private Ojs.t
+  val t_to_js: t -> Ojs.t
+  val t_of_js: Ojs.t -> t
+
+  val cast: t -> string [@@js.cast]
+
+  val prop_get_arg: t -> int [@@js.get "getter"]
+  val prop_get: unit -> int [@@js.get "getter"]
+
+  val global: t [@@js.global "global"]
+  val global_arrow: int -> int [@@js.global "global"]
+
+  val prop_set: t -> int -> unit [@@js.set "setter"]
+  val prop_set_global: t -> unit [@@js.set "setter"]
+
+  val method_call_global: t -> int [@@js.call "method"]
+  val method_call_global_unit: t -> unit [@@js.call "method"]
+  val method_call_unit: t -> unit -> int [@@js.call "method"]
+  val method_call_args: t -> int -> int [@@js.call "method"]
+  val method_call_unit_unit: t -> unit -> unit [@@js.call "method"]
+  val method_call_args_unit: t -> int -> unit [@@js.call "method"]
+
+  val new_thing: int -> t [@@js.new]
+
+  val builder: ?x:int -> (int [@js "y"]) -> z:int -> t [@@js.builder]
+end

ppx-test/binding_automatic.mli

@@ -0,0 +1,21 @@
+(* The gen_js_api is released under the terms of an MIT-like license.     *)
+(* See the attached LICENSE file.                                         *)
+(* Copyright 2015 by LexiFi.                                              *)
+module M : sig
+  type t = private Ojs.t
+  val t_to_js: t -> Ojs.t
+  val t_of_js: Ojs.t -> t
+
+  val prop_get_arg: t -> int
+  val prop_get: unit -> int
+  val set_prop: t -> int -> unit
+  val set_global: int -> unit
+  val new_thing_unit: unit -> t
+  val new_thing_args: int -> t
+  val method_call_global: t -> unit
+  val method_call_unit: t -> unit -> int
+  val method_call_args: t -> int -> int
+  val method_call_unit_unit: t -> unit -> unit
+  val method_call_args_unit: t -> int -> unit
+  val global: t
+end

ppx-test/binding_explicitly_automatic.mli

@@ -0,0 +1,21 @@
+(* The gen_js_api is released under the terms of an MIT-like license.     *)
+(* See the attached LICENSE file.                                         *)
+(* Copyright 2015 by LexiFi.                                              *)
+module M : sig
+  type t = private Ojs.t
+  val t_to_js: t -> Ojs.t
+  val t_of_js: Ojs.t -> t
+
+  val prop_get_arg: t -> int [@@js]
+  val prop_get: unit -> int [@@js]
+  val set_prop: t -> int -> unit [@@js]
+  val set_global: int -> unit [@@js]
+  val new_thing_unit: unit -> t [@@js]
+  val new_thing_args: int -> t [@@js]
+  val method_call_global: t -> unit [@@js]
+  val method_call_unit: t -> unit -> int [@@js]
+  val method_call_args: t -> int -> int [@@js]
+  val method_call_unit_unit: t -> unit -> unit [@@js]
+  val method_call_args_unit: t -> int -> unit [@@js]
+  val global: t [@@js]
+end

ppx-test/binding_manual.mli

@@ -0,0 +1,21 @@
+(* The gen_js_api is released under the terms of an MIT-like license.     *)
+(* See the attached LICENSE file.                                         *)
+(* Copyright 2015 by LexiFi.                                              *)
+module M : sig
+  type t = private Ojs.t
+  val t_to_js: t -> Ojs.t
+  val t_of_js: Ojs.t -> t
+
+  val prop_get_arg: t -> int [@@js.get "propGetArg"]
+  val prop_get: unit -> int [@@js.get "propGet"]
+  val set_prop: t -> int -> unit [@@js.set "prop"]
+  val set_global: int -> unit [@@js.set "global"]
+  val new_thing_unit: unit -> t [@@js.new "ThingUnit"]
+  val new_thing_args: int -> t [@@js.new "ThingArgs"]
+  val method_call_global: t -> unit [@@js.call "methodCallGlobal"]
+  val method_call_unit: t -> unit -> int [@@js.call "methodCallUnit"]
+  val method_call_args: t -> int -> int[@@js.call "methodCallArgs"]
+  val method_call_unit_unit: t -> unit -> unit[@@js.call "methodCallUnitUnit"]
+  val method_call_args_unit: t -> int -> unit[@@js.call "methodCallArgsUnit"]
+  val global: t[@@js.global "global"]
+end

ppx-test/dune

@@ -0,0 +1,70 @@
+(rule
+ (targets extension.ml.result)
+ (deps extension.ml)
+ (action
+  (run ppx/main.exe --impl %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff expected/extension.ml extension.ml.result)))
+
+(rule
+ (targets issues.ml.result)
+ (deps issues.ml)
+ (action
+  (run ppx/main.exe --impl %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff expected/issues.ml issues.ml.result)))
+
+
+(rule
+ (targets binding_automatic.ml)
+ (deps binding_automatic.mli)
+ (action (run %{bin:gen_js_api} %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff expected/binding_automatic.ml binding_automatic.ml)))
+
+(rule
+ (targets binding_explicitly_automatic.ml)
+ (deps binding_explicitly_automatic.mli)
+ (action (run %{bin:gen_js_api} %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff binding_automatic.ml binding_explicitly_automatic.ml)))
+
+(rule
+ (targets binding_manual.ml)
+ (deps binding_manual.mli)
+ (action (run %{bin:gen_js_api} %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff binding_automatic.ml binding_manual.ml)))
+
+(rule
+ (targets binding.ml)
+ (deps binding.mli)
+ (action (run %{bin:gen_js_api} %{deps} -o %{targets})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff expected/binding.ml binding.ml)))
+
+(library
+  (name test_library)
+  (libraries gen_js_api)
+  (preprocess (pps gen_js_api.ppx))
+  (modes byte)
+  (modules binding_automatic binding_manual extension issues)
+)

ppx-test/expected/binding.ml

@@ -0,0 +1,54 @@
+[@@@js.dummy "!! This code has been generated by gen_js_api !!"]
+[@@@ocaml.warning "-7-32-39"]
+module M =
+  struct
+    type t = Ojs.t
+    let rec (t_of_js : Ojs.t -> t) = fun x2 -> x2
+    and (t_to_js : t -> Ojs.t) = fun x1 -> x1
+    let (cast : t -> string) = fun x3 -> Ojs.string_of_js (t_to_js x3)
+    let (prop_get_arg : t -> int) =
+      fun x4 -> Ojs.int_of_js (Ojs.get (t_to_js x4) "getter")
+    let (prop_get : unit -> int) =
+      fun () -> Ojs.int_of_js (Ojs.get Ojs.global "getter")
+    let (global : t) = t_of_js (Ojs.get Ojs.global "global")
+    let (global_arrow : int -> int) =
+      fun x5 ->
+        Ojs.int_of_js (Ojs.call Ojs.global "global" [|(Ojs.int_to_js x5)|])
+    let (prop_set : t -> int -> unit) =
+      fun x6 -> fun x7 -> Ojs.set (t_to_js x6) "setter" (Ojs.int_to_js x7)
+    let (prop_set_global : t -> unit) =
+      fun x8 -> Ojs.set Ojs.global "setter" (t_to_js x8)
+    let (method_call_global : t -> int) =
+      fun x9 -> Ojs.int_of_js (Ojs.call (t_to_js x9) "method" [||])
+    let (method_call_global_unit : t -> unit) =
+      fun x10 -> ignore (Ojs.call (t_to_js x10) "method" [||])
+    let (method_call_unit : t -> unit -> int) =
+      fun x11 ->
+        fun () -> Ojs.int_of_js (Ojs.call (t_to_js x11) "method" [||])
+    let (method_call_args : t -> int -> int) =
+      fun x13 ->
+        fun x12 ->
+          Ojs.int_of_js
+            (Ojs.call (t_to_js x13) "method" [|(Ojs.int_to_js x12)|])
+    let (method_call_unit_unit : t -> unit -> unit) =
+      fun x14 -> fun () -> ignore (Ojs.call (t_to_js x14) "method" [||])
+    let (method_call_args_unit : t -> int -> unit) =
+      fun x16 ->
+        fun x15 ->
+          ignore (Ojs.call (t_to_js x16) "method" [|(Ojs.int_to_js x15)|])
+    let (new_thing : int -> t) =
+      fun x17 ->
+        t_of_js
+          (Ojs.new_obj (Ojs.get Ojs.global "Thing") [|(Ojs.int_to_js x17)|])
+    let (builder : ?x:int -> int -> z:int -> t) =
+      fun ?x:x18 ->
+        fun x19 ->
+          fun ~z:x20 ->
+            let x21 = Ojs.empty_obj () in
+            (match x18 with
+             | Some x22 -> Ojs.set x21 "x" (Ojs.int_to_js x22)
+             | None -> ());
+            Ojs.set x21 "y" (Ojs.int_to_js x19);
+            Ojs.set x21 "z" (Ojs.int_to_js x20);
+            t_of_js x21
+  end

ppx-test/expected/binding_automatic.ml

@@ -0,0 +1,43 @@
+[@@@js.dummy "!! This code has been generated by gen_js_api !!"]
+[@@@ocaml.warning "-7-32-39"]
+module M =
+  struct
+    type t = Ojs.t
+    let rec (t_of_js : Ojs.t -> t) = fun x2 -> x2
+    and (t_to_js : t -> Ojs.t) = fun x1 -> x1
+    let (prop_get_arg : t -> int) =
+      fun x3 -> Ojs.int_of_js (Ojs.get (t_to_js x3) "propGetArg")
+    let (prop_get : unit -> int) =
+      fun () -> Ojs.int_of_js (Ojs.get Ojs.global "propGet")
+    let (set_prop : t -> int -> unit) =
+      fun x4 -> fun x5 -> Ojs.set (t_to_js x4) "prop" (Ojs.int_to_js x5)
+    let (set_global : int -> unit) =
+      fun x6 -> Ojs.set Ojs.global "global" (Ojs.int_to_js x6)
+    let (new_thing_unit : unit -> t) =
+      fun () -> t_of_js (Ojs.new_obj (Ojs.get Ojs.global "ThingUnit") [||])
+    let (new_thing_args : int -> t) =
+      fun x7 ->
+        t_of_js
+          (Ojs.new_obj (Ojs.get Ojs.global "ThingArgs")
+             [|(Ojs.int_to_js x7)|])
+    let (method_call_global : t -> unit) =
+      fun x8 -> ignore (Ojs.call (t_to_js x8) "methodCallGlobal" [||])
+    let (method_call_unit : t -> unit -> int) =
+      fun x9 ->
+        fun () -> Ojs.int_of_js (Ojs.call (t_to_js x9) "methodCallUnit" [||])
+    let (method_call_args : t -> int -> int) =
+      fun x11 ->
+        fun x10 ->
+          Ojs.int_of_js
+            (Ojs.call (t_to_js x11) "methodCallArgs" [|(Ojs.int_to_js x10)|])
+    let (method_call_unit_unit : t -> unit -> unit) =
+      fun x12 ->
+        fun () -> ignore (Ojs.call (t_to_js x12) "methodCallUnitUnit" [||])
+    let (method_call_args_unit : t -> int -> unit) =
+      fun x14 ->
+        fun x13 ->
+          ignore
+            (Ojs.call (t_to_js x14) "methodCallArgsUnit"
+               [|(Ojs.int_to_js x13)|])
+    let (global : t) = t_of_js (Ojs.get Ojs.global "global")
+  end