From 5c636f11cdfed82634ee572645d765b704941b68 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 3 Mar 2020 10:44:35 +0100
Subject: Initialize views from JavaScript

---
 src/Dom/CreateElement.ml | 72 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/Dom/Document.ml      | 14 ++++++++--
 src/Dom/Element.ml       | 32 ++++++++++++++++++++-
 src/Dom/EventTarget.ml   |  5 +++-
 4 files changed, 119 insertions(+), 4 deletions(-)
 create mode 100644 src/Dom/CreateElement.ml

(limited to 'src/Dom')

diff --git a/src/Dom/CreateElement.ml b/src/Dom/CreateElement.ml
new file mode 100644
index 0000000..8183a02
--- /dev/null
+++ b/src/Dom/CreateElement.ml
@@ -0,0 +1,72 @@
+(* Element creation *)
+
+let h tag ?(attributes = [||]) ?(eventListeners = [||]) ?(children = [||]) () :
+    Dom.element =
+  let element =
+    if tag == "svg" || tag == "path" then
+      Document.createElementNS "http://www.w3.org/2000/svg" tag
+    else Document.createElement tag
+  in
+  let () =
+    Js.Array.forEach
+      (fun (name, value) -> Element.setAttribute element name value)
+      attributes
+  in
+  let () =
+    Js.Array.forEach
+      (fun (name, eventListener) ->
+        Element.addEventListener element name eventListener)
+      eventListeners
+  in
+  let () =
+    Js.Array.forEach (fun child -> Element.appendChild element child) children
+  in
+  element
+
+(* Node creation *)
+
+let text = Document.createTextNode
+
+let div = h "div"
+
+let span = h "span"
+
+let header = h "header"
+
+let button = h "button"
+
+let section = h "section"
+
+let svg = h "svg"
+
+let path = h "path"
+
+let form = h "form"
+
+let label = h "label"
+
+let input_ = h "input"
+
+(* Attribute creation *)
+
+let id v = ("id", v)
+
+let className v = ("class", v)
+
+let viewBox v = ("viewBox", v)
+
+let d v = ("d", v)
+
+let type_ v = ("type", v)
+
+let min_ v = ("min", v)
+
+let value v = ("value", v)
+
+(* Event listeners *)
+
+let onClick f = ("click", f)
+
+let onInput f = ("input", f)
+
+let onSubmit f = ("submit", f)
diff --git a/src/Dom/Document.ml b/src/Dom/Document.ml
index afd1a84..867e28c 100644
--- a/src/Dom/Document.ml
+++ b/src/Dom/Document.ml
@@ -1,4 +1,14 @@
-external querySelector : string -> Dom.element option = "querySelector"
+external createElement : string -> Dom.element = "createElement"
   [@@bs.val] [@@bs.scope "document"]
 
-let querySelectorUnsafe id = querySelector id |> Js.Option.getExn
+external createElementNS : string -> string -> Dom.element = "createElementNS"
+  [@@bs.val] [@@bs.scope "document"]
+
+external querySelector : string -> Dom.element Js.Nullable.t = "querySelector"
+  [@@bs.val] [@@bs.scope "document"]
+
+let querySelectorUnsafe id =
+  querySelector id |> Js.Nullable.toOption |> Js.Option.getExn
+
+external createTextNode : string -> Dom.element = "createTextNode"
+  [@@bs.val] [@@bs.scope "document"]
diff --git a/src/Dom/Element.ml b/src/Dom/Element.ml
index 4b38fa9..0b6c0bd 100644
--- a/src/Dom/Element.ml
+++ b/src/Dom/Element.ml
@@ -1,14 +1,44 @@
 external setValue : Dom.element -> string -> unit = "value" [@@bs.set]
 
-external setInnerText : Dom.element -> string -> unit = "innerText" [@@bs.set]
+external setTextContent : Dom.element -> string -> unit = "textContent"
+  [@@bs.set]
 
 external setStyle : Dom.element -> string -> unit = "style" [@@bs.set]
 
 external setClassName : Dom.element -> string -> unit = "className" [@@bs.set]
 
+external setScrollTop : Dom.element -> int -> unit = "scrollTop" [@@bs.set]
+
 external setAttribute : Dom.element -> string -> string -> unit = "setAttribute"
   [@@bs.send]
 
+external setAttributeNS : Dom.element -> string -> string -> string -> unit
+  = "setAttributeNS"
+  [@@bs.send]
+
 external addEventListener : Dom.element -> string -> (Dom.event -> unit) -> unit
   = "addEventListener"
   [@@bs.send]
+
+external appendChild : Dom.element -> Dom.element -> unit = "appendChild"
+  [@@bs.send]
+
+external firstChild : Dom.element -> Dom.element Js.Nullable.t = "firstChild"
+  [@@bs.get]
+
+external removeChild : Dom.element -> Dom.element -> unit = "removeChild"
+  [@@bs.send]
+
+let removeFirstChild element =
+  match Js.toOption (firstChild element) with
+  | Some child ->
+      let () = removeChild element child in
+      true
+  | _ -> false
+
+let rec removeChildren element =
+  if removeFirstChild element then removeChildren element else ()
+
+let mountOn base element =
+  let () = removeChildren base in
+  appendChild base element
diff --git a/src/Dom/EventTarget.ml b/src/Dom/EventTarget.ml
index 946a518..d1b0c02 100644
--- a/src/Dom/EventTarget.ml
+++ b/src/Dom/EventTarget.ml
@@ -1 +1,4 @@
-external value : Dom.eventTarget -> string option = "value" [@@bs.get]
+external nullableValue : Dom.eventTarget -> string Js.Nullable.t = "value"
+  [@@bs.get]
+
+let value eventTarget = nullableValue eventTarget |> Js.Nullable.toOption
-- 
cgit v1.2.3