lwd_seq

lib/lwd/lwd_seq.ml

@@ -466,6 +466,10 @@ let fold_monoid map (zero, reduce) seq =
 
 let monoid = (empty, concat)
 
+let lwd_empty : 'a t Lwd.t = Lwd.pure Nil
+let lwd_monoid : 'a. 'a t Lwd.t Lwd_utils.monoid =
+  (lwd_empty, fun x y -> Lwd.map2 concat x y)
+
 let map f seq =
   fold_monoid (fun x -> element (f x)) monoid seq
 

lib/lwd/lwd_seq.mli

@@ -36,6 +36,9 @@ val element : 'a -> 'a seq
 *)
 val concat : 'a seq -> 'a seq -> 'a seq
 
+val monoid : 'a t Lwd_utils.monoid
+val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid
+
 (* Look at the contents of a sequence *)
 
 type ('a, 'b) view =

lib/tyxml-lwd/tyxml_lwd.ml

@@ -4,28 +4,41 @@ let js_string_of_float f = (Js.number_of_float f)##toString
 
 let js_string_of_int i = (Js.number_of_float (float_of_int i))##toString
 
+module Singleton : sig
+  type +'a t = private 'a Lwd_seq.t
+  val inj : 'a -> 'a t
+  val prj : 'a t -> 'a
+  val seq : 'a t -> 'a Lwd_seq.t
+end = struct
+  type +'a t = 'a Lwd_seq.t
+  let inj a = Lwd_seq.element a
+  let prj a =
+    match Lwd_seq.view a with Lwd_seq.Element x -> x | _ -> assert false
+  let seq a = a
+end
+
 module Elt = struct
-  type 'a t = 'a Lwd.t
-  type 'a child = 'a Lwd.t
+  type 'a t = 'a Singleton.t Lwd.t
+  type 'a child = 'a t
   let inject x = x
 end
 
 module Child = struct
-  type 'a t = 'a Lwd.t
-  let return = Lwd.return
-
-  type 'a list = 'a Lwd.t Lwd_seq.t
-  let nil () = Lwd_seq.empty
-  let singleton x = Lwd_seq.element x
-  let cons x xs = Lwd_seq.concat (singleton x) xs
-  let append l1 l2 = Lwd_seq.concat l1 l2
+  type 'a t = 'a Elt.t
+  let return x = Lwd.pure (Singleton.inj x)
+
+  type 'a list = 'a Lwd_seq.t Lwd.t
+  let nil = let nil = Lwd.pure Lwd_seq.empty in fun () -> nil
+  let singleton x = (x : 'a t :> 'a list)
+  let cons x xs = Lwd.map2 Lwd_seq.concat (singleton x) xs
+  let append l1 l2 = Lwd.map2 Lwd_seq.concat l1 l2
 end
 
 module Attr = struct
-  type 'a t = 'a Lwd.t
+  type 'a t = 'a option Lwd.t
   type (-'a,'b) ft = 'a -> 'b
-  let return = Lwd.return
-  let fmap = Lwd.map
+  let return x = Lwd.return (Some x)
+  let fmap f x = Lwd.map (function None -> None | Some x -> Some (f x)) x
 end
 
 module Xml
@@ -34,75 +47,104 @@ module Xml
      and module Child = Child
      and module Attr = Attr
      and type data = Dom.node Js.t
-
+     and type event_handler          = (Dom_html.event Js.t -> bool) Attr.t
+     and type mouse_event_handler    = (Dom_html.mouseEvent Js.t -> bool) Attr.t
+     and type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) Attr.t
+     and type touch_event_handler    = (Dom_html.touchEvent Js.t -> bool) Attr.t
 = struct
 
   module Elt = Elt
   module Attr = Attr
+  type 'a attr = 'a Attr.t
   module Child = Child
-  
+
   type uri = string
   let uri_of_string s = s
   let string_of_uri s = s
 
   type aname = string
 
