(* BSD-2-Clause License *) type _ t = | Basic : Jv.t -> [> `Basic ] t | Geojson : Jv.t -> [> `Geojson ] t | Marker : Jv.t -> [> `Marker ] t | Tile : Jv.t -> [> `Tile ] t type _ sub = | Basic : [> `Basic ] sub | Geojson : [> `Geojson ] sub | Marker : [> `Marker ] sub | Tile : [> `Tile ] sub (** Basic layers *) 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 : type kind. kind t -> unit = function | Basic l | Geojson l | Marker l | Tile l -> let (_ : Jv.t) = Jv.call l "remove" [||] in () 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 bind_popup : type kind. Popup.t -> kind t -> unit = fun popup -> function | Basic layer | Geojson layer | Marker layer | Tile layer -> let (_ : Jv.t) = Jv.call layer "bindPopup" [| Popup.to_jv popup |] in () 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 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 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 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 : type kind. kind t -> Jv.t = function | Basic l | Geojson l | Marker l | Tile l -> l let of_jv : type kind. kind sub -> Jv.t -> kind t = fun tag l -> match tag with | Basic -> Basic l | Geojson -> Geojson l | Marker -> Marker l | Tile -> Tile l let on : type kind. kind Event.sub -> (kind Event.t -> 'b) -> 'c t -> unit = fun event handler layer -> let name = Event.sub_to_string event in let handler v = handler @@ Event.of_jv event v in let (_ : Jv.t) = Jv.call (to_jv layer) "on" [| Jv.of_string name; Jv.repr handler |] in () (** Geojson layers *) type geojson_opt = | Point_to_layer of (Jv.t -> Latlng.t -> [ `Marker ] t) | Style of (Jv.t -> unit) | On_each_feature of (Jv.t -> [ `Geojson ] t -> unit) | Filter of (Jv.t -> bool) | Coords_to_latlng of (Jv.t -> Latlng.t) | Markers_inherit_options of bool let geojson_opt_to_string = function | Point_to_layer _ -> "pointToLayer" | Style _ -> "style" | On_each_feature _ -> "onEachFeature" | Filter _ -> "filter" | Coords_to_latlng _ -> "coordsToLatLng" | Markers_inherit_options _ -> "markersInheritOptions" let geojson_opt_to_jv = function | Markers_inherit_options b -> Jv.of_bool b | Point_to_layer f -> (* the marker returned by `pointToLayer` is used internally by leaflet so we neet to unwrap it to a Jv.t *) Jv.repr (fun geojsonpoint latlng -> to_jv @@ f geojsonpoint latlng) | Style f -> Jv.repr f | On_each_feature f -> (* we need to wrap the Jv.t *) let f feature jv = jv |> of_jv Geojson |> f feature in Jv.repr f | Filter f -> Jv.repr f | Coords_to_latlng f -> Jv.repr f let create_geojson : Jv.t -> geojson_opt list -> [ `Geojson ] t = fun geojson options -> let l = Array.of_list @@ List.map (fun o -> (geojson_opt_to_string o, geojson_opt_to_jv o)) options in let jv_t = Jv.call Global.leaflet "geoJSON" [| geojson; Jv.obj l |] in Geojson jv_t (** Tile layers *) let create_tile_osm : string option -> [ `Tile ] t = fun url -> 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