From fbfb4037344214e6752dbdde5e168a124d46e265 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sat, 9 Apr 2022 22:21:22 +0200 Subject: [PATCH] use gadts for layer, clean code --- src/dune | 12 +----- src/event.ml | 4 +- src/event.mli | 2 +- src/geojson_layer.ml | 4 -- src/geojson_layer.mli | 23 ----------- src/latlng.ml | 4 +- src/latlng.mli | 4 +- src/layer.ml | 92 +++++++++++++++++++++++++++++++++++++------ src/layer.mli | 38 ++++++++++++------ src/map.ml | 39 ++++++++++-------- src/map.mli | 6 +-- src/marker.ml | 4 -- src/marker.mli | 23 ----------- src/popup.ml | 16 +++++--- src/popup.mli | 2 +- src/tile_layer.ml | 19 --------- src/tile_layer.mli | 23 ----------- 17 files changed, 152 insertions(+), 163 deletions(-) delete mode 100644 src/geojson_layer.ml delete mode 100644 src/geojson_layer.mli delete mode 100644 src/marker.ml delete mode 100644 src/marker.mli delete mode 100644 src/tile_layer.ml delete mode 100644 src/tile_layer.mli diff --git a/src/dune b/src/dune index bce2f76..ed4515f 100644 --- a/src/dune +++ b/src/dune @@ -1,15 +1,7 @@ (library (public_name leaflet) - (modules - event - geojson_layer - global - latlng - layer - map - marker - popup - tile_layer) + (modules event global latlng layer map popup) + (private_modules global) (libraries brr) (js_of_ocaml (javascript_files leaflet.js))) diff --git a/src/event.ml b/src/event.ml index 491f322..6b456d2 100644 --- a/src/event.ml +++ b/src/event.ml @@ -9,7 +9,7 @@ type _ sub = | Move_end : [> `Basic ] sub | Zoom_end : [> `Basic ] sub -let of_jv_t : type kind. kind sub -> Jv.t -> kind t = +let of_jv : type kind. kind sub -> Jv.t -> kind t = fun tag e -> match tag with Click -> Mouse e | Move_end -> Basic e | Zoom_end -> Basic e @@ -48,7 +48,7 @@ let layer_point : [ `Mouse ] t -> Jv.t = function | Mouse e -> Jv.get e "layerPoint" let latlng : [ `Mouse ] t -> Latlng.t = function - | Mouse e -> Jv.get e "latlng" |> Latlng.of_jv_t + | Mouse e -> Jv.get e "latlng" |> Latlng.of_jv (** Error events *) diff --git a/src/event.mli b/src/event.mli index bf4f2d7..9592bfb 100644 --- a/src/event.mli +++ b/src/event.mli @@ -9,7 +9,7 @@ type _ sub = | Move_end : [> `Basic ] sub | Zoom_end : [> `Basic ] sub -val of_jv_t : 'a sub -> Jv.t -> 'a t +val of_jv : 'a sub -> Jv.t -> 'a t val sub_to_string : _ sub -> string diff --git a/src/geojson_layer.ml b/src/geojson_layer.ml deleted file mode 100644 index c5c113d..0000000 --- a/src/geojson_layer.ml +++ /dev/null @@ -1,4 +0,0 @@ -include Layer - -let create ?(options = Jv.null) geojson = - of_jv_t @@ Jv.call Global.leaflet "geoJSON" [| geojson; options |] diff --git a/src/geojson_layer.mli b/src/geojson_layer.mli deleted file mode 100644 index e8c4660..0000000 --- a/src/geojson_layer.mli +++ /dev/null @@ -1,23 +0,0 @@ -type t - -val create : ?options:Jv.t -> Jv.t -> t - -val add_to : Map.t -> t -> unit - -val remove : t -> unit - -val remove_from : Map.t -> t -> unit - -val bind_popup : Brr.El.t -> t -> unit - -val unbind_popup : t -> unit - -val open_popup : t -> unit - -val close_popup : t -> unit - -val get_popup : t -> Popup.t - -val of_jv_t : Jv.t -> t - -val to_jv_t : t -> Jv.t diff --git a/src/latlng.ml b/src/latlng.ml index d2b4dbc..6611746 100644 --- a/src/latlng.ml +++ b/src/latlng.ml @@ -9,6 +9,6 @@ let lng latlng = Jv.get latlng "lng" |> Jv.to_float let equals a b = Jv.call a "equals" [| b |] |> Jv.to_bool -let of_jv_t = Fun.id +let of_jv = Fun.id -let to_jv_t = Fun.id +let to_jv = Fun.id diff --git a/src/latlng.mli b/src/latlng.mli index fb793ae..c63a970 100644 --- a/src/latlng.mli +++ b/src/latlng.mli @@ -8,6 +8,6 @@ val lng : t -> float val equals : t -> t -> bool -val of_jv_t : Jv.t -> t +val of_jv : Jv.t -> t -val to_jv_t : t -> Jv.t +val to_jv : t -> Jv.t diff --git a/src/layer.ml b/src/layer.ml index d0c8b62..fd9b07a 100644 --- a/src/layer.ml +++ b/src/layer.ml @@ -1,23 +1,89 @@ -type t = Jv.t +type _ t = + | Basic : Jv.t -> [> `Basic ] t + | Geojson : Jv.t -> [> `Geojson ] t + | Marker : Jv.t -> [> `Marker ] t + | Tile : Jv.t -> [> `Tile ] t -let add_to map layer = ignore @@ Jv.call layer "addTo" [| Map.to_jv_t map |] +(** Basic layers *) -let remove layer = ignore @@ Jv.call layer "remove" [||] +let add_to : type kind. Map.t -> kind t -> unit = + fun map -> function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "addTo" [| Map.to_jv map |] in + () -let remove_from map layer = - ignore @@ Jv.call layer "removeFrom" [| Map.to_jv_t map |] +let remove : type kind. kind t -> unit = function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "remove" [||] in + () -let bind_popup el layer = - ignore @@ Jv.call layer "bindPopup" [| Brr.El.to_jv el |] +let remove_from : type kind. Map.t -> kind t -> unit = + fun map -> function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "removeFrom" [| Map.to_jv map |] in + () -let unbind_popup layer = ignore @@ Jv.call layer "unbindPopup" [||] +let bind_popup : type kind. Brr.El.t -> kind t -> unit = + fun el -> function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "bindPopup" [| Brr.El.to_jv el |] in + () -let open_popup layer = ignore @@ Jv.call layer "openPopup" [||] +let unbind_popup : type kind. kind t -> unit = function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "unbindPopup" [||] in + () -let close_popup layer = ignore @@ Jv.call layer "closePopup" [||] +let open_popup : type kind. kind t -> unit = function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "openPopup" [||] in + () -let get_popup layer = Popup.of_jv_t @@ Jv.call layer "getPopup" [||] +let close_popup : type kind. kind t -> unit = function + | Basic l | Geojson l | Marker l | Tile l -> + let (_ : Jv.t) = Jv.call l "closePopup" [||] in + () -let of_jv_t = Fun.id +let get_popup : type kind. kind t -> Popup.t = function + | Basic l | Geojson l | Marker l | Tile l -> + Jv.call l "getPopup" [||] |> Popup.of_jv -let to_jv_t = Fun.id +let to_jv : type kind. kind t -> Jv.t = function + | Basic l | Geojson l | Marker l | Tile l -> l + +(** Geojson layers *) + +let create_geojson : ?options:Jv.t -> Jv.t -> [ `Geojson ] t = + fun ?(options = Jv.null) geojson -> + let jv_t = Jv.call Global.leaflet "geoJSON" [| geojson; options |] in + Geojson jv_t + +(** Marker layers *) + +let create_marker : Latlng.t -> [ `Marker ] t = + fun latlng -> + let jv_t = Jv.call Global.leaflet "marker" [| Latlng.to_jv latlng |] in + Marker jv_t + +(** Tile layers *) + +let create_tile_osm : string option -> [ `Tile ] t = + fun url -> + (* see https://wiki.openstreetmap.org/wiki/Tile_servers *) + let url = + Option.value url + ~default:"https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" + in + let jv_t = + Jv.call Global.leaflet "tileLayer" + [| Jv.of_string url + ; Jv.obj + [| ( "attribution" + , Jv.of_string + "© OpenStreetMap \ + contributors" ) + |] + |] + in + Tile jv_t diff --git a/src/layer.mli b/src/layer.mli index 98fe10c..0baf3fd 100644 --- a/src/layer.mli +++ b/src/layer.mli @@ -1,21 +1,37 @@ -type t +type _ t = + | Basic : Jv.t -> [> `Basic ] t + | Geojson : Jv.t -> [> `Geojson ] t + | Marker : Jv.t -> [> `Marker ] t + | Tile : Jv.t -> [> `Tile ] t -val add_to : Map.t -> t -> unit +(** Basic layers *) -val remove : t -> unit +val add_to : Map.t -> _ t -> unit -val remove_from : Map.t -> t -> unit +val remove : _ t -> unit -val bind_popup : Brr.El.t -> t -> unit +val remove_from : Map.t -> _ t -> unit -val unbind_popup : t -> unit +val bind_popup : Brr.El.t -> _ t -> unit -val open_popup : t -> unit +val unbind_popup : _ t -> unit -val close_popup : t -> unit +val open_popup : _ t -> unit -val get_popup : t -> Popup.t +val close_popup : _ t -> unit -val of_jv_t : Jv.t -> t +val get_popup : _ t -> Popup.t -val to_jv_t : t -> Jv.t +val to_jv : _ t -> Jv.t + +(** Geojson layers *) + +val create_geojson : ?options:Jv.t -> Jv.t -> [ `Geojson ] t + +(** Marker layers *) + +val create_marker : Latlng.t -> [ `Marker ] t + +(** Tile layers *) + +val create_tile_osm : string option -> [ `Tile ] t diff --git a/src/map.ml b/src/map.ml index e070351..57598f4 100644 --- a/src/map.ml +++ b/src/map.ml @@ -1,38 +1,43 @@ type t = Jv.t -let of_jv_t = Fun.id +let of_jv = Fun.id -let to_jv_t = Fun.id +let to_jv = Fun.id let create ?(options = Jv.null) container_id = Jv.call Global.leaflet "map" [| Jv.of_string container_id; options |] -let invalidate_size map = ignore @@ Jv.call map "invalidateSize" [| Jv.true' |] +let invalidate_size map = + let (_ : Jv.t) = Jv.call map "invalidateSize" [| Jv.true' |] in + () -let fit_world map = ignore @@ Jv.call map "fitWorld" [||] +let fit_world map = + let (_ : Jv.t) = Jv.call map "fitWorld" [||] in + () -let get_container map = - Jv.call (to_jv_t map) "getContainer" [||] |> Brr.El.of_jv +let get_container map = Jv.call (to_jv map) "getContainer" [||] |> Brr.El.of_jv -let set_view latlng ?zoom map = - let latlng = Latlng.to_jv_t latlng in - ignore - @@ - match zoom with - | None -> Jv.call map "setView" [| latlng |] - | Some zoom -> Jv.call map "setView" [| latlng; Jv.of_int zoom |] +let set_view latlng ~zoom map = + let latlng = Latlng.to_jv latlng in + let (_ : Jv.t) = + match zoom with + | None -> Jv.call map "setView" [| latlng |] + | Some zoom -> Jv.call map "setView" [| latlng; Jv.of_int zoom |] + in + () let as_target map = Brr.Ev.target_of_jv map let on : type kind. kind Event.sub -> (kind Event.t -> 'b) -> t -> unit = fun event handler map -> let name = Event.sub_to_string event in - let handler v = handler @@ Event.of_jv_t event v in - ignore @@ Jv.call map "on" [| Jv.of_string name; Jv.repr handler |] + let handler v = handler @@ Event.of_jv event v in + let (_ : Jv.t) = Jv.call map "on" [| Jv.of_string name; Jv.repr handler |] in + () -let get_center map = Latlng.of_jv_t @@ Jv.call map "getCenter" [||] +let get_center map = Latlng.of_jv @@ Jv.call map "getCenter" [||] let get_zoom map = Jv.call map "getZoom" [||] |> Jv.to_int let wrapped_latlng latlng map = - Latlng.of_jv_t @@ Jv.call map "wrapLatLng" [| Latlng.to_jv_t latlng |] + Latlng.of_jv @@ Jv.call map "wrapLatLng" [| Latlng.to_jv latlng |] diff --git a/src/map.mli b/src/map.mli index fdbd710..f4f6f2b 100644 --- a/src/map.mli +++ b/src/map.mli @@ -4,7 +4,7 @@ val create : ?options:Jv.t -> string -> t val invalidate_size : t -> unit -val set_view : Latlng.t -> ?zoom:int -> t -> unit +val set_view : Latlng.t -> zoom:int option -> t -> unit val fit_world : t -> unit @@ -20,6 +20,6 @@ val wrapped_latlng : Latlng.t -> t -> Latlng.t val as_target : t -> Brr.Ev.target -val of_jv_t : Jv.t -> t +val of_jv : Jv.t -> t -val to_jv_t : t -> Jv.t +val to_jv : t -> Jv.t diff --git a/src/marker.ml b/src/marker.ml deleted file mode 100644 index 44925a1..0000000 --- a/src/marker.ml +++ /dev/null @@ -1,4 +0,0 @@ -include Layer - -let create latlng = - of_jv_t @@ Jv.call Global.leaflet "marker" [| Latlng.to_jv_t latlng |] diff --git a/src/marker.mli b/src/marker.mli deleted file mode 100644 index ab77fc5..0000000 --- a/src/marker.mli +++ /dev/null @@ -1,23 +0,0 @@ -type t - -val create : Latlng.t -> t - -val add_to : Map.t -> t -> unit - -val remove : t -> unit - -val remove_from : Map.t -> t -> unit - -val bind_popup : Brr.El.t -> t -> unit - -val unbind_popup : t -> unit - -val open_popup : t -> unit - -val close_popup : t -> unit - -val get_popup : t -> Popup.t - -val of_jv_t : Jv.t -> t - -val to_jv_t : t -> Jv.t diff --git a/src/popup.ml b/src/popup.ml index bc0febf..fb0264c 100644 --- a/src/popup.ml +++ b/src/popup.ml @@ -3,13 +3,19 @@ type t = Jv.t let popup = Jv.call Global.leaflet "popup" [||] let set_latlng latlng = - ignore @@ Jv.call popup "setLatLng" [| Latlng.to_jv_t latlng |] + let (_ : Jv.t) = Jv.call popup "setLatLng" [| Latlng.to_jv latlng |] in + () let set_content content = - ignore @@ Jv.call popup "setContent" [| Jv.of_string content |] + let (_ : Jv.t) = Jv.call popup "setContent" [| Jv.of_string content |] in + () -let open_on map = ignore @@ Jv.call popup "openOn" [| Map.to_jv_t map |] +let open_on map = + let (_ : Jv.t) = Jv.call popup "openOn" [| Map.to_jv map |] in + () -let close map = ignore @@ Jv.call (Map.to_jv_t map) "closePopup" [||] +let close map = + let (_ : Jv.t) = Jv.call (Map.to_jv map) "closePopup" [||] in + () -let of_jv_t = Fun.id +let of_jv = Fun.id diff --git a/src/popup.mli b/src/popup.mli index 5ca939b..65e5dfc 100644 --- a/src/popup.mli +++ b/src/popup.mli @@ -8,4 +8,4 @@ val open_on : Map.t -> unit val close : Map.t -> unit -val of_jv_t : Jv.t -> t +val of_jv : Jv.t -> t diff --git a/src/tile_layer.ml b/src/tile_layer.ml deleted file mode 100644 index 1dae48c..0000000 --- a/src/tile_layer.ml +++ /dev/null @@ -1,19 +0,0 @@ -include Layer - -let create_osm ?tile_url () = - (* see https://wiki.openstreetmap.org/wiki/Tile_servers *) - let tile_url = - Option.fold ~some:Fun.id - ~none:"https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" tile_url - in - of_jv_t - @@ Jv.call Global.leaflet "tileLayer" - [| Jv.of_string tile_url - ; Jv.obj - [| ( "attribution" - , Jv.of_string - "© OpenStreetMap \ - contributors" ) - |] - |] diff --git a/src/tile_layer.mli b/src/tile_layer.mli deleted file mode 100644 index b1834b5..0000000 --- a/src/tile_layer.mli +++ /dev/null @@ -1,23 +0,0 @@ -type t - -val create_osm : ?tile_url:string -> unit -> t - -val add_to : Map.t -> t -> unit - -val remove : t -> unit - -val remove_from : Map.t -> t -> unit - -val bind_popup : Brr.El.t -> t -> unit - -val unbind_popup : t -> unit - -val open_popup : t -> unit - -val close_popup : t -> unit - -val get_popup : t -> Popup.t - -val of_jv_t : Jv.t -> t - -val to_jv_t : t -> Jv.t