-  type event_handler = Dom_html.event Js.t -> bool
-  type mouse_event_handler = Dom_html.mouseEvent Js.t -> bool
-  type keyboard_event_handler = Dom_html.keyboardEvent Js.t -> bool
-  type touch_event_handler = Dom_html.touchEvent Js.t -> bool
-
-  type attrib_k =
-    | Event of event_handler
-    | MouseEvent of mouse_event_handler
-    | KeyboardEvent of keyboard_event_handler
-    | TouchEvent of touch_event_handler
-    | Attr of Js.js_string Js.t option Lwd.t
-
-  type attrib = aname * attrib_k
-
-  let attr name v = name, Attr (Lwd.pure (Some v))
-
-  let float_attrib name value : attrib = attr name (js_string_of_float value)
-
-  let int_attrib name value = attr name (js_string_of_int value)
-
-  let string_attrib name value = attr name (Js.string value)
-
-  let space_sep_attrib name values = attr name (Js.string (String.concat " " values))
-
-  let comma_sep_attrib name values = attr name (Js.string (String.concat "," values))
-
-  let event_handler_attrib name (value : event_handler) = name, Event value
-
-  let mouse_event_handler_attrib name (value : mouse_event_handler) =
-    name, MouseEvent value
-
-  let keyboard_event_handler_attrib name (value : keyboard_event_handler) =
-    name, KeyboardEvent value
-
-  let touch_event_handler_attrib name (value : touch_event_handler) =
-    name, TouchEvent value
-
-  let uri_attrib name value = attr name (Js.string value)
-
-  let uris_attrib name values = attr name (Js.string (String.concat " " values))
+  type event_handler          = (Dom_html.event Js.t -> bool) attr
+  type mouse_event_handler    = (Dom_html.mouseEvent Js.t -> bool) attr
+  type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) attr
+  type touch_event_handler    = (Dom_html.touchEvent Js.t -> bool) attr
+
+  type 'a attrib_k =
+    | Event          : (Dom_html.event Js.t -> bool) attrib_k
+    | Event_mouse    : (Dom_html.mouseEvent Js.t -> bool) attrib_k
+    | Event_keyboard : (Dom_html.keyboardEvent Js.t -> bool) attrib_k
+    | Event_touch    : (Dom_html.touchEvent Js.t -> bool) attrib_k
+    | Attr_float     : float attrib_k
+    | Attr_int       : int attrib_k
+    | Attr_string    : string attrib_k
+    | Attr_space_sep : string list attrib_k
+    | Attr_comma_sep : string list attrib_k
+    | Attr_uri       : string attrib_k
+    | Attr_uris      : string list attrib_k
+
+  type 'a attrib_v = {name: string; kind : 'a attrib_k; value: 'a attr}
+  type attrib = Attrib : 'a attrib_v -> attrib [@@ocaml.unboxed]
+
+  let attrib kind name value = Attrib {name; kind; value}
+  let float_attrib                  n v = attrib Attr_float n v
+  let int_attrib                    n v = attrib Attr_int n v
+  let string_attrib                 n v = attrib Attr_string n v
+  let space_sep_attrib              n v = attrib Attr_space_sep n v
+  let comma_sep_attrib              n v = attrib Attr_comma_sep n v
+  let event_handler_attrib          n v = attrib Event n v
+  let mouse_event_handler_attrib    n v = attrib Event_mouse n v
+  let keyboard_event_handler_attrib n v = attrib Event_keyboard n v
+  let touch_event_handler_attrib    n v = attrib Event_touch n v
+  let uri_attrib                    n v = attrib Attr_uri n v
+  let uris_attrib                   n v = attrib Attr_uris n v
+
+  let attach
+      (type a) (node: #Dom.element Js.t) (k: a attrib_v) (v : a option) : unit =
+    let name_js = Js.string k.name in
+    match v with
+    | None -> begin match k.kind with
+        | Event | Event_mouse | Event_keyboard | Event_touch ->
+          Js.Unsafe.set node name_js Js.null
+        | Attr_float | Attr_int | Attr_string | Attr_space_sep
+        | Attr_comma_sep | Attr_uri | Attr_uris ->
+          Js.Unsafe.delete node name_js
+      end
+    | Some v -> begin match k.kind with
+        | Event          -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
+        | Event_mouse    -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
+        | Event_keyboard -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
+        | Event_touch    -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
+        | Attr_float     -> Js.Unsafe.set node name_js (Js.float v)
+        | Attr_int       -> Js.Unsafe.set node name_js v
+        | Attr_string    -> Js.Unsafe.set node name_js (Js.string v)
+        | Attr_space_sep -> Js.Unsafe.set node name_js (Js.string (String.concat " " v))
+        | Attr_comma_sep -> Js.Unsafe.set node name_js (Js.string (String.concat "," v))
+        | Attr_uri       -> Js.Unsafe.set node name_js (Js.string v)
+        | Attr_uris      -> Js.Unsafe.set node name_js (Js.string (String.concat " " v))
+      end
 
   (** Element *)
 
   type data = Dom.node Js.t
-  type elt = data Lwd.t
-  type children = data Lwd_seq.t
-  
+  type elt = data Elt.t
+  type children = data Child.list
+
   type ename = string
 
-  let empty () = (Dom_html.document##createDocumentFragment :> Dom.node Js.t)
+  let as_node (x : #Dom.node Js.t) = (x :> Dom.node Js.t)
+  let pure_node x = Child.return (as_node x)
 
-  let comment c = (Dom_html.document##createComment (Js.string c) :> Dom.node Js.t)
+  let empty () = pure_node Dom_html.document##createDocumentFragment
 
-  let pcdata s = (Dom_html.document##createTextNode (Js.string s) :> Dom.node Js.t)
+  let comment c = pure_node (Dom_html.document##createComment (Js.string c))
 
-  let encodedpcdata s = (Dom_html.document##createTextNode (Js.string s) :> Dom.node Js.t)
+  let pcdata s = Lwd.map' s @@ fun s ->
+    let s = Js.string (Singleton.prj s) in
+    Singleton.inj (as_node (Dom_html.document##createTextNode s))
+
+  let encodedpcdata s = Lwd.map' s @@ fun s ->
+    let s = Js.string (Singleton.prj s) in
+    Singleton.inj (as_node (Dom_html.document##createTextNode s))
 
   let entity =
     let string_fold s ~pos ~init ~f =
@@ -158,72 +200,65 @@ module Xml
           | _ -> Dom_html.decode_html_entities (Js.string ("&" ^ e ^ ";"))
         else invalid_entity e
       in
-      (Dom_html.document##createTextNode str :> Dom.node Js.t)
-
-  (* TODO: fix get_prop
-     it only work when html attribute and dom property names correspond.
-     find a way to get dom property name corresponding to html attribute
-  *)
-
-  let get_prop node name =
-    if Js.Optdef.test (Js.Unsafe.get node name) then Some name else None
-
-  let iter_prop_protected node name f =
-    match get_prop node name with
-    | Some n -> ( try f n with _ -> ())
-    | None -> ()
+      pure_node (Dom_html.document##createTextNode str)
 
   let attach_attribs node l =
-    List.fold_left
-      (fun (acc : unit Lwd.t) (name, att) ->
-         let name_js = Js.string name in
-         match att with
-         | Attr a ->
-           (* Note that once we have weak pointers working, we'll need to React.S.retain *)
-           Lwd.map2
-             (fun () -> function
-                | Some v -> (
-                    ignore (node##setAttribute name_js v);
-                    match name with
-                    | "style" -> node##.style##.cssText := v
-                    | _ ->
-                      iter_prop_protected node name_js (fun name ->
-                          Js.Unsafe.set node name v))
-                | None -> (
-                    ignore (node##removeAttribute name_js);
-                    match name with
-                    | "style" -> node##.style##.cssText := Js.string ""
-                    | _ ->
-                      iter_prop_protected node name_js (fun name ->
-                          Js.Unsafe.set node name Js.null)))
-             acc a
-         | Event h ->
-           Js.Unsafe.set node name_js (fun ev -> Js.bool (h ev));
-           acc
-         | MouseEvent h ->
-           Js.Unsafe.set node name_js (fun ev -> Js.bool (h ev));
-           acc
-         | KeyboardEvent h ->
-           Js.Unsafe.set node name_js (fun ev -> Js.bool (h ev));
-           acc
-         | TouchEvent h ->
-           Js.Unsafe.set node name_js (fun ev -> Js.bool (h ev));
-           acc
-      )
-      (Lwd.pure ()) l
+    Lwd_utils.pack ((), fun () () -> ())
+      (List.map (fun (Attrib a) -> Lwd.map (attach node a) a.value) l)
 
   let leaf ?(a = []) name : elt =
     let e = Dom_html.document##createElement (Js.string name) in
-    Lwd.map (fun () -> (e :> data)) @@ attach_attribs e a
+    let e' = Singleton.inj e in
+    Lwd.map' (attach_attribs e a) (fun () -> (e' :> data Singleton.t))
+
+  type child_tree =
+    | Leaf of data
+    | Inner of { mutable bound: data Js.opt;
+                 left: child_tree; right: child_tree; }
+
+  let child_node node = Leaf node
+
+  let child_join left right = Inner { bound = Js.null; left; right }
+
+  let update_children (self : data) (children : children) : unit Lwd.t =
+    let reducer =
+      ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join)
+    in
+    Lwd.map' children @@ fun children ->
+    let dropped, reducer' =
+      Lwd_seq.Reducer.update_and_get_dropped !reducer children in
+    let remove_child child () = match child with
+      | Leaf node -> ignore (self##removeChild node)
+      | Inner _ -> ()
+    in
+    Lwd_seq.Reducer.fold_dropped `Map remove_child dropped ();
+    begin match Lwd_seq.Reducer.reduce reducer' with
+      | None -> ()
+      | Some tree ->
+        let rec update acc = function
+          | Leaf x ->
+            ignore (self##insertBefore x acc);
+            Js.some x
+          | Inner t ->
+            if Js.Opt.test t.bound then t.bound else (
+              let acc = update acc t.right in
+              let acc = update acc t.left in
+              t.bound <- acc;
+              acc
+            )
+        in
+        ignore (update Js.null tree)
+    end
 
-  let update_children (_ : data) (_ : children) : unit = assert false
-  
   let node ?(a = []) name children : elt =
     let e = Dom_html.document##createElement (Js.string name) in
-    update_children (e :> data) children;
-    Lwd.map (fun () -> (e :> data)) @@ attach_attribs e a
-    
-  let cdata s = pcdata s
+    let e' = Singleton.inj e in
+    Lwd.map2'
+      (update_children (e :> data) children)
+      (attach_attribs e a)
+      (fun () () -> (e' :> data Singleton.t))
+
+  let cdata s = pure_node (Dom_html.document##createTextNode (Js.string s))
 
   let cdata_script s = cdata s
 

tyxml-lwd.opam

@@ -0,0 +1,25 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Hello"
+description: "TODO"
+maintainer: ["fred@tarides.com"]
+authors: ["Frédéric Bour"]
+license: "MIT"
+homepage: "https://github.com/let-def/lwd"
+bug-reports: "https://github.com/let-def/lwd/issues"
+depends: ["dune" "lwd" "tyxml" "js_of_ocaml"]
+build: [
+  ["dune" "subst"] {pinned}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/let-def/lwd.git"