tyxml: unify element and element list

lib/tyxml-lwd/tyxml_lwd.ml

@@ -4,34 +4,21 @@ 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 Singleton.t Lwd.t
+  type 'a t = 'a Lwd_seq.t Lwd.t
   type 'a child = 'a t
   let inject x = x
 end
 
 module Child = struct
   type 'a t = 'a Elt.t
-  let return x = Lwd.pure (Singleton.inj x)
+  let return x = Lwd.pure (Lwd_seq.element x)
 
-  type 'a list = 'a Lwd_seq.t Lwd.t
+  type 'a list = 'a 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 singleton x = x
   let append l1 l2 = Lwd.map2 Lwd_seq.concat l1 l2
+  let cons x xs = append (singleton x) xs
 end
 
 module Attr = struct
@@ -138,13 +125,24 @@ module Xml
 
   let comment c = pure_node (Dom_html.document##createComment (Js.string c))
 
-  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 string_monoid =
+    let cat a b = match a, b with "", x | x, "" -> x | a, b -> a ^ b in
+    ("", cat)
+
+  let pcdata input =
+    let node =
+      Lwd_seq.element (Dom_html.document##createTextNode (Js.string ""))
+    in
+    let text = Lwd_seq.fold_monoid (fun x -> x) string_monoid input in
+    Lwd.map (fun text ->
+        begin match Lwd_seq.view node with
+          | Lwd_seq.Element elt -> elt##.data := Js.string text;
+          | _ -> assert false
+        end;
+        (node : Dom.text Js.t Lwd_seq.t :> data Lwd_seq.t)
+      ) text
 
-  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 encodedpcdata = pcdata
 
   let entity =
     let string_fold s ~pos ~init ~f =
@@ -208,8 +206,8 @@ module Xml
 
   let leaf ?(a = []) name : elt =
     let e = Dom_html.document##createElement (Js.string name) in
-    let e' = Singleton.inj e in
-    Lwd.map' (attach_attribs e a) (fun () -> (e' :> data Singleton.t))
+    let e' = Lwd_seq.element (e : Dom_html.element Js.t :> data) in
+    Lwd.map' (attach_attribs e a) (fun () -> e')
 
   type child_tree =
     | Leaf of data
@@ -252,11 +250,11 @@ module Xml
 
   let node ?(a = []) name children : elt =
     let e = Dom_html.document##createElement (Js.string name) in
-    let e' = Singleton.inj e in
+    let e' = Lwd_seq.element e in
     Lwd.map2'
       (update_children (e :> data) children)
       (attach_attribs e a)
-      (fun () () -> (e' :> data Singleton.t))
+      (fun () () -> (e' :> data Lwd_seq.t))
 
   let cdata s = pure_node (Dom_html.document##createTextNode (Js.string s))