Browse Source

lwd_seq

tyxml
Frédéric Bour 8 months ago
parent
commit
ebd0d5c446
4 changed files with 187 additions and 120 deletions
  1. +4
    -0
      lib/lwd/lwd_seq.ml
  2. +3
    -0
      lib/lwd/lwd_seq.mli
  3. +155
    -120
      lib/tyxml-lwd/tyxml_lwd.ml
  4. +25
    -0
      tyxml-lwd.opam

+ 4
- 0
lib/lwd/lwd_seq.ml View File

@ -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


+ 3
- 0
lib/lwd/lwd_seq.mli View File

@ -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 =


+ 155
- 120
lib/tyxml-lwd/tyxml_lwd.ml View File

@ -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


+ 25
- 0
tyxml-lwd.opam View File

@ -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"

Loading…
Cancel
Save