Fix graphics_js with separate compilation

lib/js_of_ocaml/gen_stubs/gen_stubs.ml → lib/gen_stubs/gen_stubs.ml

@@ -34,14 +34,6 @@ let () =
     (fun ml -> if not (Filename.check_suffix ml ".pp.ml") then mls := ml :: !mls)
     "generate dummy js stubs";
   let externals = ref String_set.empty in
-  (* Add primitives for compatibility reasons. Existing users might
-     depend on it (e.g. gen_js_api), we dont want the ocaml compiler
-     to complain about theses missing primitives. *)
-  externals :=
-    List.fold_right
-      String_set.add
-      [ "caml_js_from_string"; "caml_js_to_byte_string"; "caml_js_to_string" ]
-      !externals;
   let value_description _mapper desc =
     let l = List.filter (fun x -> x.[0] <> '%') desc.Parsetree.pval_prim in
     externals := List.fold_right String_set.add l !externals;

lib/js_of_ocaml/dune

@@ -10,7 +10,7 @@
  (deps (glob_files *.ml))
  (mode promote)
  (action (with-stdout-to %{targets}
-          (run ./gen_stubs/gen_stubs.exe %{deps}))))
+          (run ../gen_stubs/gen_stubs.exe %{deps}))))
 
 (rule
  (targets lib_version.ml)

lib/js_of_ocaml/js.ml

@@ -758,3 +758,21 @@ type float_prop = float prop
 external float : float -> float = "%identity"
 
 external to_float : float -> float = "%identity"
+
+[@@@ocaml.warning "-32-60"]
+
+module For_compatibility_only = struct
+  (* Add primitives for compatibility reasons. Existing users might
+     depend on it (e.g. gen_js_api), we dont want the ocaml compiler
+     to complain about theses missing primitives. *)
+
+  external caml_js_from_string : string -> js_string t = "caml_js_from_string"
+
+  external caml_js_to_byte_string : js_string t -> string = "caml_js_to_byte_string"
+
+  external caml_js_to_string : js_string t -> string = "caml_js_to_string"
+
+  external caml_list_of_js_array : 'a js_array t -> 'a list = "caml_list_of_js_array"
+
+  external caml_list_to_js_array : 'a list -> 'a js_array t = "caml_list_to_js_array"
+end

lib/js_of_ocaml/js_of_ocaml_stubs.c

@@ -192,6 +192,14 @@ void caml_list_mount_point () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_list_mount_point!\n");
   exit(1);
 }
+void caml_list_of_js_array () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_list_of_js_array!\n");
+  exit(1);
+}
+void caml_list_to_js_array () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_list_to_js_array!\n");
+  exit(1);
+}
 void caml_ml_set_channel_output () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_ml_set_channel_output!\n");
   exit(1);

lib/lwt/graphics/dune

@@ -1,5 +1,6 @@
 (* -*- tuareg -*- *)
 open Jbuild_plugin.V1
+
 let graphics_exists =
   try
     match run_and_read_lines "ocamlfind query -a-format -predicates byte graphics" with
@@ -10,14 +11,24 @@ let graphics_exists =
 let () =
   let jbuild =
     if graphics_exists
-    then {|
+    then
+      {|
 (library
   (name graphics_js)
   (public_name js_of_ocaml-lwt.graphics)
   (synopsis "Graphics for js_of_ocaml.")
   (optional)
   (libraries js_of_ocaml js_of_ocaml-lwt lwt graphics)
+  (foreign_stubs (language c) (names graphics_js_stubs))
   (preprocess (pps js_of_ocaml-ppx)))
+
+(rule
+ (targets graphics_js_stubs.c)
+ (deps (glob_files *.ml))
+ (mode promote)
+ (action (with-stdout-to %{targets}
+          (run ../../gen_stubs/gen_stubs.exe %{deps}))))
+
 |}
     else {||}
   in

lib/lwt/graphics/graphics_js.ml

@@ -22,28 +22,31 @@ open Js_of_ocaml_lwt
 open! Import
 include Graphics
 
-type context
+class type context_ =
+  object
+    method canvas : Dom_html.canvasElement Js.t Js.readonly_prop
+  end
+
+type context = context_ Js.t
 
 let _ = Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "")
 
 let ( >>= ) = Lwt.bind
 
-let get_context () = Js.Unsafe.(fun_call (variable "caml_gr_state_get") [||])
+external get_context : unit -> context = "caml_gr_state_get"
 
-let set_context ctx = Js.Unsafe.(fun_call (variable "caml_gr_state_set") [| inject ctx |])
+external set_context : context -> unit = "caml_gr_state_set"
 
-let create_context canvas w h =
-  Js.Unsafe.(
-    fun_call (variable "caml_gr_state_create") [| inject canvas; inject w; inject h |])
+external create_context : Dom_html.canvasElement Js.t -> int -> int -> context
+  = "caml_gr_state_create"
 
-let document_of_context ctx =
-  Js.Unsafe.(fun_call (variable "caml_gr_doc_of_state") [| inject ctx |])
+external document_of_context : context -> Dom_html.document Js.t = "caml_gr_doc_of_state"
 
 let open_canvas x =
   let ctx = create_context x x##.width x##.height in
   set_context ctx
 
-let compute_real_pos elt =
+let compute_real_pos (elt : #Dom_html.element Js.t) =
   let rec loop elt left top =
     let top = elt##.offsetTop - elt##.scrollTop + top
     and left = elt##.offsetLeft - elt##.scrollLeft + left in
@@ -58,7 +61,7 @@ let mouse_pos () =
   let elt = ctx##.canvas in
   Lwt_js_events.mousemove elt
   >>= fun ev ->
-  let top, left = compute_real_pos elt in
+  let top, left = compute_real_pos (elt :> Dom_html.element Js.t) in
   Lwt.return
     ( Js.Optdef.get ev##.pageX (fun _ -> 0) - left
     , elt##.height - (Js.Optdef.get ev##.pageY (fun _ -> 0) - top) )
@@ -102,7 +105,7 @@ let loop elist f : unit =
           Js._true);
   elt##.onmousemove :=
     Dom_html.handler (fun ev ->
-        let cy, cx = compute_real_pos elt in
+        let cy, cx = compute_real_pos (elt :> Dom_html.element Js.t) in
         mouse_x := Js.Optdef.get ev##.pageX (fun _ -> 0) - cx;
         mouse_y := elt##.height - (Js.Optdef.get ev##.pageY (fun _ -> 0) - cy);
         (if List.mem Mouse_motion elist

lib/lwt/graphics/graphics_js_stubs.c

@@ -0,0 +1,18 @@
+#include <stdlib.h>
+#include <stdio.h>
+void caml_gr_doc_of_state () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_gr_doc_of_state!\n");
+  exit(1);
+}
+void caml_gr_state_create () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_gr_state_create!\n");
+  exit(1);
+}
+void caml_gr_state_get () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_gr_state_get!\n");
+  exit(1);
+}
+void caml_gr_state_set () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_gr_state_set!\n");
+  exit(1);
+}