diff options
Diffstat (limited to 'src')
41 files changed, 1412 insertions, 1908 deletions
diff --git a/src/Color.ml b/src/Color.ml deleted file mode 100644 index d2f74c4..0000000 --- a/src/Color.ml +++ /dev/null @@ -1,38 +0,0 @@ -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.query_selector_unsafe "body" in - let () = Element.append_child body div in - let rgb = [%raw {| window.getComputedStyle(div).color |}] in - let () = Element.remove_child 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/CSV.ml b/src/Lib/CSV.ml deleted file mode 100644 index f0366f7..0000000 --- a/src/Lib/CSV.ml +++ /dev/null @@ -1,76 +0,0 @@ -let to_string lines = - let - cell_to_string cell = - if Js.String.includes "\"" cell then - "\"" ^ (Js.String.replaceByRe [%re "/\"/g"] "\"\"" cell) ^ "\"" - else - cell - in let - line_to_string line = - line - |> Js.Array.map cell_to_string - |> Js.Array.joinWith "," - in lines - |> Js.Array.map line_to_string - |> Js.Array.joinWith "\n" - -let parse str = - let lines = [| |] in - let current_line = ref [| |] in - let current_cell = ref "" in - let in_quote = ref false in - let i = ref 0 in - let l = Js.String.length str in - let () = while !i < l do - let cc = Js.String.get str !i in - let nc = Js.String.get str (!i + 1) in - let () = - if !in_quote && cc == "\"" && nc == "\"" then - let () = current_cell := !current_cell ^ cc in - i := !i + 1 - else if cc == "\"" then - in_quote := not !in_quote - else if not !in_quote && cc == "," then - let _ = Js.Array.push !current_cell !current_line in - current_cell := "" - else if not !in_quote && ((cc == "\r" && nc == "\n") || cc == "\n" || cc == "\r") then - let _ = Js.Array.push !current_cell !current_line in - let _ = Js.Array.push !current_line lines in - let _ = current_line := [| |] in - current_cell := "" - else - current_cell := !current_cell ^ cc - in - i := !i + 1 - done - in - let _ = - if Js.String.length !current_cell > 0 then - let _ = Js.Array.push !current_cell !current_line in () - else - () - in - let _ = - if Js.Array.length !current_line > 0 then - let _ = Js.Array.push !current_line lines in () - else - () - in - lines - -let to_dicts lines = - let res = [| |] in - let () = - if Js.Array.length lines > 0 then - let header = Js.Array.unsafe_get lines 0 in - for i = 1 to Js.Array.length lines - 1 do - let line = Js.Array.unsafe_get lines i in - let dict = Js.Dict.empty() in - let () = - Js.Array.forEachi - (fun key j -> Js.Dict.set dict key (Js.Array.unsafe_get line j)) - header - in - ignore (Js.Array.push dict res) - done - in res diff --git a/src/Lib/ContextMenu.ml b/src/Lib/ContextMenu.ml deleted file mode 100644 index b9ed7d4..0000000 --- a/src/Lib/ContextMenu.ml +++ /dev/null @@ -1,40 +0,0 @@ -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 deleted file mode 100644 index 46f983a..0000000 --- a/src/Lib/Dom/Document.ml +++ /dev/null @@ -1,20 +0,0 @@ -external body : Dom.element = "body" - [@@bs.val] [@@bs.scope "document"] - -external create_element : string -> Dom.element = "createElement" - [@@bs.val] [@@bs.scope "document"] - -external create_element_ns : string -> string -> Dom.element = "createElementNS" - [@@bs.val] [@@bs.scope "document"] - -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 create_text_node : 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 deleted file mode 100644 index feb6003..0000000 --- a/src/Lib/Dom/Element.ml +++ /dev/null @@ -1,51 +0,0 @@ -external set_value : Dom.element -> string -> unit = "value" - [@@bs.set] - -external value : Dom.element -> string = "value" - [@@bs.get] - -external set_attribute : Dom.element -> string -> string -> unit = "setAttribute" - [@@bs.send] - -external set_class_name : Dom.element -> string -> unit = "className" - [@@bs.set] - -external add_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit - = "addEventListener" - [@@bs.send] - -external remove_event_listener : Dom.element -> string -> (Dom.event -> unit) -> unit - = "removeEventListener" - [@@bs.send] - -external append_child : Dom.element -> Dom.element -> unit = "appendChild" - [@@bs.send] - -external first_child : Dom.element -> Dom.element Js.Nullable.t = "firstChild" - [@@bs.get] - -external remove_child : Dom.element -> Dom.element -> unit = "removeChild" - [@@bs.send] - -external click : Dom.element -> unit = "click" - [@@bs.send] - -let remove_first_child element = - match Js.toOption (first_child element) with - | Some child -> - let () = remove_child element child in - true - | _ -> false - -let rec remove_children element = - if remove_first_child element then remove_children element else () - -let mount_on base element = - let () = remove_children base in - append_child base element - -external files : Dom.element -> string Js.Array.t = "files" - [@@bs.get] - -external focus : Dom.element -> unit = "focus" - [@@bs.send] diff --git a/src/Lib/Dom/Event.ml b/src/Lib/Dom/Event.ml deleted file mode 100644 index 5a9790f..0000000 --- a/src/Lib/Dom/Event.ml +++ /dev/null @@ -1,17 +0,0 @@ -external prevent_default : Dom.event -> unit = "preventDefault" - [@@bs.send] - -external stop_propagation : Dom.event -> unit = "stopPropagation" - [@@bs.send] - -external target : Dom.event -> Dom.element = "target" - [@@bs.get] - -external related_target : Dom.event -> Dom.element Js.Nullable.t = "relatedTarget" - [@@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 deleted file mode 100644 index 7213daf..0000000 --- a/src/Lib/Dom/H.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* Element creation *) - -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.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.set_attribute element name value - - | EventAttr (name, eventListener) -> - Element.add_event_listener element name eventListener) - attributes - in - let () = - Js.Array.forEach - (fun child -> Element.append_child element child) - children - in - element - -(* Node creation *) - -let text = Document.create_text_node - -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" - -let textarea = h "textarea" - -let i = h "i" - -let a = h "a" - -let h1 = h "h1" - -let h2 = h "h2" - -let h3 = h "h3" diff --git a/src/Lib/Dom/HA.ml b/src/Lib/Dom/HA.ml deleted file mode 100644 index ce02f2a..0000000 --- a/src/Lib/Dom/HA.ml +++ /dev/null @@ -1,43 +0,0 @@ -let concat xs ys = - let partition_class = - Js.Array.reduce - (fun (class_acc, rest_acc) z -> - match z with - | H.TextAttr ("class", c) -> (class_acc ^ " " ^ c, rest_acc) - | _ -> (class_acc, Js.Array.concat [| z |] rest_acc) - ) - ("", [| |]) - in - let (xs_class, xs_rest) = partition_class xs in - let (ys_class, ys_rest) = partition_class ys in - let rest = Js.Array.concat xs_rest ys_rest in - if xs_class == "" && ys_class == "" then - rest - else - Js.Array.concat [| H.TextAttr ("class", xs_class ^ " " ^ ys_class) |] rest - -(* 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) - -let download v = H.TextAttr ("download", v) diff --git a/src/Lib/Dom/HE.ml b/src/Lib/Dom/HE.ml deleted file mode 100644 index 03d2386..0000000 --- a/src/Lib/Dom/HE.ml +++ /dev/null @@ -1,13 +0,0 @@ -(* 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) - -let on_blur f = H.EventAttr ("blur", f) - -let on_change f = H.EventAttr ("change", f) - -let on_focus f = H.EventAttr ("focus", f) diff --git a/src/Lib/Dom/History.ml b/src/Lib/Dom/History.ml deleted file mode 100644 index ce7a877..0000000 --- a/src/Lib/Dom/History.ml +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 index 2c58705..0000000 --- a/src/Lib/Dom/Location.ml +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index 3abc921..0000000 --- a/src/Lib/Dom/Window.ml +++ /dev/null @@ -1,2 +0,0 @@ -external window : Dom.element = "window" - [@@bs.val] diff --git a/src/Lib/File.ml b/src/Lib/File.ml deleted file mode 100644 index d3597e7..0000000 --- a/src/Lib/File.ml +++ /dev/null @@ -1,21 +0,0 @@ -let download filename content = - let a = - H.a - [| HA.href ("data:text/plain;charset=utf-8," ^ URI.encode content) - ; HA.download filename - ; HA.style "display:none" - |] - [| |] - in - let () = Element.append_child Document.body a in - let () = Element.click a in - Element.remove_child Document.body a - -external reader : unit -> Dom.element = "FileReader" - [@@bs.new] - -external read_as_text : Dom.element -> string -> unit = "readAsText" - [@@bs.send] - -external result : Dom.element -> string = "result" - [@@bs.get] diff --git a/src/Lib/FontAwesome.ml b/src/Lib/FontAwesome.ml deleted file mode 100644 index daaf954..0000000 --- a/src/Lib/FontAwesome.ml +++ /dev/null @@ -1,788 +0,0 @@ -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" - ; "assistive-listening-systems" - ; "asterisk" - ; "at" - ; "audio-description" - ; "automobile" - ; "backward" - ; "balance-scale" - ; "ban" - ; "bandcamp" - ; "bank" - ; "bar-chart" - ; "bar-chart-o" - ; "barcode" - ; "bars" - ; "bath" - ; "bathtub" - ; "battery" - ; "battery-0" - ; "battery-1" - ; "battery-2" - ; "battery-3" - ; "battery-4" - ; "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" - ; "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" - ; "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" - ; "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" - ; "cloud" - ; "cloud-download" - ; "cloud-upload" - ; "cny" - ; "code" - ; "code-fork" - ; "codepen" - ; "codiepie" - ; "coffee" - ; "cog" - ; "cogs" - ; "columns" - ; "comment" - ; "comment-o" - ; "commenting" - ; "commenting-o" - ; "comments" - ; "comments-o" - ; "compass" - ; "compress" - ; "connectdevelop" - ; "contao" - ; "copy" - ; "copyright" - ; "creative-commons" - ; "credit-card" - ; "credit-card-alt" - ; "crop" - ; "crosshairs" - ; "css3" - ; "cube" - ; "cubes" - ; "cut" - ; "cutlery" - ; "dashboard" - ; "dashcube" - ; "database" - ; "deaf" - ; "deafness" - ; "dedent" - ; "delicious" - ; "desktop" - ; "deviantart" - ; "diamond" - ; "digg" - ; "dollar" - ; "dot-circle-o" - ; "download" - ; "dribbble" - ; "drivers-license" - ; "drivers-license-o" - ; "dropbox" - ; "drupal" - ; "edge" - ; "edit" - ; "eercast" - ; "eject" - ; "ellipsis-h" - ; "ellipsis-v" - ; "empire" - ; "envelope" - ; "envelope-o" - ; "envelope-open" - ; "envelope-open-o" - ; "envelope-square" - ; "envira" - ; "eraser" - ; "etsy" - ; "eur" - ; "euro" - ; "exchange" - ; "exclamation" - ; "exclamation-circle" - ; "exclamation-triangle" - ; "expand" - ; "expeditedssl" - ; "external-link" - ; "external-link-square" - ; "eye" - ; "eye-slash" - ; "eyedropper" - ; "fa" - ; "facebook" - ; "facebook-f" - ; "facebook-official" - ; "facebook-square" - ; "fast-backward" - ; "fast-forward" - ; "fax" - ; "feed" - ; "female" - ; "fighter-jet" - ; "file" - ; "file-archive-o" - ; "file-audio-o" - ; "file-code-o" - ; "file-excel-o" - ; "file-image-o" - ; "file-movie-o" - ; "file-o" - ; "file-pdf-o" - ; "file-photo-o" - ; "file-picture-o" - ; "file-powerpoint-o" - ; "file-sound-o" - ; "file-text" - ; "file-text-o" - ; "file-video-o" - ; "file-word-o" - ; "file-zip-o" - ; "files-o" - ; "film" - ; "filter" - ; "fire" - ; "fire-extinguisher" - ; "firefox" - ; "first-order" - ; "flag" - ; "flag-checkered" - ; "flag-o" - ; "flash" - ; "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" - ; "gear" - ; "gears" - ; "genderless" - ; "get-pocket" - ; "gg" - ; "gg-circle" - ; "gift" - ; "git" - ; "git-square" - ; "github" - ; "github-alt" - ; "github-square" - ; "gitlab" - ; "gittip" - ; "glass" - ; "glide" - ; "glide-g" - ; "globe" - ; "google" - ; "google-plus" - ; "google-plus-circle" - ; "google-plus-official" - ; "google-plus-square" - ; "google-wallet" - ; "graduation-cap" - ; "gratipay" - ; "grav" - ; "group" - ; "h-square" - ; "hacker-news" - ; "hand-grab-o" - ; "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" - ; "handshake-o" - ; "hard-of-hearing" - ; "hashtag" - ; "hdd-o" - ; "header" - ; "headphones" - ; "heart" - ; "heart-o" - ; "heartbeat" - ; "history" - ; "home" - ; "hospital-o" - ; "hotel" - ; "hourglass" - ; "hourglass-1" - ; "hourglass-2" - ; "hourglass-3" - ; "hourglass-end" - ; "hourglass-half" - ; "hourglass-o" - ; "hourglass-start" - ; "houzz" - ; "html5" - ; "i-cursor" - ; "id-badge" - ; "id-card" - ; "id-card-o" - ; "ils" - ; "image" - ; "imdb" - ; "inbox" - ; "indent" - ; "industry" - ; "info" - ; "info-circle" - ; "inr" - ; "instagram" - ; "institution" - ; "internet-explorer" - ; "intersex" - ; "ioxhost" - ; "italic" - ; "joomla" - ; "jpy" - ; "jsfiddle" - ; "key" - ; "keyboard-o" - ; "krw" - ; "language" - ; "laptop" - ; "lastfm" - ; "lastfm-square" - ; "leaf" - ; "leanpub" - ; "legal" - ; "lemon-o" - ; "level-down" - ; "level-up" - ; "life-bouy" - ; "life-buoy" - ; "life-ring" - ; "life-saver" - ; "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" - ; "mail-reply" - ; "mail-reply-all" - ; "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" - ; "modx" - ; "money" - ; "moon-o" - ; "mortar-board" - ; "motorcycle" - ; "mouse-pointer" - ; "music" - ; "navicon" - ; "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" - ; "pause" - ; "pause-circle" - ; "pause-circle-o" - ; "paw" - ; "paypal" - ; "pencil" - ; "pencil-square" - ; "pencil-square-o" - ; "percent" - ; "phone" - ; "phone-square" - ; "photo" - ; "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" - ; "random" - ; "ravelry" - ; "rebel" - ; "recycle" - ; "reddit" - ; "reddit-alien" - ; "reddit-square" - ; "refresh" - ; "registered" - ; "remove" - ; "renren" - ; "reorder" - ; "repeat" - ; "reply" - ; "reply-all" - ; "resistance" - ; "retweet" - ; "rmb" - ; "road" - ; "rocket" - ; "rotate-left" - ; "rotate-right" - ; "rouble" - ; "rss" - ; "rss-square" - ; "rub" - ; "ruble" - ; "rupee" - ; "s15" - ; "safari" - ; "save" - ; "scissors" - ; "scribd" - ; "search" - ; "search-minus" - ; "search-plus" - ; "sellsy" - ; "send" - ; "send-o" - ; "server" - ; "share" - ; "share-alt" - ; "share-alt-square" - ; "share-square" - ; "share-square-o" - ; "shekel" - ; "sheqel" - ; "shield" - ; "ship" - ; "shirtsinbulk" - ; "shopping-bag" - ; "shopping-basket" - ; "shopping-cart" - ; "shower" - ; "sign-in" - ; "sign-language" - ; "sign-out" - ; "signal" - ; "signing" - ; "simplybuilt" - ; "sitemap" - ; "skyatlas" - ; "skype" - ; "slack" - ; "sliders" - ; "slideshare" - ; "smile-o" - ; "snapchat" - ; "snapchat-ghost" - ; "snapchat-square" - ; "snowflake-o" - ; "soccer-ball-o" - ; "sort" - ; "sort-alpha-asc" - ; "sort-alpha-desc" - ; "sort-amount-asc" - ; "sort-amount-desc" - ; "sort-asc" - ; "sort-desc" - ; "sort-down" - ; "sort-numeric-asc" - ; "sort-numeric-desc" - ; "sort-up" - ; "soundcloud" - ; "space-shuttle" - ; "spinner" - ; "spoon" - ; "spotify" - ; "square" - ; "square-o" - ; "stack-exchange" - ; "stack-overflow" - ; "star" - ; "star-half" - ; "star-half-empty" - ; "star-half-full" - ; "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" - ; "table" - ; "tablet" - ; "tachometer" - ; "tag" - ; "tags" - ; "tasks" - ; "taxi" - ; "telegram" - ; "television" - ; "tencent-weibo" - ; "terminal" - ; "text-height" - ; "text-width" - ; "th" - ; "th-large" - ; "th-list" - ; "themeisle" - ; "thermometer" - ; "thermometer-0" - ; "thermometer-1" - ; "thermometer-2" - ; "thermometer-3" - ; "thermometer-4" - ; "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" - ; "times-rectangle-o" - ; "tint" - ; "toggle-down" - ; "toggle-left" - ; "toggle-off" - ; "toggle-on" - ; "toggle-right" - ; "toggle-up" - ; "trademark" - ; "train" - ; "transgender" - ; "transgender-alt" - ; "trash" - ; "trash-o" - ; "tree" - ; "trello" - ; "tripadvisor" - ; "trophy" - ; "truck" - ; "try" - ; "tty" - ; "tumblr" - ; "tumblr-square" - ; "turkish-lira" - ; "tv" - ; "twitch" - ; "twitter" - ; "twitter-square" - ; "umbrella" - ; "underline" - ; "undo" - ; "universal-access" - ; "university" - ; "unlink" - ; "unlock" - ; "unlock-alt" - ; "unsorted" - ; "upload" - ; "usb" - ; "usd" - ; "user" - ; "user-circle" - ; "user-circle-o" - ; "user-md" - ; "user-o" - ; "user-plus" - ; "user-secret" - ; "user-times" - ; "users" - ; "vcard" - ; "vcard-o" - ; "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" - ; "wechat" - ; "weibo" - ; "weixin" - ; "whatsapp" - ; "wheelchair" - ; "wheelchair-alt" - ; "wifi" - ; "wikipedia-w" - ; "window-close" - ; "window-close-o" - ; "window-maximize" - ; "window-minimize" - ; "window-restore" - ; "windows" - ; "won" - ; "wordpress" - ; "wpbeginner" - ; "wpexplorer" - ; "wpforms" - ; "wrench" - ; "xing" - ; "xing-square" - ; "y-combinator" - ; "y-combinator-square" - ; "yahoo" - ; "yc" - ; "yc-square" - ; "yelp" - ; "yen" - ; "yoast" - ; "youtube" - ; "youtube-play" - ; "youtube-square" - |] diff --git a/src/Lib/Fun.ml b/src/Lib/Fun.ml deleted file mode 100644 index bf1eb38..0000000 --- a/src/Lib/Fun.ml +++ /dev/null @@ -1,2 +0,0 @@ -let flip f b a = - f a b diff --git a/src/Lib/Leaflet.ml b/src/Lib/Leaflet.ml deleted file mode 100644 index 282b5b0..0000000 --- a/src/Lib/Leaflet.ml +++ /dev/null @@ -1,89 +0,0 @@ -type layer - -type map_options = - { attributionControl : bool - } - -external map : string -> map_options -> layer = "map" - [@@bs.val] [@@bs.scope "L"] - -external setView : layer -> float array -> int -> unit = "setView" - [@@bs.send] - -type event - -external on : layer -> string -> (event -> unit) -> unit = "on" - [@@bs.send] - -type lat_lng = - { lat : float; - lng : float; - } - -external original_event : event -> Dom.mouseEvent = "originalEvent" - [@@bs.get] - -external lat_lng : event -> lat_lng = "latlng" - [@@bs.get] - -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] - -(* Fit bounds *) - -external feature_group : layer array -> layer = "featureGroup" - [@@bs.val] [@@bs.scope "L"] - -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 - ; icon : icon - ; draggable : bool - } - -external marker : lat_lng -> markerInput -> layer = "marker" - [@@bs.val] [@@bs.scope "L"] diff --git a/src/Lib/Modal.ml b/src/Lib/Modal.ml deleted file mode 100644 index 5db88cd..0000000 --- a/src/Lib/Modal.ml +++ /dev/null @@ -1,25 +0,0 @@ -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" |] - [| Button.raw - [| 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 diff --git a/src/Lib/Option.ml b/src/Lib/Option.ml deleted file mode 100644 index 1158b96..0000000 --- a/src/Lib/Option.ml +++ /dev/null @@ -1,9 +0,0 @@ -let withDefault default opt = - match opt with - | Some v -> v - | None -> default - -let map f opt = - match opt with - | Some v -> Some (f v) - | None -> None diff --git a/src/Lib/String.ml b/src/Lib/String.ml deleted file mode 100644 index be16d0e..0000000 --- a/src/Lib/String.ml +++ /dev/null @@ -1,35 +0,0 @@ -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/Lib/URI.ml b/src/Lib/URI.ml deleted file mode 100644 index 705bc7b..0000000 --- a/src/Lib/URI.ml +++ /dev/null @@ -1,2 +0,0 @@ -external encode : string -> string = "encodeURIComponent" - [@@bs.val] diff --git a/src/Main.ml b/src/Main.ml deleted file mode 100644 index 9216b35..0000000 --- a/src/Main.ml +++ /dev/null @@ -1,3 +0,0 @@ -let () = - let body = Document.query_selector_unsafe "body" in - Element.append_child body (Map.render ()) diff --git a/src/State.ml b/src/State.ml deleted file mode 100644 index c1cb99d..0000000 --- a/src/State.ml +++ /dev/null @@ -1,119 +0,0 @@ -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 - -(* URL 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_url_string state = - state - |> Js.Array.map marker_to_string - |> Js.Array.joinWith sep - |> String.encode - -let from_url_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 - -(* Colors *) - -let default_color = "#3f92cf" - -let colors = - Js.Array.reduce - (fun colors marker -> - if Js.Array.indexOf marker.color colors == -1 then - Js.Array.concat [| marker.color |] colors - else - colors) - [| |] - -(* CSV Serialization *) - -let lat_key = "lat" -let lng_key = "lng" -let name_key = "name" -let color_key = "color" -let icon_key = "icon" - -let to_csv_string state = - let to_csv_line marker = - [| Js.Float.toString marker.pos.lat - ; Js.Float.toString marker.pos.lng - ; marker.name - ; marker.color - ; marker.icon - |] - in let - header = - [| lat_key; lng_key; name_key; color_key; icon_key |] - in - state - |> Js.Array.map to_csv_line - |> Fun.flip Js.Array.concat [| header |] - |> CSV.to_string - -let from_dicts dicts = - Js.Array.map - (fun dict -> - (* let get key default = Js.Dict.get dict key |> Option.withDefault default in *) - { pos = - { lat = - Js.Dict.get dict lat_key - |> Option.map Js.Float.fromString - |> Option.withDefault 0.0 - ; lng = - Js.Dict.get dict lng_key - |> Option.map Js.Float.fromString - |> Option.withDefault 0.0 - } - ; name = Js.Dict.get dict name_key |> Option.withDefault "" - ; color = Js.Dict.get dict color_key |> Option.withDefault default_color - ; icon = Js.Dict.get dict icon_key |> Option.withDefault "" - }) - dicts diff --git a/src/View/Button.ml b/src/View/Button.ml deleted file mode 100644 index b4641d2..0000000 --- a/src/View/Button.ml +++ /dev/null @@ -1,19 +0,0 @@ -let raw attrs content = - H.button - (HA.concat [| HA.class_ "g-Button__Raw" |] attrs) - content - -let text attrs content = - H.button - (HA.concat [| HA.class_ "g-Button__Text" |] attrs) - content - -let action attrs content = - H.button - (HA.concat [| HA.class_ "g-Button__Action" |] attrs) - content - -let cancel attrs content = - H.button - (HA.concat [| HA.class_ "g-Button__Cancel" |] attrs) - content diff --git a/src/View/Form.ml b/src/View/Form.ml deleted file mode 100644 index cec49d6..0000000 --- a/src/View/Form.ml +++ /dev/null @@ -1,65 +0,0 @@ -let input id label attrs = - 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.concat attrs [| HA.id id |]) - [| |] - |] - -let color_input default_colors id label init_value on_input = - let - input = - H.input - [| HA.id id - ; HE.on_input (fun e -> on_input (Element.value (Event.target e))) - ; HA.value init_value - ; HA.type_ "color" - |] - [| |] - in - H.div - [| HA.class_ "g-Form__Field" |] - [| H.div - [| HA.class_ "g-Form__Label" |] - [| H.label - [| HA.for_ id |] - [| H.text label |] - |] - ; Layout.line - [| |] - (default_colors - |> Js.Array.map (fun color -> - Button.raw - [| HA.class_ "g-Form__DefaultColor" - ; HA.style ("background-color: " ^ color) - ; HE.on_click (fun _ -> - let () = Element.set_value input color in - on_input color) - ; HA.type_ "button" - |] - [| |]) - |> Fun.flip Js.Array.concat [| input |]) - |] - -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 deleted file mode 100644 index 98e4b43..0000000 --- a/src/View/Form/Autocomplete.ml +++ /dev/null @@ -1,80 +0,0 @@ -let search s xs = - Js.Array.filter (Js.String.includes s) xs - -let render_completion render_entry on_select entries = - H.div - [| HA.class_ "g-Autocomplete__Completion" |] - (entries - |> Js.Array.map (fun c -> - Button.raw - [| HA.class_ "g-Autocomplete__Entry" - ; HA.type_ "button" - ; HE.on_click (fun e -> - let () = Event.stop_propagation e in - let () = Event.prevent_default e in - on_select c) - |] - (render_entry c))) - -let create attrs id values render_entry on_input = - - let completion = - H.div [| |] [| |] - in - - let update_completion target value = - let entries = search value values in - Element.mount_on completion (render_completion - render_entry - (fun selected -> - let () = Element.set_value target selected in - let () = Element.remove_children completion in - on_input selected) - entries) - in - - let hide_completion () = - Element.mount_on completion (H.text "") - in - - let - input = - H.input - (HA.concat - attrs - [| HA.id id - ; HA.class_ "g-Autocomplete__Input" - ; HA.autocomplete "off" - ; HE.on_focus (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) - |]) - [| |] - in - - let () = - Element.add_event_listener input "blur" (fun e -> - if Js.isNullable (Event.related_target e) then - hide_completion ()) - in - - H.div - [| HA.class_ "g-Autocomplete" |] - [| input - ; completion - ; Button.raw - [| HA.class_ "g-Autocomplete__Clear fa fa-close" - ; HA.type_ "button" - ; HE.on_click (fun _ -> - let () = on_input "" in - let () = Element.set_value input "" in - Element.focus input) - |] - [| |] - |] diff --git a/src/View/Layout.ml b/src/View/Layout.ml deleted file mode 100644 index db1e234..0000000 --- a/src/View/Layout.ml +++ /dev/null @@ -1,9 +0,0 @@ -let section attrs content = - H.div - (HA.concat attrs [| HA.class_ "g-Layout__Section" |]) - content - -let line attrs content = - H.div - (HA.concat attrs [| HA.class_ "g-Layout__Line" |]) - content diff --git a/src/View/Map.ml b/src/View/Map.ml deleted file mode 100644 index 6e2611e..0000000 --- a/src/View/Map.ml +++ /dev/null @@ -1,131 +0,0 @@ -let state_from_hash () = - let hash = Js.String.sliceToEnd ~from:1 (Location.hash Document.location) in - State.from_url_string hash - -let rec reload_from_hash state map markers focus = - let update_state new_state = - let () = History.push_state "" "" ("#" ^ State.to_url_string new_state) () in - reload_from_hash state map markers 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 colors = State.colors !state in - let () = - Js.Array.forEach - (fun (m: State.marker_state) -> Leaflet.add_layer markers (Marker.create on_remove on_update colors 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 - () - -let mapView state map markers = - H.div - [| HA.class_ "g-Layout__Page" |] - [| H.div - [| HA.class_ "g-Layout__Header" |] - [| H.a - [| HA.class_ "g-Layout__Home" - ; HA.href "#" - |] - [| H.text "Map" |] - ; Layout.line - [| HA.class_ "g-Layout__HeaderImportExport" |] - [| H.input - [| HA.id "g-Header__ImportInput" - ; HA.type_ "file" - ; HE.on_change (fun e -> - match !map with - | Some map -> - let reader = File.reader () in - let () = Element.add_event_listener reader "load" (fun _ -> - let str = File.result reader in - let new_state = State.from_dicts (CSV.to_dicts (CSV.parse str)) in - let () = History.push_state "" "" ("#" ^ State.to_url_string new_state) () in - reload_from_hash state map markers true) - in - File.read_as_text reader ( - Js.Array.unsafe_get (Element.files (Event.target e)) 0) - | _ -> - ()) - |] - [| |] - ; H.label - [| HA.for_ "g-Header__ImportInput" - ; HA.class_ "g-Button__Text" - |] - [| H.text "Import" |] - ; Button.text - [| HE.on_click (fun _ -> File.download "map.csv" (State.to_csv_string !state)) |] - [| H.text "Export" |] - |] - |] - ; H.div - [| HA.class_ "g-Map" |] - [| H.div - [| HA.id "g-Map__Content" |] - [||] - |] - |] - -let install_map state map_ref markers = - let map = Leaflet.map "g-Map__Content" { attributionControl = false } in - let () = map_ref := Some map in - let title_layer = Leaflet.title_layer "http://{s}.tile.osm.org/{z}/{x}/{y}.png" in - let () = Leaflet.add_layer map markers in - let () = Leaflet.add_layer map title_layer in - - (* Init markers from url *) - let () = reload_from_hash state map markers true in - - (* Reload the map if the URL changes *) - let () = Element.add_event_listener Window.window "popstate" (fun _ -> - reload_from_hash state map markers true) - in - - let add_marker pos name color icon = - let new_marker = { State.pos = pos; name = name; color = color; icon = icon } in - let new_state = State.update !state pos new_marker in - let () = History.push_state "" "" ("#" ^ State.to_url_string new_state) () in - reload_from_hash state map markers false - in - - (* Context menu *) - Leaflet.on map "contextmenu" (fun event -> - ContextMenu.show - (Leaflet.original_event event) - [| { label = "Add a marker" - ; action = (fun _ -> - let pos = Leaflet.lat_lng event in - let marker = - match State.last_added !state with - | Some m -> { m with pos = pos; name = "" } - | _ -> { pos = pos; name = ""; color = "#3f92cf"; icon = "" } - in - let colors = State.colors !state in - Modal.show (Marker.form (add_marker pos) colors marker.name marker.color marker.icon)) - } - |]) - -let render () = - let state = ref (state_from_hash ()) in - let map = ref None in - let markers = Leaflet.feature_group [| |] in - let _ = Js.Global.setTimeout (fun _ -> install_map state map markers) 0 in - mapView state map markers diff --git a/src/View/Map/Icon.ml b/src/View/Map/Icon.ml deleted file mode 100644 index 8737f43..0000000 --- a/src/View/Map/Icon.ml +++ /dev/null @@ -1,32 +0,0 @@ -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 = "" - ; popupAnchor = [| 0.; -34. |] - ; html = - H.div - [| HA.class_ "g-Marker" |] - [| H.div - [| HA.class_ "g-Marker__Round" - ; HA.style ("background-color: " ^ color) - |] - [| |] - ; H.div [| HA.class_ "g-Marker__PeakBorder" |] [| |] - ; H.div - [| HA.class_ "g-Marker__PeakInner" - ; HA.style ("border-top-color: " ^ color) - |] - [| |] - ; H.div - [| HA.class_ "g-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 deleted file mode 100644 index 1c0c0d6..0000000 --- a/src/View/Map/Marker.ml +++ /dev/null @@ -1,105 +0,0 @@ -let form on_validate colors init_name init_color init_icon = - let name = ref init_name in - let color = ref init_color in - let icon = ref init_icon in - let on_validate () = - let () = on_validate !name !color !icon in - Modal.hide () - in - H.div - [| |] - [| Layout.section - [| |] - [| H.form - [| HA.class_ "g-MarkerForm" - ; HE.on_submit (fun e -> - let () = Event.prevent_default e in - on_validate ()) - |] - [| Layout.section - [| |] - [| Form.input - "g-MarkerForm__Name" - "Name" - [| HE.on_input (fun e -> name := (Element.value (Event.target e))) - ; HA.value init_name - |] - ; Form.color_input colors "g-MarkerForm__Color" "Color" init_color (fun newColor -> color := newColor) - ; H.div - [| HA.class_ "g-Form__Field" |] - [| H.div - [| HA.class_ "g-Form__Label" |] - [| H.label - [| HA.for_ "g-MarkerForm__IconInput" |] - [| H.text "Icon" |] - |] - ; let dom_icon = H.div [| HA.class_ ("fa fa-" ^ !icon) |] [| |] in - Layout.line - [| HA.class_ "g-MarkerForm__AutocompleteAndIcon" |] - [| Autocomplete.create - [| HA.value init_icon - ; HA.class_ "g-MarkerForm__Autocomplete" - |] - "g-MarkerForm__IconInput" - FontAwesome.icons - (fun icon -> - [| H.div - [| HA.class_ ("g-MarkerForm__IconEntry fa fa-" ^ icon) |] - [| |] - ; H.text icon - |]) - (fun newIcon -> - let () = icon := newIcon in - Element.set_class_name dom_icon ("fa fa-" ^ newIcon)) - ; H.div [| HA.class_ "g-MarkerForm__Icon" |] [| dom_icon |] - |] - |] - |] - ; Layout.line - [| |] - [| Button.action - [| HE.on_click (fun _ -> on_validate ()) |] - [| H.text "Save" |] - ; Button.cancel - [| HE.on_click (fun _ -> Modal.hide ()) - ; HA.type_ "button" - |] - [| H.text "Cancel" |] - |] - |] - |] - |] - - -let create on_remove on_update colors 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 - - (* Context menu *) - let () = Leaflet.on marker "contextmenu" (fun event -> - ContextMenu.show - (Leaflet.original_event event) - [| { label = "Modify" - ; action = fun _ -> - Modal.show (form (on_update pos pos) colors init_name init_color init_icon) - } - ; { label = "Remove" - ; action = fun _ -> on_remove pos - } - |]) - 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 - - let () = Leaflet.on marker "dblclick" (fun _ -> - Modal.show (form (on_update pos pos) colors init_name init_color init_icon)) in - - marker diff --git a/src/lib/autoComplete.ts b/src/lib/autoComplete.ts new file mode 100644 index 0000000..769f617 --- /dev/null +++ b/src/lib/autoComplete.ts @@ -0,0 +1,114 @@ +import { h, Children, concatClassName } from 'lib/h' +import * as Button from 'lib/button' + +export function create( + attrs: object, + id: string, + values: string[], + renderEntry: (entry: string) => Element, + onInput: (value: string) => void +): Element { + const completion = h('div', {}) + + const updateCompletion = (target: EventTarget, value: string) => { + const entries = search(value, values) + mountOn( + completion, + renderCompletion( + renderEntry, + selected => { + (target as HTMLInputElement).value = selected + completion.remove + removeChildren(completion) + onInput(selected) + }, + entries + ) + ) + } + + const input = h('input', + concatClassName( + { ...attrs, + id, + autocomplete: 'off', + onfocus: (e: Event) => { + if (e.target !== null) { + const target = e.target as HTMLInputElement + updateCompletion(target, target.value) + } + }, + oninput: (e: Event) => { + if (e.target !== null) { + const target = e.target as HTMLInputElement + updateCompletion(target, target.value) + onInput(target.value) + } + } + }, + 'g-AutoComplete__Input' + ) + ) as HTMLInputElement + + input.addEventListener('blur', (e: MouseEvent) => { + if (e.relatedTarget === null) { + removeChildren(completion) + } + }) + + return h('div', + { className: 'g-AutoComplete' }, + input, + completion, + Button.raw( + { className: 'g-AutoComplete__Clear fa fa-close', + type: 'button', + onclick: () => { + onInput('') + input.value = '' + input.focus() + } + } + ) + ) +} + +function renderCompletion( + renderEntry: (entry: string) => Element, + onSelect: (entry: string) => void, + entries: string[] +): Element { + return h('div', + { className: 'g-AutoComplete__Completion' }, + ...entries.map(c => + Button.raw( + { className: 'g-AutoComplete__Entry', + type: 'button', + onclick: (e: Event) => { + e.stopPropagation() + e.preventDefault() + onSelect(c) + } + }, + renderEntry(c) + ) + ) + ) +} + +function search(s: string, xs: string[]): string[] { + return xs.filter(x => x.includes(s)) +} + +function mountOn(base: Element, ...children: Element[]) { + removeChildren(base) + children.forEach(child => base.appendChild(child)) +} + +function removeChildren(base: Element) { + const firstChild = base.firstChild + if (firstChild !== null) { + base.removeChild(firstChild) + removeChildren(base) + } +} diff --git a/src/lib/button.ts b/src/lib/button.ts new file mode 100644 index 0000000..794df35 --- /dev/null +++ b/src/lib/button.ts @@ -0,0 +1,29 @@ +import { h, Children, concatClassName } from 'lib/h' + +export function raw(attrs: object, ...children: Children): Element { + return h('button', + concatClassName(attrs, 'g-Button__Raw'), + ...children + ) +} + +export function text(attrs: object, ...children: Children): Element { + return h('button', + concatClassName(attrs, 'g-Button__Text'), + ...children + ) +} + +export function action(attrs: object, ...children: Children): Element { + return h('button', + concatClassName(attrs, 'g-Button__Action'), + ...children + ) +} + +export function cancel(attrs: object, ...children: Children): Element { + return h('button', + concatClassName(attrs, 'g-Button__Cancel'), + ...children + ) +} diff --git a/src/lib/contextMenu.ts b/src/lib/contextMenu.ts new file mode 100644 index 0000000..6edd567 --- /dev/null +++ b/src/lib/contextMenu.ts @@ -0,0 +1,35 @@ +import { h } from 'lib/h' + +interface Action { + label: string, + action: () => void +} + +export function show(event: MouseEvent, actions: Action[]) { + const menu = h('div', + { id: 'g-ContextMenu', + style: `left: ${event.pageX.toString()}px; top: ${event.pageY.toString()}px` + }, + ...actions.map(({ label, action }) => + h('div', + { className: 'g-ContextMenu__Entry', + onclick: () => action() + }, + label + ) + ) + ) + + document.body.appendChild(menu) + + // Remove on click or context menu + setTimeout(() => { + const f = () => { + document.body.removeChild(menu) + document.body.removeEventListener('click', f) + document.body.removeEventListener('contextmenu', f) + } + document.body.addEventListener('click', f) + document.body.addEventListener('contextmenu', f) + }, 0) +} diff --git a/src/lib/fontAwesome.ts b/src/lib/fontAwesome.ts new file mode 100644 index 0000000..896fa52 --- /dev/null +++ b/src/lib/fontAwesome.ts @@ -0,0 +1,788 @@ +export const icons: string [] = [ + "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", + "assistive-listening-systems", + "asterisk", + "at", + "audio-description", + "automobile", + "backward", + "balance-scale", + "ban", + "bandcamp", + "bank", + "bar-chart", + "bar-chart-o", + "barcode", + "bars", + "bath", + "bathtub", + "battery", + "battery-0", + "battery-1", + "battery-2", + "battery-3", + "battery-4", + "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", + "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", + "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", + "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", + "cloud", + "cloud-download", + "cloud-upload", + "cny", + "code", + "code-fork", + "codepen", + "codiepie", + "coffee", + "cog", + "cogs", + "columns", + "comment", + "comment-o", + "commenting", + "commenting-o", + "comments", + "comments-o", + "compass", + "compress", + "connectdevelop", + "contao", + "copy", + "copyright", + "creative-commons", + "credit-card", + "credit-card-alt", + "crop", + "crosshairs", + "css3", + "cube", + "cubes", + "cut", + "cutlery", + "dashboard", + "dashcube", + "database", + "deaf", + "deafness", + "dedent", + "delicious", + "desktop", + "deviantart", + "diamond", + "digg", + "dollar", + "dot-circle-o", + "download", + "dribbble", + "drivers-license", + "drivers-license-o", + "dropbox", + "drupal", + "edge", + "edit", + "eercast", + "eject", + "ellipsis-h", + "ellipsis-v", + "empire", + "envelope", + "envelope-o", + "envelope-open", + "envelope-open-o", + "envelope-square", + "envira", + "eraser", + "etsy", + "eur", + "euro", + "exchange", + "exclamation", + "exclamation-circle", + "exclamation-triangle", + "expand", + "expeditedssl", + "external-link", + "external-link-square", + "eye", + "eye-slash", + "eyedropper", + "fa", + "facebook", + "facebook-f", + "facebook-official", + "facebook-square", + "fast-backward", + "fast-forward", + "fax", + "feed", + "female", + "fighter-jet", + "file", + "file-archive-o", + "file-audio-o", + "file-code-o", + "file-excel-o", + "file-image-o", + "file-movie-o", + "file-o", + "file-pdf-o", + "file-photo-o", + "file-picture-o", + "file-powerpoint-o", + "file-sound-o", + "file-text", + "file-text-o", + "file-video-o", + "file-word-o", + "file-zip-o", + "files-o", + "film", + "filter", + "fire", + "fire-extinguisher", + "firefox", + "first-order", + "flag", + "flag-checkered", + "flag-o", + "flash", + "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", + "gear", + "gears", + "genderless", + "get-pocket", + "gg", + "gg-circle", + "gift", + "git", + "git-square", + "github", + "github-alt", + "github-square", + "gitlab", + "gittip", + "glass", + "glide", + "glide-g", + "globe", + "google", + "google-plus", + "google-plus-circle", + "google-plus-official", + "google-plus-square", + "google-wallet", + "graduation-cap", + "gratipay", + "grav", + "group", + "h-square", + "hacker-news", + "hand-grab-o", + "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", + "handshake-o", + "hard-of-hearing", + "hashtag", + "hdd-o", + "header", + "headphones", + "heart", + "heart-o", + "heartbeat", + "history", + "home", + "hospital-o", + "hotel", + "hourglass", + "hourglass-1", + "hourglass-2", + "hourglass-3", + "hourglass-end", + "hourglass-half", + "hourglass-o", + "hourglass-start", + "houzz", + "html5", + "i-cursor", + "id-badge", + "id-card", + "id-card-o", + "ils", + "image", + "imdb", + "inbox", + "indent", + "industry", + "info", + "info-circle", + "inr", + "instagram", + "institution", + "internet-explorer", + "intersex", + "ioxhost", + "italic", + "joomla", + "jpy", + "jsfiddle", + "key", + "keyboard-o", + "krw", + "language", + "laptop", + "lastfm", + "lastfm-square", + "leaf", + "leanpub", + "legal", + "lemon-o", + "level-down", + "level-up", + "life-bouy", + "life-buoy", + "life-ring", + "life-saver", + "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", + "mail-reply", + "mail-reply-all", + "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", + "modx", + "money", + "moon-o", + "mortar-board", + "motorcycle", + "mouse-pointer", + "music", + "navicon", + "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", + "pause", + "pause-circle", + "pause-circle-o", + "paw", + "paypal", + "pencil", + "pencil-square", + "pencil-square-o", + "percent", + "phone", + "phone-square", + "photo", + "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", + "random", + "ravelry", + "rebel", + "recycle", + "reddit", + "reddit-alien", + "reddit-square", + "refresh", + "registered", + "remove", + "renren", + "reorder", + "repeat", + "reply", + "reply-all", + "resistance", + "retweet", + "rmb", + "road", + "rocket", + "rotate-left", + "rotate-right", + "rouble", + "rss", + "rss-square", + "rub", + "ruble", + "rupee", + "s15", + "safari", + "save", + "scissors", + "scribd", + "search", + "search-minus", + "search-plus", + "sellsy", + "send", + "send-o", + "server", + "share", + "share-alt", + "share-alt-square", + "share-square", + "share-square-o", + "shekel", + "sheqel", + "shield", + "ship", + "shirtsinbulk", + "shopping-bag", + "shopping-basket", + "shopping-cart", + "shower", + "sign-in", + "sign-language", + "sign-out", + "signal", + "signing", + "simplybuilt", + "sitemap", + "skyatlas", + "skype", + "slack", + "sliders", + "slideshare", + "smile-o", + "snapchat", + "snapchat-ghost", + "snapchat-square", + "snowflake-o", + "soccer-ball-o", + "sort", + "sort-alpha-asc", + "sort-alpha-desc", + "sort-amount-asc", + "sort-amount-desc", + "sort-asc", + "sort-desc", + "sort-down", + "sort-numeric-asc", + "sort-numeric-desc", + "sort-up", + "soundcloud", + "space-shuttle", + "spinner", + "spoon", + "spotify", + "square", + "square-o", + "stack-exchange", + "stack-overflow", + "star", + "star-half", + "star-half-empty", + "star-half-full", + "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", + "table", + "tablet", + "tachometer", + "tag", + "tags", + "tasks", + "taxi", + "telegram", + "television", + "tencent-weibo", + "terminal", + "text-height", + "text-width", + "th", + "th-large", + "th-list", + "themeisle", + "thermometer", + "thermometer-0", + "thermometer-1", + "thermometer-2", + "thermometer-3", + "thermometer-4", + "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", + "times-rectangle-o", + "tint", + "toggle-down", + "toggle-left", + "toggle-off", + "toggle-on", + "toggle-right", + "toggle-up", + "trademark", + "train", + "transgender", + "transgender-alt", + "trash", + "trash-o", + "tree", + "trello", + "tripadvisor", + "trophy", + "truck", + "try", + "tty", + "tumblr", + "tumblr-square", + "turkish-lira", + "tv", + "twitch", + "twitter", + "twitter-square", + "umbrella", + "underline", + "undo", + "universal-access", + "university", + "unlink", + "unlock", + "unlock-alt", + "unsorted", + "upload", + "usb", + "usd", + "user", + "user-circle", + "user-circle-o", + "user-md", + "user-o", + "user-plus", + "user-secret", + "user-times", + "users", + "vcard", + "vcard-o", + "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", + "wechat", + "weibo", + "weixin", + "whatsapp", + "wheelchair", + "wheelchair-alt", + "wifi", + "wikipedia-w", + "window-close", + "window-close-o", + "window-maximize", + "window-minimize", + "window-restore", + "windows", + "won", + "wordpress", + "wpbeginner", + "wpexplorer", + "wpforms", + "wrench", + "xing", + "xing-square", + "y-combinator", + "y-combinator-square", + "yahoo", + "yc", + "yc-square", + "yelp", + "yen", + "yoast", + "youtube", + "youtube-play", + "youtube-square" +] diff --git a/src/lib/form.ts b/src/lib/form.ts new file mode 100644 index 0000000..a1f8cfd --- /dev/null +++ b/src/lib/form.ts @@ -0,0 +1,80 @@ +import { h } from 'lib/h' +import * as Layout from 'lib/layout' +import * as Button from 'lib/button' + +export function input(id: string, label: string, attrs: object): Element { + return h('div', + { className: 'g-Form__Field' }, + h('div', + { className: 'g-Form__Label' }, + h('label', { for: id }, label) + ), + h('input', { id: id, ...attrs }) + ) +} + +export function colorInput( + defaultColors: string[], + id: string, + label: string, + initValue: string, + onInput: (value: string) => void +): Element { + const input = h('input', + { id, + value: initValue, + type: 'color', + oninput: (e: Event) => { + if (e.target !== null) { + onInput((e.target as HTMLInputElement).value) + } + } + } + ) as HTMLInputElement + return h('div', + { className: 'g-Form__Field' }, + h('div', + { className: 'g-Form__Label' }, + h('label', { for: id }, label) + ), + Layout.line( + {}, + ...(defaultColors.map(color => + Button.raw({ className: 'g-Form__DefaultColor', + style: `background-color: ${color}`, + type: 'button', + onclick: () => { + input.value = color + onInput(color) + } + }) + ).concat(input)) + ) + ) +} + +export function textarea( + id: string, + label: string, + initValue: string, + onInput: (value: string) => void +): Element { + return h('div', + { className: 'g-Form__Field' }, + h('div', + { className: 'g-Form__Label' }, + h('label', { for: id }, label) + ), + h('textarea', + { id, + className: 'g-Form__Textarea', + oninput: (e: Event) => { + if (e.target !== null) { + onInput((e.target as HTMLTextAreaElement).value) + } + } + }, + initValue + ) + ) +} diff --git a/src/lib/h.ts b/src/lib/h.ts new file mode 100644 index 0000000..1e49f2f --- /dev/null +++ b/src/lib/h.ts @@ -0,0 +1,41 @@ +type Child = Element | Text | string | number + +export type Children = Child[] + +export function h( + tagName: string, + attrs: object, + ...children: Children +): Element { + const isSvg = tagName === 'svg' || tagName === 'path' + + let elem = isSvg + ? document.createElementNS('http://www.w3.org/2000/svg', tagName) + : document.createElement(tagName) + + if (isSvg) { + Object.entries(attrs).forEach(([key, value]) => { + elem.setAttribute(key, value) + }) + } else { + elem = Object.assign(elem, attrs) + } + + for (const child of children) { + if (typeof child === 'number') + elem.append(child.toString()) + else + elem.append(child) + // if (Array.isArray(child)) + // elem.append(...child) + // else + // elem.append(child) + } + + return elem +} + +export function concatClassName(attrs: any, className: string): object { + const existingClassName = 'className' in attrs ? attrs['className'] : undefined + return { ...attrs, className: `${className} ${existingClassName}` } +} diff --git a/src/lib/layout.ts b/src/lib/layout.ts new file mode 100644 index 0000000..1e38bfd --- /dev/null +++ b/src/lib/layout.ts @@ -0,0 +1,15 @@ +import { h, Children, concatClassName } from 'lib/h' + +export function section(attrs: object, ...children: Children): Element { + return h('div', + concatClassName(attrs, 'g-Layout__Section'), + ...children + ) +} + +export function line(attrs: object, ...children: Children): Element { + return h('div', + concatClassName(attrs, 'g-Layout__Line'), + ...children + ) +} diff --git a/src/lib/modal.ts b/src/lib/modal.ts new file mode 100644 index 0000000..4f8c675 --- /dev/null +++ b/src/lib/modal.ts @@ -0,0 +1,28 @@ +import { h } from 'lib/h' +import * as Button from 'lib/button' + +export function show(content: Element) { + document.body.appendChild(h('div', + { id: 'g-Modal' }, + h('div', + { className: 'g-Modal__Curtain', + onclick: () => hide() + } + ), + h('div', + { className: 'g-Modal__Window' }, + Button.raw( + { className: 'g-Modal__Close', + onclick: () => hide() + }, + h('div', { className: 'fa fa-close' }) + ), + content + ) + )) +} + +export function hide() { + const modal = document.querySelector('#g-Modal') + modal && document.body.removeChild(modal) +} diff --git a/src/main.ts b/src/main.ts new file mode 100644 index 0000000..36b1143 --- /dev/null +++ b/src/main.ts @@ -0,0 +1,3 @@ +import * as Map from 'map' + +document.body.appendChild(Map.view()) diff --git a/src/map.ts b/src/map.ts new file mode 100644 index 0000000..cc1df17 --- /dev/null +++ b/src/map.ts @@ -0,0 +1,126 @@ +import { h } from 'lib/h' +import * as Button from 'lib/button' +import * as ContextMenu from 'lib/contextMenu' +import * as Layout from 'lib/layout' +import * as Modal from 'lib/modal' +import * as Marker from 'marker' +const L = window.L + +let map + +export function view() { + // let state = ref (state_from_hash ()) in + // let map = ref None in + // let markers = Leaflet.feature_group [| |] in + window.setTimeout(() => map = getMap(), 0) + return element() +} + +function element(): Element { + return h('div', + { className: 'g-Layout__Page' }, + h('div', + { className: 'g-Layout__Header' }, + h('a', + { className: 'g-Layout__Home', + href: '#' + }, + 'Map' + ), + Layout.line( + { className: 'g-Layout__HeaderImportExport' }, + h('input', + { id: 'g-Header__ImportInput', + type: 'file', + onchange: () => { + // match !map with + // | Some map -> + // let reader = File.reader () in + // let () = Element.add_event_listener reader 'load' (fun _ -> + // let str = File.result reader in + // let new_state = State.from_dicts (CSV.to_dicts (CSV.parse str)) in + // let () = History.push_state '' '' ('#' ^ State.to_url_string new_state) () in + // reload_from_hash state map markers true) + // in + // File.read_as_text reader ( + // Js.Array.unsafe_get (Element.files (Event.target e)) 0) + // | _ -> + // ()) + } + } + ), + h('label', + { for: 'g-Header__ImportInput', + className: 'g-Button__Text' + }, + 'Import' + ), + Button.text({}, 'Export') + // { onclick: () => File.download 'map.csv' (State.to_csv_string !state)) |] + ) + ) + , h('div', + { className: 'g-Map' }, + h('div', { id: 'g-Map__Content' }) + ) + ) +} + +function getMap(): object { + + const map = L.map('g-Map__Content', { + center: [51.505, -0.09], + zoom: 13, + attributionControl: false + }) + + // map.addLayer(markers) + map.addLayer(L.tileLayer('http://{s}.tile.osm.org/{z}/{x}/{y}.png')) + + // (* Init markers from url *) + // let () = reload_from_hash state map markers true in + + // (* Reload the map if the URL changes *) + // let () = Element.add_event_listener Window.window 'popstate' (fun _ -> + // reload_from_hash state map markers true) + // in + + // Context menu + map.addEventListener('contextmenu', e => { + ContextMenu.show( + e.originalEvent, + [ { label: 'Add a marker', + action: () => { + const pos = e.latlng + const marker = { pos, name: '', color: '#3F92CF', icon: '' } + const colors: string[] = [] + + const add_marker = (name: string, color: string, icon: string) => { + console.log('adding marker…') + // let new_marker = { State.pos = pos; name = name; color = color; icon = icon } in + // let new_state = State.update !state pos new_marker in + // let () = History.push_state '' '' ('#' ^ State.to_url_string new_state) () in + // reload_from_hash state map markers false + } + + // let marker = + // match State.last_added !state with + // | Some m -> { m with pos = pos; name = '' } + // | _ -> { pos = pos; name = ''; color = '#3f92cf'; icon = '' } + // in + // let colors = State.colors !state in + Modal.show(Marker.form( + add_marker, + colors, + marker.name, + marker.color, + marker.icon + )) + } + } + ] + ) + }) + + return map +} diff --git a/src/marker.ts b/src/marker.ts new file mode 100644 index 0000000..67b9649 --- /dev/null +++ b/src/marker.ts @@ -0,0 +1,125 @@ +import { h } from 'lib/h' +import * as Button from 'lib/button' +import * as Form from 'lib/form' +import * as Layout from 'lib/layout' +import * as Modal from 'lib/modal' +import * as FontAwesome from 'lib/fontAwesome' +import * as AutoComplete from 'lib/autoComplete' + +export function form( + onValidate: (name: string, color: string, icon: string) => void, + colors: string[], + name: string, + color: string, + icon: string +): Element { + const onSubmit = () => { + onValidate(name, color, icon) + Modal.hide() + } + const domIcon = h('div', { className: `fa fa-${icon}` }) + return h('div', + {}, + Layout.section( + {}, + h('form', + { className: 'g-MarkerForm', + onsubmit: (e: Event) => { + e.preventDefault() + onSubmit() + } + }, + Layout.section( + {}, + Form.input( + 'g-MarkerForm__Name', + 'Name', + { oninput: (e: Event) => { + if (e.target !== null) { + name = (e.target as HTMLInputElement).value + } + }, + value: name + } + ), + Form.colorInput( + colors, + 'g-MarkerForm__Color', + 'Color', + color, + newColor => color = newColor + ), + h('div', + { className: 'g-Form__Field' }, + h('div', + { className: 'g-Form__Label' }, + h('label', { for: 'g-MarkerForm__IconInput' }, 'Icon') + ), + Layout.line( + { className: 'g-MarkerForm__AutoCompleteAndIcon' }, + AutoComplete.create( + { value: icon, + className: 'g-MarkerForm__AutoComplete' + }, + 'g-MarkerForm__IconInput', + FontAwesome.icons, + icon => h('div', + {}, + h('div', { className: `g-MarkerForm__IconEntry fa fa-${icon}` }), + icon + ), + newIcon => { + icon = newIcon + domIcon.className = `fa fa-${icon}` + }), + h('div', { className: 'g-MarkerForm__Icon' }, domIcon) + ) + ) + ) + ), + Layout.line( + {}, + Button.action({ onclick: () => onSubmit() }, 'Save'), + Button.cancel( + { onclick: () => Modal.hide(), + type: 'button' + }, + 'Cancel' + ) + ) + ) + ) +} + +// let create on_remove on_update colors 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 +// +// (* Context menu *) +// let () = Leaflet.on marker 'contextmenu' (fun event -> +// ContextMenu.show +// (Leaflet.original_event event) +// [| { label = 'Modify' +// ; action = fun _ -> +// Modal.show (form (on_update pos pos) colors init_name init_color init_icon) +// } +// ; { label = 'Remove' +// ; action = fun _ -> on_remove pos +// } +// |]) +// 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 +// +// let () = Leaflet.on marker 'dblclick' (fun _ -> +// Modal.show (form (on_update pos pos) colors init_name init_color init_icon)) in +// +// marker diff --git a/src/types/leaflet.d.ts b/src/types/leaflet.d.ts new file mode 100644 index 0000000..39ddf5a --- /dev/null +++ b/src/types/leaflet.d.ts @@ -0,0 +1,28 @@ +export as namespace L + +export function map(element: string, options?: MapOptions): Map + +export interface MapOptions { + center: number[], + zoom: number, + attributionControl: boolean, +} + +export interface Map { + addLayer: (layer: Layer) => void, + addEventListener: (name: string, fn: (e: MapEvent) => void) => void, +} + +interface MapEvent { + originalEvent: MouseEvent, + latlng: {lat: number, lng: number}, +} + +export interface Pos { + lat: number, + lng: number, +} + +export function tileLayer(url: string): Layer + +export interface Layer {} |