From 063d8ef9eaf874a941f4459e831057dd0a1b7ddd Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 5 Jul 2022 21:55:41 +0200 Subject: Rewrite in TS --- src/View/Button.ml | 19 ------ src/View/Form.ml | 65 --------------------- src/View/Form/Autocomplete.ml | 80 -------------------------- src/View/Layout.ml | 9 --- src/View/Map.ml | 131 ------------------------------------------ src/View/Map/Icon.ml | 32 ----------- src/View/Map/Marker.ml | 105 --------------------------------- 7 files changed, 441 deletions(-) delete mode 100644 src/View/Button.ml delete mode 100644 src/View/Form.ml delete mode 100644 src/View/Form/Autocomplete.ml delete mode 100644 src/View/Layout.ml delete mode 100644 src/View/Map.ml delete mode 100644 src/View/Map/Icon.ml delete mode 100644 src/View/Map/Marker.ml (limited to 'src/View') 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 -- cgit v1.2.3