ocaml-wasm · vouillon · Dec 2, 2024 · Nov 29, 2024
diff --git a/examples/README.md b/examples/README.md
@@ -10,4 +10,17 @@ Or a single one:
 $> dune build @examples/<path-to-example-project>/default
 ```
 
+Add the `--profile wasm` option to compile to Wasm:
+```
+$> dune build @examples/boulderdash/default --profile wasm
+```
+
 Compilation artifacts can be found in `${REPO_ROOT}/_build/default/examples/`.
+
+When generating JavaScript code, you can directly open the
+`index.html` files in a browser. When generating Wasm code, you need
+to serve the files, for instance with the following command:
+```
+python -m http.server -d _build/default/examples/boulderdash/
+```
+and then open `http://localhost:8000` in a browser.
diff --git a/examples/boulderdash/boulderdash.ml b/examples/boulderdash/boulderdash.ml
@@ -326,7 +326,7 @@ let http_get url =
   let msg = r.XmlHttpRequest.content in
   if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ())
 
-let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f
+let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Sys_error _ -> http_get f
 
 exception Eos
 
@@ -507,8 +507,4 @@ let start _ =
   Dom.appendChild body div;
   Lwt.return ()
 
-let _ =
-  Html.window##.onload :=
-    Html.handler (fun _ ->
-        ignore (start ());
-        Js._false)
+let () = Lwt.async start
diff --git a/examples/boulderdash/dune b/examples/boulderdash/dune
@@ -1,30 +1,25 @@
 (executables
  (names boulderdash)
  (libraries js_of_ocaml-lwt)
- (modes byte)
+ (modes js wasm)
+ (js_of_ocaml
+  (flags :standard --file %{dep:maps.txt} --file maps))
+ (link_deps
+  (glob_files maps/*.map))
  (preprocess
   (pps js_of_ocaml-ppx)))
 
 (rule
- (targets boulderdash.js)
- (deps
-  (glob_files maps/*.map))
  (action
-  (run
-   %{bin:js_of_ocaml}
-   --source-map
-   %{dep:boulderdash.bc}
-   -o
-   %{targets}
-   --pretty
-   --file
-   %{dep:maps.txt}
-   --file
-   maps)))
+  (copy boulderdash.bc.wasm.js boulderdash.bc.js))
+ (enabled_if
+  (not %{env:js-enabled=})))
 
 (alias
  (name default)
  (deps
-  boulderdash.js
+  boulderdash.bc.js
   index.html
+  maps.txt
+  (glob_files maps/*.map)
   (glob_files sprites/*.{png,svg})))
diff --git a/examples/boulderdash/index.html b/examples/boulderdash/index.html
@@ -5,7 +5,7 @@
   <head>
     <title>Boulder Dash</title>
     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
-    <script type="text/javascript" src="boulderdash.js"></script>
+    <script type="text/javascript" src="boulderdash.bc.js" defer></script>
   </head>
   <body id="boulderdash">
   </body>

diff --git a/examples/cubes/dune b/examples/cubes/dune
@@ -1,21 +1,16 @@
 (executables
  (names cubes)
  (libraries js_of_ocaml-lwt)
- (modes byte)
+ (modes js wasm)
  (preprocess
   (pps js_of_ocaml-ppx)))
 
 (rule
- (targets cubes.js)
  (action
-  (run
-   %{bin:js_of_ocaml}
-   --source-map
-   %{dep:cubes.bc}
-   -o
-   %{targets}
-   --pretty)))
+  (copy cubes.bc.wasm.js cubes.bc.js))
+ (enabled_if
+  (not %{env:js-enabled=})))
 
 (alias
  (name default)
- (deps cubes.js index.html))
+ (deps cubes.bc.js index.html))
diff --git a/examples/cubes/index.html b/examples/cubes/index.html
@@ -4,7 +4,7 @@
 <html xmlns="http://www.w3.org/1999/xhtml">
   <head>
     <title>Cubes</title>
-    <script type="text/javascript" src="cubes.js" defer></script>
+    <script type="text/javascript" src="cubes.bc.js" defer></script>
   </head>
   <body>
   </body>

diff --git a/examples/graph_viewer/dune b/examples/graph_viewer/dune
@@ -1,7 +1,7 @@
 (executables
  (names viewer_js) ;; add converter & viewer
  (libraries js_of_ocaml-lwt)
- (modes byte)
+ (modes js wasm)
  (modules
   (:standard
    \
@@ -13,24 +13,19 @@
    dot_lexer
    dot_graph
    dot_render))
+ (js_of_ocaml
+  (flags :standard --file %{dep:scene.json}))
  (preprocess
-  (pps js_of_ocaml-ppx)))
+  (pps js_of_ocaml-ppx js_of_ocaml-ppx_deriving_json)))
 
 (ocamllex dot_lexer)
 
 (rule
- (targets viewer_js.js)
  (action
-  (run
-   %{bin:js_of_ocaml}
-   --source-map
-   %{dep:viewer_js.bc}
-   -o
-   %{targets}
-   --pretty
-   --file
-   %{dep:scene.json})))
+  (copy viewer_js.bc.wasm.js viewer_js.bc.js))
+ (enabled_if
+  (not %{env:js-enabled=})))
 
 (alias
  (name default)
- (deps viewer_js.js index.html))
+ (deps viewer_js.bc.js scene.json index.html))
diff --git a/examples/graph_viewer/index.html b/examples/graph_viewer/index.html
@@ -4,7 +4,7 @@
 <html xmlns="http://www.w3.org/1999/xhtml">
   <head>
     <title>Graph viewer</title>
-  <script type="text/javascript" src="viewer_js.js"></script>
+  <script type="text/javascript" src="viewer_js.bc.js" defer></script>
   </head>
   <body>
   </body>

diff --git a/examples/graph_viewer/scene.ml b/examples/graph_viewer/scene.ml
@@ -17,9 +17,12 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
+[@@@warning "-39"]
+
 type command =
   | Move_to of float * float
   | Curve_to of float * float * float * float * float * float
+[@@deriving json]
 
 type color = float * float * float
 
@@ -28,6 +31,7 @@ type ('color, 'font, 'text) element =
   | Polygon of (float * float) array * 'color option * 'color option
   | Ellipse of float * float * float * float * 'color option * 'color option
   | Text of float * float * 'text * 'font * 'color option * 'color option
+[@@deriving json]
 
 (****)
 

diff --git a/examples/graph_viewer/scene.mli b/examples/graph_viewer/scene.mli
@@ -20,6 +20,7 @@
 type command =
   | Move_to of float * float
   | Curve_to of float * float * float * float * float * float
+[@@deriving json]
 
 type color = float * float * float
 
@@ -28,6 +29,7 @@ type ('color, 'font, 'text) element =
   | Polygon of (float * float) array * 'color option * 'color option
   | Ellipse of float * float * float * float * 'color option * 'color option
   | Text of float * float * 'text * 'font * 'color option * 'color option
+[@@deriving json]
 
 (****)
 

diff --git a/examples/graph_viewer/viewer_js.ml b/examples/graph_viewer/viewer_js.ml
@@ -166,23 +166,16 @@ open Common
 let redraw st s h v (canvas : Html.canvasElement Js.t) =
   let width = canvas##.width in
   let height = canvas##.height in
-  (*Firebug.console##time (Js.string "draw");*)
   redraw st s h v canvas { x = 0; y = 0; width; height } 0 0 width height
 
-(*
-;Firebug.console##timeEnd (Js.string "draw")
-;Firebug.console##log_2 (Js.string "draw", Js.date##now())
-*)
-let json : < parse : Js.js_string Js.t -> 'a > Js.t = Js.Unsafe.pure_js_expr "JSON"
-
 let ( >>= ) = Lwt.bind
 
 let http_get url =
   XmlHttpRequest.get url
   >>= fun { XmlHttpRequest.code = cod; content = msg; _ } ->
   if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ())
 
-let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f
+let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Sys_error _ -> http_get f
 
 class adjustment
   ?(value = 0.)
@@ -275,6 +268,25 @@ let handle_drag element f =
            in this example. *)
         Js._true)
 
+let of_json ~typ v =
+  match Sys.backend_type with
+  | Other "js_of_ocaml" -> Js._JSON##parse (Js.string v)
+  | _ -> Deriving_Json.from_string typ v
+
+type js_string = Js.js_string Js.t
+
+let js_string_to_json _ _ : unit = assert false
+
+let js_string_of_json buf = Js.bytestring (Deriving_Json.Json_string.read buf)
+
+[@@@warning "-20-39"]
+
+type scene =
+  (float * float * float * float)
+  * (float * float * float * float) array
+  * (js_string, js_string, js_string) Scene.element array
+[@@deriving json]
+
 let start () =
   let doc = Html.document in
   let page = doc##.documentElement in
@@ -300,7 +312,7 @@ let start () =
   Firebug.console##timeEnd(Js.string "loading");
   Firebug.console##time(Js.string "parsing");
 *)
-  let (x1, y1, x2, y2), bboxes, scene = json##parse (Js.string s) in
+  let (x1, y1, x2, y2), bboxes, scene = of_json ~typ:[%json: scene] s in
   (*
   Firebug.console##timeEnd(Js.string "parsing");
   Firebug.console##time(Js.string "init");
@@ -560,8 +572,4 @@ Firebug.console##timeEnd(Js.string "init");
 *)
   Lwt.return ()
 
-let _ =
-  Html.window##.onload :=
-    Html.handler (fun _ ->
-        ignore (start ());
-        Js._false)
+let () = Lwt.async start
diff --git a/examples/graphics/dune b/examples/graphics/dune
@@ -5,6 +5,12 @@
  (preprocess
   (pps js_of_ocaml-ppx)))
 
+(rule
+ (action
+  (copy main.bc.wasm.js main.bc.js))
+ (enabled_if
+  (not %{env:js-enabled=})))
+
 (alias
  (name default)
  (deps main.bc.js index.html))
diff --git a/examples/hyperbolic/dune b/examples/hyperbolic/dune
@@ -1,31 +1,32 @@
 (executables
  (names hypertree)
  (libraries js_of_ocaml-lwt)
- (modes byte)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(rule
- (targets hypertree.js)
- (action
-  (run
-   %{bin:js_of_ocaml}
-   --source-map
-   %{dep:hypertree.bc}
-   -o
-   %{targets}
-   --pretty
+ (modes js wasm)
+ (js_of_ocaml
+  (flags
+   :standard
    --file
    %{dep:image_info.json}
    --file
    %{dep:messages.json}
    --file
-   %{dep:tree.json})))
+   %{dep:tree.json}))
+ (preprocess
+  (pps js_of_ocaml-ppx js_of_ocaml-ppx_deriving_json)))
+
+(rule
+ (action
+  (copy hypertree.bc.wasm.js hypertree.bc.js))
+ (enabled_if
+  (not %{env:js-enabled=})))
 
 (alias
  (name default)
  (deps
-  hypertree.js
+  hypertree.bc.js
   index.html
+  image_info.json
+  messages.json
+  tree.json
   (glob_files icons/*.{png,jpg})
   (glob_files thumbnails/*.{png,jpg})))