experiment with tyxml (#1)

* experiment with tyxml * we don't need to add any special case for svg We can use the same [h] function for both html and svg nodes. We just need to ensure that we don't send in namespace attributes for svg since snabbdom takes care of that for us. * add mli file for snabbdom-tyxml * dont expose internal vnode type and dont specialcase svg function * work with html/svg elements created by tyxml
anuragsoni · Apr 6, 2021 · f94aa76 · f94aa76
1 parent 1b5a2d6
commit f94aa76
Show file tree

Hide file tree

Showing 12 changed files with 281 additions and 36 deletions.
diff --git a/dune-project b/dune-project
@@ -13,3 +13,12 @@
     (ocaml
       (>= 4.08.0))
     ))
+
+(package
+  (name snabbdom-tyxml)
+  (depends
+    brr
+    (ocaml
+      (>= 4.08.0))
+    tyxml
+    ))
diff --git a/example/dune b/example/dune
@@ -1,4 +1,4 @@
-(executable
- (name main)
+(executables
+ (names main main_tyxml)
  (modes js)
- (libraries js_of_ocaml snabbdom))
+ (libraries js_of_ocaml snabbdom snabbdom-tyxml))
diff --git a/example/index.tyxml.html b/example/index.tyxml.html
@@ -0,0 +1,13 @@
+<!DOCTYPE html>
+<html lang="en">
+  <head>
+    <meta charset="UTF-8" />
+    <link rel="icon" type="image/svg+xml" href="favicon.svg" />
+    <meta name="viewport" content="width=device-width, initial-scale=1.0" />
+    <title>OCaml App</title>
+  </head>
+  <body>
+    <div id="app"></div>
+    <script src="./main_tyxml.bc.js"></script>
+  </body>
+</html>
diff --git a/example/main_tyxml.ml b/example/main_tyxml.ml
@@ -0,0 +1,68 @@
+open Brr
+open Snabbdom_tyxml
+
+module Date = struct
+  let date = Jv.get Jv.global "Date"
+  let now () = Jv.new' date [||]
+  let to_locale_time_string date = Jv.call date "toLocaleTimeString" [||] |> Jv.to_string
+end
+
+let () =
+  let container =
+    match Document.find_el_by_id G.document (Jstr.v "app") with
+    | Some v -> v
+    | None -> assert false
+  in
+  let patch =
+    init
+      M.
+        [ attributes_module
+        ; class_module
+        ; props_module
+        ; event_listeners_module
+        ; style_module
+        ; dataset_module
+        ]
+  in
+  let tick () = Html.(h2 [ txt (Date.to_locale_time_string (Date.now ())) ]) in
+  let svg_node =
+    Html.svg
+      Svg.
+        [ circle
+            ~a:
+              [ a_cx (50., None)
+              ; a_cy (50., None)
+              ; a_r (40., None)
+              ; a_stroke (`Color ("green", None))
+              ; a_stroke_width (4., None)
+              ; a_fill (`Color ("yellow", None))
+              ]
+            []
+        ]
+  in
+  let make_counter count = Html.(p [ txt (Int.to_string count) ]) in
+  let count = ref 0 in
+  let counter = ref (make_counter !count) in
+  let on_click _ev =
+    incr count;
+    let new_counter = make_counter !count in
+    patch (`Html !counter) (`Html new_counter);
+    counter := new_counter
+  in
+  let timer = ref (tick ()) in
+  ignore
+    (G.set_interval ~ms:1000 (fun () ->
+         let new_node = tick () in
+         patch (`Html !timer) (`Html new_node);
+         timer := new_node));
+  patch
+    (`Element container)
+    Html.(
+      `Html
+        (div
+           [ svg_node
+           ; h1 [ txt "Hello World" ]
+           ; !timer
+           ; !counter
+           ; button ~a:[ a_onclick on_click ] [ txt "Click Me" ]
+           ]))
diff --git a/lib/m.ml b/lib/m.ml
diff --git a/lib/m.mli b/lib/m.mli
diff --git a/lib/snabbdom.ml b/lib/snabbdom.ml
@@ -1,2 +1,27 @@
-module M = M
+open! Import
+
+module M = struct
+  type t = Jv.t
+
+  let init = get_global "init"
+  let attributes_module = get_global "attributesModule"
+  let class_module = get_global "classModule"
+  let props_module = get_global "propsModule"
+  let event_listeners_module = get_global "eventListenersModule"
+  let style_module = get_global "styleModule"
+  let dataset_module = get_global "datasetModule"
+end
+
 module Vnode = Vnode
