WIP tyxml lwd

This commit is contained in:
Drup 2020-08-28 18:23:51 +02:00 committed by Frédéric Bour
부모 bfc481aa54
커밋 58fd8c6b85
5개의 변경된 파일245개의 추가작업 그리고 0개의 파일을 삭제

파일 보기

@ -21,6 +21,12 @@
(description "TODO")
(depends dune lwd notty))
(package
(name tyxml-lwd)
(synopsis "Hello")
(description "TODO")
(depends dune lwd tyxml js_of_ocaml))
(package
(name nottui-pretty)
(synopsis "A pretty-printer based on PPrint rendering UIs")

2
lib/tyxml-lwd/Makefile Normal file
파일 보기

@ -0,0 +1,2 @@
all:
dune build @all

6
lib/tyxml-lwd/dune Normal file
파일 보기

@ -0,0 +1,6 @@
(library
(name tyxml_lwd)
(public_name tyxml-lwd)
(modes byte)
(preprocess (pps js_of_ocaml-ppx))
(libraries tyxml.functor js_of_ocaml lwd))

231
lib/tyxml-lwd/tyxml_lwd.ml Normal file
파일 보기

@ -0,0 +1,231 @@
open Js_of_ocaml
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 Elt = struct
type 'a t = 'a Lwd.t
type 'a child = 'a Lwd.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
end
module Attr = struct
type 'a t = 'a Lwd.t
type (-'a,'b) ft = 'a -> 'b
let return = Lwd.return
let fmap = Lwd.map
end
module Xml
: Xml_sigs.T
with module Elt = Elt
and module Child = Child
and module Attr = Attr
and type data = Dom.node Js.t
= struct
module Elt = Elt
module Attr = Attr
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))
(** Element *)
type data = Dom.node Js.t
type elt = data Lwd.t
type children = data Lwd_seq.t
type ename = string
let empty () = (Dom_html.document##createDocumentFragment :> Dom.node Js.t)
let comment c = (Dom_html.document##createComment (Js.string c) :> Dom.node Js.t)
let pcdata s = (Dom_html.document##createTextNode (Js.string s) :> Dom.node Js.t)
let encodedpcdata s = (Dom_html.document##createTextNode (Js.string s) :> Dom.node Js.t)
let entity =
let string_fold s ~pos ~init ~f =
let r = ref init in
for i = pos to String.length s - 1 do
let c = s.[i] in
r := f !r c
done;
!r
in
let invalid_entity e = failwith (Printf.sprintf "Invalid entity %S" e) in
let int_of_char = function
| '0' .. '9' as x -> Some (Char.code x - Char.code '0')
| 'a' .. 'f' as x -> Some (Char.code x - Char.code 'a' + 10)
| 'A' .. 'F' as x -> Some (Char.code x - Char.code 'A' + 10)
| _ -> None
in
let parse_int ~pos ~base e =
string_fold e ~pos ~init:0 ~f:(fun acc x ->
match int_of_char x with
| Some d when d < base -> (acc * base) + d
| Some _ | None -> invalid_entity e)
in
let is_alpha_num = function
| '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true
| _ -> false
in
fun e ->
let len = String.length e in
let str =
if len >= 1 && Char.equal e.[0] '#'
then
let i =
if len >= 2 && (Char.equal e.[1] 'x' || Char.equal e.[1] 'X')
then parse_int ~pos:2 ~base:16 e
else parse_int ~pos:1 ~base:10 e
in
Js.string_constr##fromCharCode i
else if string_fold e ~pos:0 ~init:true ~f:(fun acc x ->
(* This is not quite right according to
https://www.xml.com/axml/target.html#NT-Name.
but it seems to cover all html5 entities
https://dev.w3.org/html5/html-author/charref *)
acc && is_alpha_num x)
then
match e with
| "quot" -> Js.string "\""
| "amp" -> Js.string "&"
| "apos" -> Js.string "'"
| "lt" -> Js.string "<"
| "gt" -> Js.string ">"
| "" -> invalid_entity e
| _ -> 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 -> ()
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
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 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 cdata_script s = cdata s
let cdata_style s = cdata s
end

0
tyxml-lwd.opam Normal file
파일 보기