Browse Source

WIP tyxml lwd

tyxml
Drup 4 months ago
committed by Frédéric Bour
parent
commit
58fd8c6b85
5 changed files with 245 additions and 0 deletions
  1. +6
    -0
      dune-project
  2. +2
    -0
      lib/tyxml-lwd/Makefile
  3. +6
    -0
      lib/tyxml-lwd/dune
  4. +231
    -0
      lib/tyxml-lwd/tyxml_lwd.ml
  5. +0
    -0
      tyxml-lwd.opam

+ 6
- 0
dune-project View File

@@ -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
- 0
lib/tyxml-lwd/Makefile View File

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

+ 6
- 0
lib/tyxml-lwd/dune View 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
- 0
lib/tyxml-lwd/tyxml_lwd.ml View 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
- 0
tyxml-lwd.opam View File


Loading…
Cancel
Save