+
+let init modules =
+  let patch container node =
+    let patch' = Jv.apply M.init [| Jv.of_jv_list modules |] in
+    let container =
+      match container with
+      | `Element el -> Brr.El.to_jv el
+      | `Vnode jv -> Vnode.to_jv jv
+    in
+    Jv.apply patch' [| container; Vnode.to_jv node |] |> ignore
+  in
+  patch
diff --git a/lib/snabbdom.mli b/lib/snabbdom.mli
@@ -0,0 +1,14 @@
+module M : sig
+  type t
+
+  val attributes_module : t
+  val class_module : t
+  val props_module : t
+  val event_listeners_module : t
+  val style_module : t
+  val dataset_module : t
+end
+
+module Vnode = Vnode
+
+val init : M.t list -> [< `Element of Brr.El.t | `Vnode of Vnode.t ] -> Vnode.t -> unit
diff --git a/snabbdom-tyxml.opam b/snabbdom-tyxml.opam
@@ -0,0 +1,24 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+license: "MIT"
+depends: [
+  "dune" {>= "2.8"}
+  "brr"
+  "ocaml" {>= "4.08.0"}
+  "tyxml"
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
diff --git a/tyxml/dune b/tyxml/dune
@@ -0,0 +1,4 @@
+(library
+ (name snabbdom_tyxml)
+ (public_name snabbdom-tyxml)
+ (libraries snabbdom tyxml.functor))
diff --git a/tyxml/snabbdom_tyxml.ml b/tyxml/snabbdom_tyxml.ml
@@ -0,0 +1,100 @@
+module M = Snabbdom.M
+
+module Xml_vnode = struct
+  open Snabbdom
+  module W = Xml_wrap.NoWrap
+
+  type 'a wrap = 'a
+  type 'a list_wrap = 'a list
+  type uri = string
+
+  let uri_of_string s = s
+  let string_of_uri s = s
+
+  type event_handler = Jv.t -> unit
+  type mouse_event_handler = Brr.Ev.Mouse.t Brr.Ev.t -> unit
+  type keyboard_event_handler = Brr.Ev.Keyboard.t Brr.Ev.t -> unit
+  type touch_event_handler = Jv.t -> unit
+  type attrib = [ `Event of string | `Attr of string ] * Jv.t
+
+  let float_attrib name f = `Attr name, Jv.of_float f
+  let int_attrib name f = `Attr name, Jv.of_int f
+  let string_attrib name f = `Attr name, Jv.of_string f
+  let space_sep_attrib name xs = `Attr name, Jv.of_string (String.concat " " xs)
+  let comma_sep_attrib name xs = `Attr name, Jv.of_string (String.concat "," xs)
+  let event_handler_attrib name handler = `Event name, Jv.repr handler
+  let mouse_event_handler_attrib name handler = `Event name, Jv.repr handler
+  let touch_event_handler_attrib name handler = `Event name, Jv.repr handler
+  let keyboard_event_handler_attrib name handler = `Event name, Jv.repr handler
+  let uri_attrib name value = `Attr name, Jv.of_string value
+  let uris_attrib name values = `Attr name, Jv.of_string (String.concat " " values)
+
+  type aname = string
+  type elt = Vnode.t
+  type ename = string
+
+  module StringSet = Set.Make (struct
+    type t = string
+
+    let compare a b =
+      let a = String.lowercase_ascii a in
+      let b = String.lowercase_ascii b in
+      String.compare a b
+  end)
+
+  let attributes_to_skip = StringSet.of_list [ "xmlns"; "xmlns:xlink" ]
+
+  let make_attrs (a : attrib list option) =
+    match a with
+    | None -> Jv.null
+    | Some attrs ->
+      let events, attrs =
+        List.fold_left
+          (fun (events, attrs) t ->
+            match t with
+            | `Attr name, v ->
+              if StringSet.mem name attributes_to_skip
+              then events, attrs
+              else events, (name, v) :: attrs
+            (* TODO: This is just temporary to verify that this approach can work. Tyxml
+               sends events like [onclick] but snabbdom expects keys like [click] *)
+            | `Event name, v ->
+              (String.sub name 2 (String.length name - 2), v) :: events, attrs)
+          ([], [])
+          attrs
+      in
+      Jv.obj
+        [| "attrs", Jv.obj (Array.of_list attrs); "on", Jv.obj (Array.of_list events) |]
+
+  let leaf ?a name = Vnode.make_node name (make_attrs a) []
+  let node ?a name children = Vnode.make_node name (make_attrs a) children
+  let empty () = assert false
+  let comment _c = assert false
+  let pcdata = Vnode.text
+  let encodedpcdata = Vnode.text
+  let cdata s = pcdata s
+  let cdata_script s = cdata s
+  let cdata_style s = cdata s
+  let entity _ = assert false
+end
+
+module Svg_vnode = struct
+  include Xml_vnode
+end
+
+module Svg = Svg_f.Make (Svg_vnode)
+module Html = Html_f.Make (Xml_vnode) (Svg)
+
+let init modules =
+  let patch = Snabbdom.init modules in
+  fun container node ->
+    let container =
+      match container with
+      | `Element _ as res -> res
+      | `Html n | `Svg n -> `Vnode n
+    in
+    let vnode =
+      match node with
+      | `Html n | `Svg n -> n
+    in
+    patch container vnode
diff --git a/tyxml/snabbdom_tyxml.mli b/tyxml/snabbdom_tyxml.mli
@@ -0,0 +1,20 @@
+module M : module type of Snabbdom.M with type t = Snabbdom.M.t
+
+module Xml_vnode :
+  Xml_sigs.T
+    with type uri = string
+     and type event_handler = Jv.t -> unit
+     and type mouse_event_handler = Brr.Ev.Mouse.t Brr.Ev.t -> unit
+     and type keyboard_event_handler = Brr.Ev.Keyboard.t Brr.Ev.t -> unit
+     and type touch_event_handler = Jv.t -> unit
+     and type elt = Snabbdom.Vnode.t
+     and module W = Xml_wrap.NoWrap
+
+module Svg : Svg_sigs.Make(Xml_vnode).T
+module Html : Html_sigs.Make(Xml_vnode)(Svg).T
+
+val init
+  :  M.t list
+  -> [< `Element of Brr.El.t | `Html of _ Html.elt | `Svg of _ Svg.elt ]
+  -> [< `Html of _ Html.elt | `Svg of _ Svg.elt ]
+  -> unit