def
/
lwd
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

lwd_seq

tyxml
Frédéric Bour 1 year ago
parent
58fd8c6b85
commit
ebd0d5c446
4 changed files with 187 additions and 120 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 4
      lib/lwd/lwd_seq.ml
  2. 3
      lib/lwd/lwd_seq.mli
  3. 275
      lib/tyxml-lwd/tyxml_lwd.ml
  4. 25
      tyxml-lwd.opam

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

275
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
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"
Write Preview
Loading…
Cancel
Save