aboutsummaryrefslogtreecommitdiff
path: root/src/Lib
diff options
context:
space:
mode:
Diffstat (limited to 'src/Lib')
-rw-r--r--src/Lib/ContextMenu.ml40
-rw-r--r--src/Lib/Dom/Document.ml15
-rw-r--r--src/Lib/Dom/Element.ml33
-rw-r--r--src/Lib/Dom/Event.ml12
-rw-r--r--src/Lib/Dom/H.ml12
-rw-r--r--src/Lib/Leaflet.ml3
-rw-r--r--src/Lib/Modal.ml25
7 files changed, 106 insertions, 34 deletions
diff --git a/src/Lib/ContextMenu.ml b/src/Lib/ContextMenu.ml
new file mode 100644
index 0000000..b9ed7d4
--- /dev/null
+++ b/src/Lib/ContextMenu.ml
@@ -0,0 +1,40 @@
+let px f =
+ Js.Float.toString f ^ "px"
+
+type entry =
+ { label: string
+ ; action: unit -> unit
+ }
+
+let show mouse_event actions =
+ let menu =
+ H.div
+ [| HA.id "g-ContextMenu"
+ ; HA.style ("left: " ^ (px (Event.page_x mouse_event)) ^ "; top: " ^ (px (Event.page_y mouse_event)))
+ |]
+ (Js.Array.map
+ (fun entry ->
+ H.div
+ [| HA.class_ "g-ContextMenu__Entry"
+ ; HE.on_click (fun _ -> entry.action ())
+ |]
+ [| H.text entry.label |])
+ actions)
+ in
+ let () = Element.append_child Document.body menu in
+
+ (* Remove on click or context menu *)
+ let _ =
+ Js.Global.setTimeout
+ (fun _ ->
+ let rec f = (fun _ ->
+ let () = Element.remove_child Document.body menu in
+ let () = Element.remove_event_listener Document.body "click" f in
+ Element.remove_event_listener Document.body "contextmenu" f)
+ in
+ let () = Element.add_event_listener Document.body "click" f in
+ Element.add_event_listener Document.body "contextmenu" f
+ )
+ 0
+ in
+ ()
diff --git a/src/Lib/Dom/Document.ml b/src/Lib/Dom/Document.ml
index 39c1bb4..46f983a 100644
--- a/src/Lib/Dom/Document.ml
+++ b/src/Lib/Dom/Document.ml
@@ -1,16 +1,19 @@
-external createElement : string -> Dom.element = "createElement"
+external body : Dom.element = "body"
[@@bs.val] [@@bs.scope "document"]
-external createElementNS : string -> string -> Dom.element = "createElementNS"
+external create_element : string -> Dom.element = "createElement"
[@@bs.val] [@@bs.scope "document"]
-external querySelector : string -> Dom.element Js.Nullable.t = "querySelector"
+external create_element_ns : string -> string -> Dom.element = "createElementNS"
[@@bs.val] [@@bs.scope "document"]
-let querySelectorUnsafe id =
- querySelector id |> Js.Nullable.toOption |> Js.Option.getExn
+external query_selector : string -> Dom.element Js.Nullable.t = "querySelector"
+ [@@bs.val] [@@bs.scope "document"]
+
+let query_selector_unsafe id =
+ query_selector id |> Js.Nullable.toOption |> Js.Option.getExn
-external createTextNode : string -> Dom.element = "createTextNode"
+external create_text_node : string -> Dom.element = "createTextNode"
[@@bs.val] [@@bs.scope "document"]
external location : Location.location = "location"
diff --git a/src/Lib/Dom/Element.ml b/src/Lib/Dom/Element.ml
index a72b783..391a95c 100644
--- a/src/Lib/Dom/Element.ml
+++ b/src/Lib/Dom/Element.ml
@@ -2,43 +2,36 @@ external set_value : Dom.element -> string -> unit = "value" [@@bs.set]
external value : Dom.element -> string = "value" [@@bs.get]
-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 setAttribute : Dom.element -> string -> string -> unit = "setAttribute"
+external set_attribute : Dom.element -> string -> string -> unit = "setAttribute"
[@@bs.send]
-external setAttributeNS : Dom.element -> string -> string -> string -> unit
- = "setAttributeNS"
+external add_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit
+ = "addEventListener"
[@@bs.send]
-external addEventListener : Dom.element -> string -> (Dom.event -> unit) -> unit
- = "addEventListener"
+external remove_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit
+ = "removeEventListener"
[@@bs.send]
-external appendChild : Dom.element -> Dom.element -> unit = "appendChild"
+external append_child : Dom.element -> Dom.element -> unit = "appendChild"
[@@bs.send]
-external firstChild : Dom.element -> Dom.element Js.Nullable.t = "firstChild"
+external first_child : Dom.element -> Dom.element Js.Nullable.t = "firstChild"
[@@bs.get]
-external removeChild : Dom.element -> Dom.element -> unit = "removeChild"
+external remove_child : Dom.element -> Dom.element -> unit = "removeChild"
[@@bs.send]
-let removeFirstChild element =
- match Js.toOption (firstChild element) with
+let remove_first_child element =
+ match Js.toOption (first_child element) with
| Some child ->
- let () = removeChild element child in
+ let () = remove_child element child in
true
| _ -> false
let rec remove_children element =
- if removeFirstChild element then remove_children element else ()
+ if remove_first_child element then remove_children element else ()
let mount_on base element =
let () = remove_children base in
- appendChild base element
+ append_child base element
diff --git a/src/Lib/Dom/Event.ml b/src/Lib/Dom/Event.ml
index acdc9fd..861afcf 100644
--- a/src/Lib/Dom/Event.ml
+++ b/src/Lib/Dom/Event.ml
@@ -1,3 +1,11 @@
-external preventDefault : Dom.event -> unit = "preventDefault" [@@bs.send]
+external prevent_default : Dom.event -> unit = "preventDefault"
+ [@@bs.send]
-external target : Dom.event -> Dom.element = "target" [@@bs.get]
+external target : Dom.event -> Dom.element = "target"
+ [@@bs.get]
+
+external page_x : Dom.mouseEvent -> float = "pageX"
+ [@@bs.get]
+
+external page_y : Dom.mouseEvent -> float = "pageY"
+ [@@bs.get]
diff --git a/src/Lib/Dom/H.ml b/src/Lib/Dom/H.ml
index d547a70..7213daf 100644
--- a/src/Lib/Dom/H.ml
+++ b/src/Lib/Dom/H.ml
@@ -7,30 +7,30 @@ type attribute =
let h tag attributes children =
let element =
if tag == "svg" || tag == "path" then
- Document.createElementNS "http://www.w3.org/2000/svg" tag
- else Document.createElement tag
+ Document.create_element_ns "http://www.w3.org/2000/svg" tag
+ else Document.create_element tag
in
let () =
Js.Array.forEach
(fun attr ->
match attr with
| TextAttr (name, value) ->
- Element.setAttribute element name value
+ Element.set_attribute element name value
| EventAttr (name, eventListener) ->
- Element.addEventListener element name eventListener)
+ Element.add_event_listener element name eventListener)
attributes
in
let () =
Js.Array.forEach
- (fun child -> Element.appendChild element child)
+ (fun child -> Element.append_child element child)
children
in
element
(* Node creation *)
-let text = Document.createTextNode
+let text = Document.create_text_node
let div = h "div"
diff --git a/src/Lib/Leaflet.ml b/src/Lib/Leaflet.ml
index a8a8978..0cc7976 100644
--- a/src/Lib/Leaflet.ml
+++ b/src/Lib/Leaflet.ml
@@ -16,6 +16,9 @@ type lat_lng =
lng : float;
}
+external original_event : event -> Dom.mouseEvent = "originalEvent"
+ [@@bs.get]
+
external lat_lng : event -> lat_lng = "latlng"
[@@bs.get]
diff --git a/src/Lib/Modal.ml b/src/Lib/Modal.ml
new file mode 100644
index 0000000..3fa0550
--- /dev/null
+++ b/src/Lib/Modal.ml
@@ -0,0 +1,25 @@
+let hide () =
+ let modal = Document.query_selector_unsafe "#g-Modal" in
+ Element.remove_child Document.body modal
+
+let show content =
+ let view =
+ H.div
+ [| HA.id "g-Modal" |]
+ [| H.div
+ [| HA.class_ "g-Modal__Curtain"
+ ; HE.on_click (fun _ -> hide ())
+ |]
+ [| |]
+ ; H.div
+ [| HA.class_ "g-Modal__Window" |]
+ [| H.button
+ [| HA.class_ "g-Modal__Close"
+ ; HE.on_click (fun _ -> hide ())
+ |]
+ [| H.div [| HA.class_ "fa fa-close" |] [| |] |]
+ ; content
+ |]
+ |]
+ in
+ Element.append_child Document.body view
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 18:41:31 +0000