leaflet/src/layer.ml

(* 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
                  "&copy; <a \
                   href=\"https://www.openstreetmap.org/copyright\">OpenStreetMap</a> \
                   contributors" )
           |]
      |]
  in
  Tile jv_t