aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Color.ml38
-rw-r--r--src/Lib/Dom/Document.ml3
-rw-r--r--src/Lib/Dom/Element.ml12
-rw-r--r--src/Lib/Dom/Event.ml3
-rw-r--r--src/Lib/Dom/H.ml49
-rw-r--r--src/Lib/Dom/HA.ml23
-rw-r--r--src/Lib/Dom/HE.ml7
-rw-r--r--src/Lib/Dom/History.ml2
-rw-r--r--src/Lib/Dom/Location.ml7
-rw-r--r--src/Lib/Dom/Window.ml2
-rw-r--r--src/Lib/FontAwesome.ml788
-rw-r--r--src/Lib/Leaflet.ml71
-rw-r--r--src/Lib/String.ml35
-rw-r--r--src/Main.ml4
-rw-r--r--src/State.ml61
-rw-r--r--src/View/Button.ml13
-rw-r--r--src/View/Form.ml56
-rw-r--r--src/View/Form/Autocomplete.ml62
-rw-r--r--src/View/Layout.ml4
-rw-r--r--src/View/Map.ml109
-rw-r--r--src/View/Map/Icon.ml32
-rw-r--r--src/View/Map/Marker.ml61
-rw-r--r--src/View/Map/MarkerForm.ml0
-rw-r--r--src/View/Modal.ml27
24 files changed, 1397 insertions, 72 deletions
diff --git a/src/Color.ml b/src/Color.ml
new file mode 100644
index 0000000..b3d2f91
--- /dev/null
+++ b/src/Color.ml
@@ -0,0 +1,38 @@
+let from_sRGB sRGB =
+ if sRGB <= 0.03928 then
+ sRGB /. 12.92
+ else
+ ((sRGB +. 0.055) /. 1.055) ** 2.4
+
+type rgb =
+ { r: float
+ ; g: float
+ ; b: float
+ }
+
+(* https://www.w3.org/TR/2008/REC-WCAG20-20081211/#relativeluminancedef *)
+let relativeLuminance (c: rgb) =
+ 0.2126 *. from_sRGB (c.r /. 255.) +. 0.7152 *. from_sRGB (c.g /. 255.) +. 0.0722 *. from_sRGB (c.b /. 255.)
+
+(* https://www.w3.org/TR/2008/REC-WCAG20-20081211/#contrastratio *)
+let contrast_ratio (c1: rgb) (c2: rgb) =
+ let rl1 = relativeLuminance c1 in
+ let rl2 = relativeLuminance c2 in
+
+ if (rl1 > rl2) then
+ (rl1 +. 0.05) /. (rl2 +. 0.05)
+ else
+ (rl2 +. 0.05) /. (rl1 +. 0.05)
+
+let from_raw color =
+ let get_opt = function | Some x -> x | None -> raise (Invalid_argument "Option.get") in
+ let div = H.div [| HA.style ("color: " ^ color) |] [| |] in
+ let body = Document.querySelectorUnsafe "body" in
+ let () = Element.appendChild body div in
+ let rgb = [%raw {| window.getComputedStyle(div).color |}] in
+ let () = Element.removeChild body div in
+ let xs = Js.String.split ", " (get_opt (Js.String.splitByRe [%re "/[()]/"] rgb).(1)) in
+ { r = Js.Float.fromString xs.(0)
+ ; g = Js.Float.fromString xs.(1)
+ ; b = Js.Float.fromString xs.(2)
+ }
diff --git a/src/Lib/Dom/Document.ml b/src/Lib/Dom/Document.ml
index 867e28c..39c1bb4 100644
--- a/src/Lib/Dom/Document.ml
+++ b/src/Lib/Dom/Document.ml
@@ -12,3 +12,6 @@ let querySelectorUnsafe id =
external createTextNode : string -> Dom.element = "createTextNode"
[@@bs.val] [@@bs.scope "document"]
+
+external location : Location.location = "location"
+ [@@bs.val] [@@bs.scope "document"]
diff --git a/src/Lib/Dom/Element.ml b/src/Lib/Dom/Element.ml
index 3e3b78a..a72b783 100644
--- a/src/Lib/Dom/Element.ml
+++ b/src/Lib/Dom/Element.ml
@@ -1,4 +1,6 @@
-external setValue : Dom.element -> string -> unit = "value" [@@bs.set]
+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]
@@ -34,9 +36,9 @@ let removeFirstChild element =
true
| _ -> false
-let rec removeChildren element =
- if removeFirstChild element then removeChildren element else ()
+let rec remove_children element =
+ if removeFirstChild element then remove_children element else ()
-let mountOn base element =
- let () = removeChildren base in
+let mount_on base element =
+ let () = remove_children base in
appendChild base element
diff --git a/src/Lib/Dom/Event.ml b/src/Lib/Dom/Event.ml
new file mode 100644
index 0000000..acdc9fd
--- /dev/null
+++ b/src/Lib/Dom/Event.ml
@@ -0,0 +1,3 @@
+external preventDefault : Dom.event -> unit = "preventDefault" [@@bs.send]
+
+external target : Dom.event -> Dom.element = "target" [@@bs.get]
diff --git a/src/Lib/Dom/H.ml b/src/Lib/Dom/H.ml
index 8183a02..d547a70 100644
--- a/src/Lib/Dom/H.ml
+++ b/src/Lib/Dom/H.ml
@@ -1,7 +1,10 @@
(* Element creation *)
-let h tag ?(attributes = [||]) ?(eventListeners = [||]) ?(children = [||]) () :
- Dom.element =
+type attribute =
+ | TextAttr of string * string
+ | EventAttr of string * (Dom.event -> unit)
+
+let h tag attributes children =
let element =
if tag == "svg" || tag == "path" then
Document.createElementNS "http://www.w3.org/2000/svg" tag
@@ -9,17 +12,19 @@ let h tag ?(attributes = [||]) ?(eventListeners = [||]) ?(children = [||]) () :
in
let () =
Js.Array.forEach
- (fun (name, value) -> Element.setAttribute element name value)
+ (fun attr ->
+ match attr with
+ | TextAttr (name, value) ->
+ Element.setAttribute element name value
+
+ | EventAttr (name, eventListener) ->
+ Element.addEventListener element name eventListener)
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
+ (fun child -> Element.appendChild element child)
+ children
in
element
@@ -45,28 +50,16 @@ 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 input = h "input"
-let min_ v = ("min", v)
+let textarea = h "textarea"
-let value v = ("value", v)
+let i = h "i"
-(* Event listeners *)
+let a = h "a"
-let onClick f = ("click", f)
+let h1 = h "h1"
-let onInput f = ("input", f)
+let h2 = h "h2"
-let onSubmit f = ("submit", f)
+let h3 = h "h3"
diff --git a/src/Lib/Dom/HA.ml b/src/Lib/Dom/HA.ml
new file mode 100644
index 0000000..a7a45ce
--- /dev/null
+++ b/src/Lib/Dom/HA.ml
@@ -0,0 +1,23 @@
+(* Attribute creation *)
+
+let id v = H.TextAttr ("id", v)
+
+let class_ v = H.TextAttr ("class", v)
+
+let viewBox v = H.TextAttr ("viewBox", v)
+
+let d v = H.TextAttr ("d", v)
+
+let type_ v = H.TextAttr ("type", v)
+
+let min_ v = H.TextAttr ("min", v)
+
+let value v = H.TextAttr ("value", v)
+
+let for_ v = H.TextAttr ("for", v)
+
+let style v = H.TextAttr ("style", v)
+
+let href v = H.TextAttr ("href", v)
+
+let autocomplete v = H.TextAttr ("autocomplete", v)
diff --git a/src/Lib/Dom/HE.ml b/src/Lib/Dom/HE.ml
new file mode 100644
index 0000000..098259a
--- /dev/null
+++ b/src/Lib/Dom/HE.ml
@@ -0,0 +1,7 @@
+(* Event listeners *)
+
+let on_click f = H.EventAttr ("click", f)
+
+let on_input f = H.EventAttr ("input", f)
+
+let on_submit f = H.EventAttr ("submit", f)
diff --git a/src/Lib/Dom/History.ml b/src/Lib/Dom/History.ml
new file mode 100644
index 0000000..ce7a877
--- /dev/null
+++ b/src/Lib/Dom/History.ml
@@ -0,0 +1,2 @@
+external push_state : string -> string -> string -> unit -> unit = "pushState"
+ [@@bs.val] [@@bs.scope "history"]
diff --git a/src/Lib/Dom/Location.ml b/src/Lib/Dom/Location.ml
new file mode 100644
index 0000000..2c58705
--- /dev/null
+++ b/src/Lib/Dom/Location.ml
@@ -0,0 +1,7 @@
+external set : Dom.element -> string -> unit = "location"
+ [@@bs.set]
+
+type location
+
+external hash : location -> string = "hash"
+ [@@bs.get]
diff --git a/src/Lib/Dom/Window.ml b/src/Lib/Dom/Window.ml
new file mode 100644
index 0000000..3abc921
--- /dev/null
+++ b/src/Lib/Dom/Window.ml
@@ -0,0 +1,2 @@
+external window : Dom.element = "window"
+ [@@bs.val]
diff --git a/src/Lib/FontAwesome.ml b/src/Lib/FontAwesome.ml
new file mode 100644
index 0000000..ed8f5d5
--- /dev/null
+++ b/src/Lib/FontAwesome.ml
@@ -0,0 +1,788 @@
+let icons =
+ [| "500px"
+ ; "address-book"
+ ; "address-book-o"
+ ; "address-card"
+ ; "address-card-o"
+ ; "adjust"
+ ; "adn"
+ ; "align-center"
+ ; "align-justify"
+ ; "align-left"
+ ; "align-right"
+ ; "amazon"
+ ; "ambulance"
+ ; "american-sign-language-interpreting"
+ ; "anchor"
+ ; "android"
+ ; "angellist"
+ ; "angle-double-down"
+ ; "angle-double-left"
+ ; "angle-double-right"
+ ; "angle-double-up"
+ ; "angle-down"
+ ; "angle-left"
+ ; "angle-right"
+ ; "angle-up"
+ ; "apple"
+ ; "archive"
+ ; "area-chart"
+ ; "arrow-circle-down"
+ ; "arrow-circle-left"
+ ; "arrow-circle-o-down"
+ ; "arrow-circle-o-left"
+ ; "arrow-circle-o-right"
+ ; "arrow-circle-o-up"
+ ; "arrow-circle-right"
+ ; "arrow-circle-up"
+ ; "arrow-down"
+ ; "arrow-left"
+ ; "arrow-right"
+ ; "arrow-up"
+ ; "arrows"
+ ; "arrows-alt"
+ ; "arrows-h"
+ ; "arrows-v"
+ ; "asl-interpreting (alias)"
+ ; "assistive-listening-systems"
+ ; "asterisk"
+ ; "at"
+ ; "audio-description"
+ ; "automobile (alias)"
+ ; "backward"
+ ; "balance-scale"
+ ; "ban"
+ ; "bandcamp"
+ ; "bank (alias)"
+ ; "bar-chart"
+ ; "bar-chart-o (alias)"
+ ; "barcode"
+ ; "bars"
+ ; "bath"
+ ; "bathtub (alias)"
+ ; "battery (alias)"
+ ; "battery-0 (alias)"
+ ; "battery-1 (alias)"
+ ; "battery-2 (alias)"
+ ; "battery-3 (alias)"
+ ; "battery-4 (alias)"
+ ; "battery-empty"
+ ; "battery-full"
+ ; "battery-half"
+ ; "battery-quarter"
+ ; "battery-three-quarters"
+ ; "bed"
+ ; "beer"
+ ; "behance"
+ ; "behance-square"
+ ; "bell"
+ ; "bell-o"
+ ; "bell-slash"
+ ; "bell-slash-o"
+ ; "bicycle"
+ ; "binoculars"
+ ; "birthday-cake"
+ ; "bitbucket"
+ ; "bitbucket-square"
+ ; "bitcoin (alias)"
+ ; "black-tie"
+ ; "blind"
+ ; "bluetooth"
+ ; "bluetooth-b"
+ ; "bold"
+ ; "bolt"
+ ; "bomb"
+ ; "book"
+ ; "bookmark"
+ ; "bookmark-o"
+ ; "braille"
+ ; "briefcase"
+ ; "btc"
+ ; "bug"
+ ; "building"
+ ; "building-o"
+ ; "bullhorn"
+ ; "bullseye"
+ ; "bus"
+ ; "buysellads"
+ ; "cab (alias)"
+ ; "calculator"
+ ; "calendar"
+ ; "calendar-check-o"
+ ; "calendar-minus-o"
+ ; "calendar-o"
+ ; "calendar-plus-o"
+ ; "calendar-times-o"
+ ; "camera"
+ ; "camera-retro"
+ ; "car"
+ ; "caret-down"
+ ; "caret-left"
+ ; "caret-right"
+ ; "caret-square-o-down"
+ ; "caret-square-o-left"
+ ; "caret-square-o-right"
+ ; "caret-square-o-up"
+ ; "caret-up"
+ ; "cart-arrow-down"
+ ; "cart-plus"
+ ; "cc"
+ ; "cc-amex"
+ ; "cc-diners-club"
+ ; "cc-discover"
+ ; "cc-jcb"
+ ; "cc-mastercard"
+ ; "cc-paypal"
+ ; "cc-stripe"
+ ; "cc-visa"
+ ; "certificate"
+ ; "chain (alias)"
+ ; "chain-broken"
+ ; "check"
+ ; "check-circle"
+ ; "check-circle-o"
+ ; "check-square"
+ ; "check-square-o"
+ ; "chevron-circle-down"
+ ; "chevron-circle-left"
+ ; "chevron-circle-right"
+ ; "chevron-circle-up"
+ ; "chevron-down"
+ ; "chevron-left"
+ ; "chevron-right"
+ ; "chevron-up"
+ ; "child"
+ ; "chrome"
+ ; "circle"
+ ; "circle-o"
+ ; "circle-o-notch"
+ ; "circle-thin"
+ ; "clipboard"
+ ; "clock-o"
+ ; "clone"
+ ; "close (alias)"
+ ; "cloud"
+ ; "cloud-download"
+ ; "cloud-upload"
+ ; "cny (alias)"
+ ; "code"
+ ; "code-fork"
+ ; "codepen"
+ ; "codiepie"
+ ; "coffee"
+ ; "cog"
+ ; "cogs"
+ ; "columns"
+ ; "comment"
+ ; "comment-o"
+ ; "commenting"
+ ; "commenting-o"
+ ; "comments"
+ ; "comments-o"
+ ; "compass"
+ ; "compress"
+ ; "connectdevelop"
+ ; "contao"
+ ; "copy (alias)"
+ ; "copyright"
+ ; "creative-commons"
+ ; "credit-card"
+ ; "credit-card-alt"
+ ; "crop"
+ ; "crosshairs"
+ ; "css3"
+ ; "cube"
+ ; "cubes"
+ ; "cut (alias)"
+ ; "cutlery"
+ ; "dashboard (alias)"
+ ; "dashcube"
+ ; "database"
+ ; "deaf"
+ ; "deafness (alias)"
+ ; "dedent (alias)"
+ ; "delicious"
+ ; "desktop"
+ ; "deviantart"
+ ; "diamond"
+ ; "digg"
+ ; "dollar (alias)"
+ ; "dot-circle-o"
+ ; "download"
+ ; "dribbble"
+ ; "drivers-license (alias)"
+ ; "drivers-license-o (alias)"
+ ; "dropbox"
+ ; "drupal"
+ ; "edge"
+ ; "edit (alias)"
+ ; "eercast"
+ ; "eject"
+ ; "ellipsis-h"
+ ; "ellipsis-v"
+ ; "empire"
+ ; "envelope"
+ ; "envelope-o"
+ ; "envelope-open"
+ ; "envelope-open-o"
+ ; "envelope-square"
+ ; "envira"
+ ; "eraser"
+ ; "etsy"
+ ; "eur"
+ ; "euro (alias)"
+ ; "exchange"
+ ; "exclamation"
+ ; "exclamation-circle"
+ ; "exclamation-triangle"
+ ; "expand"
+ ; "expeditedssl"
+ ; "external-link"
+ ; "external-link-square"
+ ; "eye"
+ ; "eye-slash"
+ ; "eyedropper"
+ ; "fa (alias)"
+ ; "facebook"
+ ; "facebook-f (alias)"
+ ; "facebook-official"
+ ; "facebook-square"
+ ; "fast-backward"
+ ; "fast-forward"
+ ; "fax"
+ ; "feed (alias)"
+ ; "female"
+ ; "fighter-jet"
+ ; "file"
+ ; "file-archive-o"
+ ; "file-audio-o"
+ ; "file-code-o"
+ ; "file-excel-o"
+ ; "file-image-o"
+ ; "file-movie-o (alias)"
+ ; "file-o"
+ ; "file-pdf-o"
+ ; "file-photo-o (alias)"
+ ; "file-picture-o (alias)"
+ ; "file-powerpoint-o"
+ ; "file-sound-o (alias)"
+ ; "file-text"
+ ; "file-text-o"
+ ; "file-video-o"
+ ; "file-word-o"
+ ; "file-zip-o (alias)"
+ ; "files-o"
+ ; "film"
+ ; "filter"
+ ; "fire"
+ ; "fire-extinguisher"
+ ; "firefox"
+ ; "first-order"
+ ; "flag"
+ ; "flag-checkered"
+ ; "flag-o"
+ ; "flash (alias)"
+ ; "flask"
+ ; "flickr"
+ ; "floppy-o"
+ ; "folder"
+ ; "folder-o"
+ ; "folder-open"
+ ; "folder-open-o"
+ ; "font"
+ ; "font-awesome"
+ ; "fonticons"
+ ; "fort-awesome"
+ ; "forumbee"
+ ; "forward"
+ ; "foursquare"
+ ; "free-code-camp"
+ ; "frown-o"
+ ; "futbol-o"
+ ; "gamepad"
+ ; "gavel"
+ ; "gbp"
+ ; "ge (alias)"
+ ; "gear (alias)"
+ ; "gears (alias)"
+ ; "genderless"
+ ; "get-pocket"
+ ; "gg"
+ ; "gg-circle"
+ ; "gift"
+ ; "git"
+ ; "git-square"
+ ; "github"
+ ; "github-alt"
+ ; "github-square"
+ ; "gitlab"
+ ; "gittip (alias)"
+ ; "glass"
+ ; "glide"
+ ; "glide-g"
+ ; "globe"
+ ; "google"
+ ; "google-plus"
+ ; "google-plus-circle (alias)"
+ ; "google-plus-official"
+ ; "google-plus-square"
+ ; "google-wallet"
+ ; "graduation-cap"
+ ; "gratipay"
+ ; "grav"
+ ; "group (alias)"
+ ; "h-square"
+ ; "hacker-news"
+ ; "hand-grab-o (alias)"
+ ; "hand-lizard-o"
+ ; "hand-o-down"
+ ; "hand-o-left"
+ ; "hand-o-right"
+ ; "hand-o-up"
+ ; "hand-paper-o"
+ ; "hand-peace-o"
+ ; "hand-pointer-o"
+ ; "hand-rock-o"
+ ; "hand-scissors-o"
+ ; "hand-spock-o"
+ ; "hand-stop-o (alias)"
+ ; "handshake-o"
+ ; "hard-of-hearing (alias)"
+ ; "hashtag"
+ ; "hdd-o"
+ ; "header"
+ ; "headphones"
+ ; "heart"
+ ; "heart-o"
+ ; "heartbeat"
+ ; "history"
+ ; "home"
+ ; "hospital-o"
+ ; "hotel (alias)"
+ ; "hourglass"
+ ; "hourglass-1 (alias)"
+ ; "hourglass-2 (alias)"
+ ; "hourglass-3 (alias)"
+ ; "hourglass-end"
+ ; "hourglass-half"
+ ; "hourglass-o"
+ ; "hourglass-start"
+ ; "houzz"
+ ; "html5"
+ ; "i-cursor"
+ ; "id-badge"
+ ; "id-card"
+ ; "id-card-o"
+ ; "ils"
+ ; "image (alias)"
+ ; "imdb"
+ ; "inbox"
+ ; "indent"
+ ; "industry"
+ ; "info"
+ ; "info-circle"
+ ; "inr"
+ ; "instagram"
+ ; "institution (alias)"
+ ; "internet-explorer"
+ ; "intersex (alias)"
+ ; "ioxhost"
+ ; "italic"
+ ; "joomla"
+ ; "jpy"
+ ; "jsfiddle"
+ ; "key"
+ ; "keyboard-o"
+ ; "krw"
+ ; "language"
+ ; "laptop"
+ ; "lastfm"
+ ; "lastfm-square"
+ ; "leaf"
+ ; "leanpub"
+ ; "legal (alias)"
+ ; "lemon-o"
+ ; "level-down"
+ ; "level-up"
+ ; "life-bouy (alias)"
+ ; "life-buoy (alias)"
+ ; "life-ring"
+ ; "life-saver (alias)"
+ ; "lightbulb-o"
+ ; "line-chart"
+ ; "link"
+ ; "linkedin"
+ ; "linkedin-square"
+ ; "linode"
+ ; "linux"
+ ; "list"
+ ; "list-alt"
+ ; "list-ol"
+ ; "list-ul"
+ ; "location-arrow"
+ ; "lock"
+ ; "long-arrow-down"
+ ; "long-arrow-left"
+ ; "long-arrow-right"
+ ; "long-arrow-up"
+ ; "low-vision"
+ ; "magic"
+ ; "magnet"
+ ; "mail-forward (alias)"
+ ; "mail-reply (alias)"
+ ; "mail-reply-all (alias)"
+ ; "male"
+ ; "map"
+ ; "map-marker"
+ ; "map-o"
+ ; "map-pin"
+ ; "map-signs"
+ ; "mars"
+ ; "mars-double"
+ ; "mars-stroke"
+ ; "mars-stroke-h"
+ ; "mars-stroke-v"
+ ; "maxcdn"
+ ; "meanpath"
+ ; "medium"
+ ; "medkit"
+ ; "meetup"
+ ; "meh-o"
+ ; "mercury"
+ ; "microchip"
+ ; "microphone"
+ ; "microphone-slash"
+ ; "minus"
+ ; "minus-circle"
+ ; "minus-square"
+ ; "minus-square-o"
+ ; "mixcloud"
+ ; "mobile"
+ ; "mobile-phone (alias)"
+ ; "modx"
+ ; "money"
+ ; "moon-o"
+ ; "mortar-board (alias)"
+ ; "motorcycle"
+ ; "mouse-pointer"
+ ; "music"
+ ; "navicon (alias)"
+ ; "neuter"
+ ; "newspaper-o"
+ ; "object-group"
+ ; "object-ungroup"
+ ; "odnoklassniki"
+ ; "odnoklassniki-square"
+ ; "opencart"
+ ; "openid"
+ ; "opera"
+ ; "optin-monster"
+ ; "outdent"
+ ; "pagelines"
+ ; "paint-brush"
+ ; "paper-plane"
+ ; "paper-plane-o"
+ ; "paperclip"
+ ; "paragraph"
+ ; "paste (alias)"
+ ; "pause"
+ ; "pause-circle"
+ ; "pause-circle-o"
+ ; "paw"
+ ; "paypal"
+ ; "pencil"
+ ; "pencil-square"
+ ; "pencil-square-o"
+ ; "percent"
+ ; "phone"
+ ; "phone-square"
+ ; "photo (alias)"
+ ; "picture-o"
+ ; "pie-chart"
+ ; "pied-piper"
+ ; "pied-piper-alt"
+ ; "pied-piper-pp"
+ ; "pinterest"
+ ; "pinterest-p"
+ ; "pinterest-square"
+ ; "plane"
+ ; "play"
+ ; "play-circle"
+ ; "play-circle-o"
+ ; "plug"
+ ; "plus"
+ ; "plus-circle"
+ ; "plus-square"
+ ; "plus-square-o"
+ ; "podcast"
+ ; "power-off"
+ ; "print"
+ ; "product-hunt"
+ ; "puzzle-piece"
+ ; "qq"
+ ; "qrcode"
+ ; "question"
+ ; "question-circle"
+ ; "question-circle-o"
+ ; "quora"
+ ; "quote-left"
+ ; "quote-right"
+ ; "ra (alias)"
+ ; "random"
+ ; "ravelry"
+ ; "rebel"
+ ; "recycle"
+ ; "reddit"
+ ; "reddit-alien"
+ ; "reddit-square"
+ ; "refresh"
+ ; "registered"
+ ; "remove (alias)"
+ ; "renren"
+ ; "reorder (alias)"
+ ; "repeat"
+ ; "reply"
+ ; "reply-all"
+ ; "resistance (alias)"
+ ; "retweet"
+ ; "rmb (alias)"
+ ; "road"
+ ; "rocket"
+ ; "rotate-left (alias)"
+ ; "rotate-right (alias)"
+ ; "rouble (alias)"
+ ; "rss"
+ ; "rss-square"
+ ; "rub"
+ ; "ruble (alias)"
+ ; "rupee (alias)"
+ ; "s15 (alias)"
+ ; "safari"
+ ; "save (alias)"
+ ; "scissors"
+ ; "scribd"
+ ; "search"
+ ; "search-minus"
+ ; "search-plus"
+ ; "sellsy"
+ ; "send (alias)"
+ ; "send-o (alias)"
+ ; "server"
+ ; "share"
+ ; "share-alt"
+ ; "share-alt-square"
+ ; "share-square"
+ ; "share-square-o"
+ ; "shekel (alias)"
+ ; "sheqel (alias)"
+ ; "shield"
+ ; "ship"
+ ; "shirtsinbulk"
+ ; "shopping-bag"
+ ; "shopping-basket"
+ ; "shopping-cart"
+ ; "shower"
+ ; "sign-in"
+ ; "sign-language"
+ ; "sign-out"
+ ; "signal"
+ ; "signing (alias)"
+ ; "simplybuilt"
+ ; "sitemap"
+ ; "skyatlas"
+ ; "skype"
+ ; "slack"
+ ; "sliders"
+ ; "slideshare"
+ ; "smile-o"
+ ; "snapchat"
+ ; "snapchat-ghost"
+ ; "snapchat-square"
+ ; "snowflake-o"
+ ; "soccer-ball-o (alias)"
+ ; "sort"
+ ; "sort-alpha-asc"
+ ; "sort-alpha-desc"
+ ; "sort-amount-asc"
+ ; "sort-amount-desc"
+ ; "sort-asc"
+ ; "sort-desc"
+ ; "sort-down (alias)"
+ ; "sort-numeric-asc"
+ ; "sort-numeric-desc"
+ ; "sort-up (alias)"
+ ; "soundcloud"
+ ; "space-shuttle"
+ ; "spinner"
+ ; "spoon"
+ ; "spotify"
+ ; "square"
+ ; "square-o"
+ ; "stack-exchange"
+ ; "stack-overflow"
+ ; "star"
+ ; "star-half"
+ ; "star-half-empty (alias)"
+ ; "star-half-full (alias)"
+ ; "star-half-o"
+ ; "star-o"
+ ; "steam"
+ ; "steam-square"
+ ; "step-backward"
+ ; "step-forward"
+ ; "stethoscope"
+ ; "sticky-note"
+ ; "sticky-note-o"
+ ; "stop"
+ ; "stop-circle"
+ ; "stop-circle-o"
+ ; "street-view"
+ ; "strikethrough"
+ ; "stumbleupon"
+ ; "stumbleupon-circle"
+ ; "subscript"
+ ; "subway"
+ ; "suitcase"
+ ; "sun-o"
+ ; "superpowers"
+ ; "superscript"
+ ; "support (alias)"
+ ; "table"
+ ; "tablet"
+ ; "tachometer"
+ ; "tag"
+ ; "tags"
+ ; "tasks"
+ ; "taxi"
+ ; "telegram"
+ ; "television"
+ ; "tencent-weibo"
+ ; "terminal"
+ ; "text-height"
+ ; "text-width"
+ ; "th"
+ ; "th-large"
+ ; "th-list"
+ ; "themeisle"
+ ; "thermometer (alias)"
+ ; "thermometer-0 (alias)"
+ ; "thermometer-1 (alias)"
+ ; "thermometer-2 (alias)"
+ ; "thermometer-3 (alias)"
+ ; "thermometer-4 (alias)"
+ ; "thermometer-empty"
+ ; "thermometer-full"
+ ; "thermometer-half"
+ ; "thermometer-quarter"
+ ; "thermometer-three-quarters"
+ ; "thumb-tack"
+ ; "thumbs-down"
+ ; "thumbs-o-down"
+ ; "thumbs-o-up"
+ ; "thumbs-up"
+ ; "ticket"
+ ; "times"
+ ; "times-circle"
+ ; "times-circle-o"
+ ; "times-rectangle (alias)"
+ ; "times-rectangle-o (alias)"
+ ; "tint"
+ ; "toggle-down (alias)"
+ ; "toggle-left (alias)"
+ ; "toggle-off"
+ ; "toggle-on"
+ ; "toggle-right (alias)"
+ ; "toggle-up (alias)"
+ ; "trademark"
+ ; "train"
+ ; "transgender"
+ ; "transgender-alt"
+ ; "trash"
+ ; "trash-o"
+ ; "tree"
+ ; "trello"
+ ; "tripadvisor"
+ ; "trophy"
+ ; "truck"
+ ; "try"
+ ; "tty"
+ ; "tumblr"
+ ; "tumblr-square"
+ ; "turkish-lira (alias)"
+ ; "tv (alias)"
+ ; "twitch"
+ ; "twitter"
+ ; "twitter-square"
+ ; "umbrella"
+ ; "underline"
+ ; "undo"
+ ; "universal-access"
+ ; "university"
+ ; "unlink (alias)"
+ ; "unlock"
+ ; "unlock-alt"
+ ; "unsorted (alias)"
+ ; "upload"
+ ; "usb"
+ ; "usd"
+ ; "user"
+ ; "user-circle"
+ ; "user-circle-o"
+ ; "user-md"
+ ; "user-o"
+ ; "user-plus"
+ ; "user-secret"
+ ; "user-times"
+ ; "users"
+ ; "vcard (alias)"
+ ; "vcard-o (alias)"
+ ; "venus"
+ ; "venus-double"
+ ; "venus-mars"
+ ; "viacoin"
+ ; "viadeo"
+ ; "viadeo-square"
+ ; "video-camera"
+ ; "vimeo"
+ ; "vimeo-square"
+ ; "vine"
+ ; "vk"
+ ; "volume-control-phone"
+ ; "volume-down"
+ ; "volume-off"
+ ; "volume-up"
+ ; "warning (alias)"
+ ; "wechat (alias)"
+ ; "weibo"
+ ; "weixin"
+ ; "whatsapp"
+ ; "wheelchair"
+ ; "wheelchair-alt"
+ ; "wifi"
+ ; "wikipedia-w"
+ ; "window-close"
+ ; "window-close-o"
+ ; "window-maximize"
+ ; "window-minimize"
+ ; "window-restore"
+ ; "windows"
+ ; "won (alias)"
+ ; "wordpress"
+ ; "wpbeginner"
+ ; "wpexplorer"
+ ; "wpforms"
+ ; "wrench"
+ ; "xing"
+ ; "xing-square"
+ ; "y-combinator"
+ ; "y-combinator-square (alias)"
+ ; "yahoo"
+ ; "yc (alias)"
+ ; "yc-square (alias)"
+ ; "yelp"
+ ; "yen (alias)"
+ ; "yoast"
+ ; "youtube"
+ ; "youtube-play"
+ ; "youtube-square"
+ |]
diff --git a/src/Lib/Leaflet.ml b/src/Lib/Leaflet.ml
index 45e2963..a8a8978 100644
--- a/src/Lib/Leaflet.ml
+++ b/src/Lib/Leaflet.ml
@@ -1,35 +1,82 @@
-type map
+type layer
-external map : string -> map = "map"
+external map : string -> layer = "map"
[@@bs.val] [@@bs.scope "L"]
-external setView : map -> float array -> int -> unit = "setView"
+external setView : layer -> float array -> int -> unit = "setView"
[@@bs.send]
-type mapEvent
+type event
-external on : map -> string -> (mapEvent -> unit) -> unit = "on"
+external on : layer -> string -> (event -> unit) -> unit = "on"
[@@bs.send]
-type latLng =
+type lat_lng =
{ lat : float;
lng : float;
}
-external latLng : mapEvent -> latLng = "latlng"
+external lat_lng : event -> lat_lng = "latlng"
[@@bs.get]
-type addable
+external target : event -> layer = "target"
+ [@@bs.get]
+
+external get_lat_lng : layer -> unit -> lat_lng = "getLatLng"
+ [@@bs.send]
+
+external title_layer : string -> layer = "tileLayer"
+ [@@bs.val] [@@bs.scope "L"]
+
+external add_layer : layer -> layer -> unit = "addLayer"
+ [@@bs.send]
+
+external clear_layers : layer -> unit = "clearLayers"
+ [@@bs.send]
+
+external remove : layer -> unit = "remove"
+ [@@bs.send]
+
+external get_layers : layer -> unit -> layer array = "getLayers"
+ [@@bs.send]
-external tileLayer : string -> addable = "tileLayer"
+(* Fit bounds *)
+
+external feature_group : layer array -> layer = "featureGroup"
[@@bs.val] [@@bs.scope "L"]
-external addTo : addable -> map -> unit = "addTo"
+type bounds
+
+external get_bounds : layer -> unit -> bounds = "getBounds"
[@@bs.send]
+type fit_bounds_options =
+ { padding: float array
+ }
+
+external fit_bounds : layer -> bounds -> fit_bounds_options -> unit = "fitBounds"
+ [@@bs.send]
+
+(* Icon *)
+
+type icon
+
+type div_icon_input =
+ { className : string
+ ; popupAnchor : float array
+ ; html : Dom.element
+ }
+
+external div_icon : div_icon_input -> icon = "divIcon"
+ [@@bs.val] [@@bs.scope "L"]
+
+(* Marker *)
+
type markerInput =
- { title : string;
+ { title : string
+ ; icon : icon
+ ; draggable : bool
}
-external marker : latLng -> markerInput -> addable = "marker"
+external marker : lat_lng -> markerInput -> layer = "marker"
[@@bs.val] [@@bs.scope "L"]
diff --git a/src/Lib/String.ml b/src/Lib/String.ml
new file mode 100644
index 0000000..be16d0e
--- /dev/null
+++ b/src/Lib/String.ml
@@ -0,0 +1,35 @@
+let format_float precision f =
+ let str = Js.Float.toString f in
+ match Js.String.split "." str with
+ | [| a ; b |] -> a ^ "." ^ (Js.String.substring ~from:0 ~to_:precision b)
+ | _ -> str
+
+external btoa : string -> string = "btoa"
+ [@@bs.val] [@@bs.scope "window"]
+
+external atob : string -> string = "atob"
+ [@@bs.val] [@@bs.scope "window"]
+
+external unescape : string -> string = "unescape"
+ [@@bs.val]
+
+external escape : string -> string = "escape"
+ [@@bs.val]
+
+external encodeURIComponent : string -> string = "encodeURIComponent"
+ [@@bs.val]
+
+external decodeURIComponent : string -> string = "decodeURIComponent"
+ [@@bs.val]
+
+let encode str =
+ str
+ |> encodeURIComponent
+ |> unescape
+ |> btoa
+
+let decode str =
+ str
+ |> atob
+ |> escape
+ |> decodeURIComponent
diff --git a/src/Main.ml b/src/Main.ml
index bae9ee1..b95d01f 100644
--- a/src/Main.ml
+++ b/src/Main.ml
@@ -1,3 +1,3 @@
let () =
- let main = Document.querySelectorUnsafe "body" in
- Element.appendChild main (Map.render ())
+ let body = Document.querySelectorUnsafe "body" in
+ Element.appendChild body (Map.render ())
diff --git a/src/State.ml b/src/State.ml
new file mode 100644
index 0000000..cc20b16
--- /dev/null
+++ b/src/State.ml
@@ -0,0 +1,61 @@
+type marker_state =
+ { pos : Leaflet.lat_lng
+ ; name : string
+ ; color : string
+ ; icon : string
+ }
+
+let remove state pos =
+ Js.Array.filter (fun m -> m.pos != pos) state
+
+let update state previousPos marker =
+ Js.Array.concat [| marker |] (remove state previousPos)
+
+let last_added state =
+ if Js.Array.length state > 0 then
+ Some state.(0)
+ else
+ None
+
+(* Serialization *)
+
+let sep = "|"
+
+let marker_to_string marker =
+ [| String.format_float 6 marker.pos.lat
+ ; String.format_float 6 marker.pos.lng
+ ; marker.name
+ ; marker.color
+ ; marker.icon
+ |]
+ |> Js.Array.joinWith sep
+
+let to_string state =
+ state
+ |> Js.Array.map marker_to_string
+ |> Js.Array.joinWith sep
+ |> String.encode
+
+let from_string str =
+ let (_, _, res) = Js.Array.reduce
+ (fun (acc_str, acc_marker, acc_state) c ->
+ let length = Js.Array.length acc_marker in
+ if c != sep then
+ (acc_str ^ c, acc_marker, acc_state)
+ else if c == sep && length < 4 then
+ ("", Js.Array.concat [| acc_str |] acc_marker, acc_state)
+ else
+ let marker =
+ { pos =
+ { lat = Js.Float.fromString acc_marker.(0)
+ ; lng = Js.Float.fromString acc_marker.(1)
+ }
+ ; name = acc_marker.(2)
+ ; color = acc_marker.(3)
+ ; icon = acc_str
+ }
+ in ("", [| |], Js.Array.concat acc_state [| marker |])
+ )
+ ("", [| |], [| |])
+ (Js.Array.from (Js.String.castToArrayLike ((String.decode str) ^ sep)))
+ in res
diff --git a/src/View/Button.ml b/src/View/Button.ml
new file mode 100644
index 0000000..31fa1b0
--- /dev/null
+++ b/src/View/Button.ml
@@ -0,0 +1,13 @@
+let action on_click label =
+ H.button
+ [| HA.class_ "g-Button__Action"
+ ; HE.on_click on_click
+ |]
+ [| H.text label |]
+
+let danger on_click label =
+ H.button
+ [| HA.class_ "g-Button__Danger"
+ ; HE.on_click on_click
+ |]
+ [| H.text label |]
diff --git a/src/View/Form.ml b/src/View/Form.ml
new file mode 100644
index 0000000..b0319b5
--- /dev/null
+++ b/src/View/Form.ml
@@ -0,0 +1,56 @@
+let section name =
+ H.h1
+ [| HA.class_ "g-Form__Section" |]
+ [| H.text name |]
+
+let input id label init_value on_input =
+ H.div
+ [| HA.class_ "g-Form__Field" |]
+ [| H.div
+ [| HA.class_ "g-Form__Label" |]
+ [| H.label
+ [| HA.for_ id |]
+ [| H.text label |]
+ |]
+ ; H.input
+ [| HA.id id
+ ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
+ ; HA.value init_value
+ |]
+ [| |]
+ |]
+
+let color_input id label init_value on_input =
+ H.div
+ [| HA.class_ "g-Form__Field" |]
+ [| H.div
+ [| HA.class_ "g-Form__Label" |]
+ [| H.label
+ [| HA.for_ id |]
+ [| H.text label |]
+ |]
+ ; H.input
+ [| HA.id id
+ ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
+ ; HA.value init_value
+ ; HA.type_ "color"
+ |]
+ [| |]
+ |]
+
+let textarea id label init_value on_input =
+ H.div
+ [| HA.class_ "g-Form__Field" |]
+ [| H.div
+ [| HA.class_ "g-Form__Label" |]
+ [| H.label
+ [| HA.for_ id |]
+ [| H.text label |]
+ |]
+ ; H.textarea
+ [| HA.id id
+ ; HA.class_ "g-Form__Textarea"
+ ; HE.on_input (fun e -> on_input (Element.value (Event.target e)))
+ |]
+ [| H.text init_value |]
+ |]
diff --git a/src/View/Form/Autocomplete.ml b/src/View/Form/Autocomplete.ml
new file mode 100644
index 0000000..537316d
--- /dev/null
+++ b/src/View/Form/Autocomplete.ml
@@ -0,0 +1,62 @@
+let search s xs =
+ if s == "" then
+ [| |]
+ else
+ let results = Js.Array.filter (Js.String.includes s) xs in
+ if Js.Array.length results == 1 && results.(0) == s then [| |] else results
+
+let render_completion on_select entries =
+ H.div
+ [| HA.class_ "g-Autocomplete__Completion" |]
+ (entries
+ |> Js.Array.map (fun c ->
+ H.button
+ [| HA.class_ "g-Autocomplete__Entry"
+ ; HA.type_ "button"
+ ; HE.on_click (fun _ -> on_select c)
+ |]
+ [| H.text c |]))
+
+let create id label values on_input attrs =
+
+ let completion =
+ H.div [| |] [| |]
+ in
+
+ let update_completion target value =
+ let entries = search value values in
+ Element.mount_on completion (render_completion
+ (fun selected ->
+ let () = Element.set_value target selected in
+ let () = Element.remove_children completion in
+ on_input selected)
+ entries)
+ in
+
+ H.div
+ [| HA.class_ "g-Autocomplete" |]
+ [| H.div
+ [| HA.class_ "g-Form__Label" |]
+ [| H.label
+ [| HA.for_ id |]
+ [| H.text label |]
+ |]
+ ; H.input
+ (Js.Array.concat
+ [| HA.id id
+ ; HA.class_ "g-Autocomplete__Input"
+ ; HA.autocomplete "off"
+ ; HE.on_click (fun e ->
+ let target = Event.target e in
+ let value = Element.value target in
+ update_completion target value)
+ ; HE.on_input (fun e ->
+ let target = Event.target e in
+ let value = Element.value target in
+ let () = update_completion target value in
+ on_input value)
+ |]
+ attrs)
+ [| |]
+ ; completion
+ |]
diff --git a/src/View/Layout.ml b/src/View/Layout.ml
new file mode 100644
index 0000000..98218ad
--- /dev/null
+++ b/src/View/Layout.ml
@@ -0,0 +1,4 @@
+let section attrs content =
+ H.div
+ (Js.Array.concat [| HA.class_ "g-Layout__Section" |] attrs)
+ content
diff --git a/src/View/Map.ml b/src/View/Map.ml
index bcd0506..969a95a 100644
--- a/src/View/Map.ml
+++ b/src/View/Map.ml
@@ -1,28 +1,87 @@
-let render () =
- let
- _ =
- Js.Global.setTimeout
- (fun () ->
- let map = Leaflet.map("g-Map__Content") in
- let tileLayer = Leaflet.tileLayer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in
- let () = Leaflet.addTo tileLayer map in
- let () = Leaflet.setView map [| 51.505; -0.09 |] 13 in
- Leaflet.on map "contextmenu" (fun (event) ->
- Leaflet.addTo (Leaflet.marker (Leaflet.latLng event) { title = "Hey"; }) map))
- 0
- in
+let mapView =
H.div
- ~attributes:[| H.className "g-Layout__Page" |]
- ~children: [|
- H.div
- ~attributes:[| H.className "g-Layout__Header" |]
- ~children:[| H.text "Map" |]
- ();
- H.div
- ~attributes:[| H.className "g-Map" |]
- ~children:[|
- H.div ~attributes:[| H.id "g-Map__Content" |] ()
+ [| HA.class_ "g-Layout__Page" |]
+ [| H.div
+ [| HA.class_ "g-Layout__Header" |]
+ [| H.a
+ [| HA.class_ "g-Layout__Home"
+ ; HA.href "#"
+ |]
+ [| H.text "Map" |]
+ |]
+ ; H.div
+ [| HA.class_ "g-Map" |]
+ [| H.div
+ [| HA.id "g-Map__Content" |]
+ [||]
|]
- ();
|]
- ()
+
+let state_from_hash () =
+ let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in
+ State.from_string hash
+
+let installMap () =
+ let state = ref (state_from_hash ()) in
+ let map = Leaflet.map "g-Map__Content" in
+ let title_layer = Leaflet.title_layer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in
+ let markers = Leaflet.feature_group [| |] in
+ let () = Leaflet.add_layer map markers in
+ let () = Leaflet.add_layer map title_layer in
+
+ let rec reload_from_hash focus =
+ let update_state new_state =
+ let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in
+ reload_from_hash false
+ in
+
+ let on_remove pos =
+ update_state (State.remove !state pos) in
+
+ let on_update previousPos pos name color icon =
+ update_state (State.update !state previousPos { pos = pos; name = name; color = color; icon = icon }) in
+
+ let () =
+ if Js.Array.length (Leaflet.get_layers markers ()) > 0 then
+ Leaflet.clear_layers markers
+ else
+ ()
+ in
+ let () = state := state_from_hash () in
+ let () =
+ Js.Array.forEach
+ (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update m.pos m.name m.color m.icon))
+ !state
+ in
+ if focus then
+ if Js.Array.length (Leaflet.get_layers markers ()) > 0 then
+ Leaflet.fit_bounds map (Leaflet.get_bounds markers ()) { padding = [| 50.; 50. |] }
+ else
+ Leaflet.setView map [| 51.505; -0.09 |] 2
+ else
+ ()
+ in
+
+ (* Init markers from url *)
+ let () = reload_from_hash true in
+
+ (* Reload the map if the URL changes *)
+ let () = Element.addEventListener Window.window "popstate" (fun _ ->
+ reload_from_hash true)
+ in
+
+ (* Add a marker on right click *)
+ Leaflet.on map "contextmenu" (fun (event) ->
+ let pos = Leaflet.lat_lng event in
+ let new_marker =
+ match State.last_added !state with
+ | Some m -> { m with pos = pos; name = "" }
+ | None -> { pos = pos; name = ""; color = "#3f92cf"; icon = "" }
+ in
+ let new_state = State.update !state pos new_marker in
+ let () = History.push_state "" "" ("#" ^ State.to_string new_state) () in
+ reload_from_hash false)
+
+let render () =
+ let _ = Js.Global.setTimeout installMap 0 in
+ mapView
diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml
new file mode 100644
index 0000000..9b1f40a
--- /dev/null
+++ b/src/View/Map/Icon.ml
@@ -0,0 +1,32 @@
+let create name color =
+ let c = Color.from_raw color in
+ let crBlack = Color.contrast_ratio { r = 0.; g = 0.; b = 0. } c in
+ let crWhite = Color.contrast_ratio { r = 255.; g = 255.; b = 255. } c in
+ let textCol = if crBlack > crWhite then "black" else "white" in
+ Leaflet.div_icon
+ { className = "marker-parent"
+ ; popupAnchor = [| 0.; -34. |]
+ ; html =
+ H.div
+ [| |]
+ [| H.div
+ [| HA.class_ "marker-round"
+ ; HA.style ("background-color: " ^ color)
+ |]
+ [| |]
+ ; H.div [| HA.class_ "marker-peak-border" |] [| |]
+ ; H.div
+ [| HA.class_ "marker-peak-inner"
+ ; HA.style ("border-top-color: " ^ color)
+ |]
+ [| |]
+ ; H.div
+ [| HA.class_ "marker-icon" |]
+ [| H.i
+ [| HA.class_ ("fa fa-" ^ name)
+ ; HA.style ("color: " ^ textCol)
+ |]
+ [| |]
+ |]
+ |]
+ }
diff --git a/src/View/Map/Marker.ml b/src/View/Map/Marker.ml
new file mode 100644
index 0000000..a96af86
--- /dev/null
+++ b/src/View/Map/Marker.ml
@@ -0,0 +1,61 @@
+let create on_remove on_update pos init_name init_color init_icon =
+ let marker =
+ Leaflet.marker pos
+ { title = init_name
+ ; icon = Icon.create init_icon init_color
+ ; draggable = true
+ }
+ in
+ let form on_remove on_update =
+ let name = ref init_name in
+ let color = ref init_color in
+ let icon = ref init_icon in
+ let on_update () =
+ let () = on_update pos pos !name !color !icon in
+ Modal.hide ()
+ in
+ H.div
+ [| |]
+ [| Layout.section
+ [| |]
+ [| H.form
+ [| HA.class_ "g-MarkerForm"
+ ; HE.on_submit (fun e ->
+ let () = Event.preventDefault e in
+ on_update ())
+ |]
+ [| Form.section "Modification"
+ ; Layout.section
+ [| |]
+ [| Form.input "g-MarkerForm__Name" "Name" init_name (fun newName -> name := newName)
+ ; Form.color_input "g-MarkerForm__Color" "Color" init_color (fun newColor -> color := newColor)
+ ; Autocomplete.create
+ "g-MarkerForm__Icon"
+ "Icon"
+ FontAwesome.icons
+ (fun newIcon -> let () = Js.log newIcon in icon := newIcon)
+ [| HA.value init_icon |]
+ |]
+ ; Button.action (fun _ -> on_update ()) "Modify"
+ |]
+ |]
+ ; Layout.section
+ [| |]
+ [| Form.section "Deletion"
+ ; Button.danger (fun _ ->
+ let () = on_remove pos in
+ Modal.hide ()) "Remove"
+ |]
+ |]
+ in
+
+ (* Open a modification / deletion modal on click *)
+ let () = Leaflet.on marker "click" (fun _ ->
+ Modal.show (form on_remove on_update)) in
+
+ (* Move the cursor on drag *)
+ let () = Leaflet.on marker "dragend" (fun e ->
+ let newPos = Leaflet.get_lat_lng (Leaflet.target e) () in
+ on_update pos newPos init_name init_color init_icon) in
+
+ marker
diff --git a/src/View/Map/MarkerForm.ml b/src/View/Map/MarkerForm.ml
deleted file mode 100644
index e69de29..0000000
--- a/src/View/Map/MarkerForm.ml
+++ /dev/null
diff --git a/src/View/Modal.ml b/src/View/Modal.ml
new file mode 100644
index 0000000..9365555
--- /dev/null
+++ b/src/View/Modal.ml
@@ -0,0 +1,27 @@
+let hide () =
+ let body = Document.querySelectorUnsafe "body" in
+ let modal = Document.querySelectorUnsafe ".g-Modal" in
+ Element.removeChild body modal
+
+let show content =
+ let body = Document.querySelectorUnsafe "body" in
+ let view =
+ H.div
+ [| HA.class_ "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.text "X" |]
+ ; content
+ |]
+ |]
+ in
+ Element.appendChild body view
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 00:52:37 +0000