use gadts for event, clean repo

src/dune

@@ -1,7 +1,15 @@
 (library
- (name leaflet)
  (public_name leaflet)
- (modules ev latlng geojson_layer tile_layer popup marker map global layer)
+ (modules
- (libraries brr js_of_ocaml)
+  event
+  geojson_layer
+  global
+  latlng
+  layer
+  map
+  marker
+  popup
+  tile_layer)
+ (libraries brr)
  (js_of_ocaml
   (javascript_files leaflet.js)))

src/ev.ml

@@ -1,31 +0,0 @@
-module Make () = struct
-  type t = Jv.t
-
-  let type' e = Jv.get e "type" |> Jv.to_string
-
-  let target e = Jv.get e "target" |> Brr.Ev.target_of_jv
-
-  let source_target e = Jv.get e "sourceTarget" |> Brr.Ev.target_of_jv
-
-  let propagated_from e = Jv.get e "propagatedFrom"
-
-  let latlng e = Latlng.of_jv_t @@ Jv.get e "latlng"
-
-  let layer_point e = Jv.get e "layerPoint"
-
-  let container_point e = Jv.get e "containerPoint"
-
-  let original_event e = Jv.get e "originalEvent"
-
-  let message e = Jv.get e "message" |> Jv.to_string
-
-  let code e = Jv.get e "code" |> Jv.to_int
-end
-
-module Event = Make ()
-
-module Keyboard = Make ()
-
-module Mouse = Make ()
-
-module Error = Make ()

src/ev.mli

@@ -1,66 +0,0 @@
-module Event : sig
-  type t
-
-  val type' : t -> string
-
-  val target : t -> Brr.Ev.target
-
-  val source_target : t -> Brr.Ev.target
-
-  (* TODO this should return Point *)
-  val propagated_from : t -> Jv.t
-end
-
-module Keyboard : sig
-  type t
-
-  val type' : t -> string
-
-  val target : t -> Brr.Ev.target
-
-  val source_target : t -> Brr.Ev.target
-
-  val propagated_from : t -> Jv.t
-
-  (* TODO this should return BrrDomEvent*)
-  val original_event : t -> Jv.t
-end
-
-module Mouse : sig
-  type t
-
-  val type' : t -> string
-
-  val target : t -> Brr.Ev.target
-
-  val source_target : t -> Brr.Ev.target
-
-  val propagated_from : t -> Jv.t
-
-  val latlng : t -> Latlng.t
-
-  (* TODO this should return Point *)
-  val layer_point : t -> Jv.t
-
-  (* TODO this should return Point *)
-  val container_point : t -> Jv.t
-
-  (* TODO this should return BrrDomEvent*)
-  val original_event : t -> Jv.t
-end
-
-module Error : sig
-  type t
-
-  val type' : t -> string
-
-  val target : t -> Brr.Ev.target
-
-  val source_target : t -> Brr.Ev.target
-
-  val propagated_from : t -> Jv.t
-
-  val message : t -> string
-
-  val code : t -> int
-end

src/event.ml

@@ -0,0 +1,59 @@
+type _ t =
+  | Keyboard : Jv.t -> [> `Keyboard ] t
+  | Mouse : Jv.t -> [> `Mouse ] t
+  | Error : Jv.t -> [> `Error ] t
+  | Basic : Jv.t -> [> `Basic ] t
+
+type _ sub =
+  | Click : [> `Mouse ] sub
+  | Move_end : [> `Basic ] sub
+  | Zoom_end : [> `Basic ] sub
+
+let of_jv_t : 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
+
+let sub_to_string : type kind. kind sub -> string = function
+  | Click -> "click"
+  | Move_end -> "moveend"
+  | Zoom_end -> "zoomend"
+
+(** Basic events *)
+
+let get_type : type kind. kind t -> string = function
+  | Keyboard e | Mouse e | Error e | Basic e -> Jv.get e "type" |> Jv.to_string
+
+let target : type kind. kind t -> Brr.Ev.target = function
+  | Keyboard e | Mouse e | Error e | Basic e ->
+    Jv.get e "target" |> Brr.Ev.target_of_jv
+
+let source_target : type kind. kind t -> Brr.Ev.target = function
+  | Keyboard e | Mouse e | Error e | Basic e ->
+    Jv.get e "sourceTarget" |> Brr.Ev.target_of_jv
+
+let propagated_from : type kind. kind t -> Jv.t = function
+  | Keyboard e | Mouse e | Error e | Basic e -> Jv.get e "propagatedFrom"
+
+(** Keyboard & Mouse events *)
+
+let original_event : [ `Keyboard | `Mouse ] t -> Jv.t = function
+  | Keyboard e | Mouse e -> Jv.get e "originalEvent"
+
+(** Mouse events *)
+
+let container_point : [ `Mouse ] t -> Jv.t = function
+  | Mouse e -> Jv.get e "containerPoint"
+
+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
+
+(** Error events *)
+
+let code : [ `Error ] t -> int = function
+  | Error e -> Jv.get e "code" |> Jv.to_int
+
+let message : [ `Error ] t -> string = function
+  | Error e -> Jv.get e "message" |> Jv.to_string

src/event.mli

@@ -0,0 +1,42 @@
+type _ t =
+  | Keyboard : Jv.t -> [> `Keyboard ] t
+  | Mouse : Jv.t -> [> `Mouse ] t
+  | Error : Jv.t -> [> `Error ] t
+  | Basic : Jv.t -> [> `Basic ] t
+
+type _ sub =
+  | Click : [> `Mouse ] sub
+  | Move_end : [> `Basic ] sub
+  | Zoom_end : [> `Basic ] sub
+
+val of_jv_t : 'a sub -> Jv.t -> 'a t
+
+val sub_to_string : _ sub -> string
+
+(** Basic events *)
+
+val get_type : _ t -> string
+
+val target : _ t -> Brr.Ev.target
+
+val source_target : _ t -> Brr.Ev.target
+
+val propagated_from : _ t -> Jv.t
+
+(** Keyboard & Mouse events *)
+
+val original_event : [ `Keyboard | `Mouse ] t -> Jv.t
+
+(** Mouse events *)
+
+val container_point : [ `Mouse ] t -> Jv.t
+
+val layer_point : [ `Mouse ] t -> Jv.t
+
+val latlng : [ `Mouse ] t -> Latlng.t
+
+(** Error events *)
+
+val code : [ `Error ] t -> int
+
+val message : [ `Error ] t -> string

src/leaflet.js.license

@@ -1,3 +0,0 @@
-SPDX-FileCopyrightText: 2010-2021 Vladimir Agafonkin
-
-SPDX-License-Identifier: BSD-2-Clause

src/map.ml

@@ -1,15 +1,5 @@
 type t = Jv.t
 
-module Event = struct
-  let to_brr s = s |> Jstr.v |> Brr.Ev.Type.create
-
-  let click = to_brr "click"
-
-  let moveend = to_brr "moveend"
-
-  let zoomend = to_brr "zoomend"
-end
-
 let of_jv_t = Fun.id
 
 let to_jv_t = Fun.id
@@ -34,9 +24,11 @@ let set_view latlng ?zoom map =
 
 let as_target map = Brr.Ev.target_of_jv map
 
-let on ~event ~handler map =
+let on : type kind. kind Event.sub -> (kind Event.t -> 'b) -> t -> unit =
-  let name = Brr.Ev.Type.name event |> Jv.of_jstr in
+ fun event handler map ->
-  ignore @@ Jv.call map "on" [| name; Jv.repr handler |]
+  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 get_center map = Latlng.of_jv_t @@ Jv.call map "getCenter" [||]
 

src/map.mli

@@ -1,14 +1,5 @@
 type t
 
-module Event : sig
-  (* TODO do this need to be wrapped in Brr.Ev.type' ?*)
-  val click : Ev.Mouse.t Brr.Ev.type'
-
-  val moveend : Ev.Event.t Brr.Ev.type'
-
-  val zoomend : Ev.Event.t Brr.Ev.type'
-end
-
 val create : ?options:Jv.t -> string -> t
 
 val invalidate_size : t -> unit
@@ -19,7 +10,7 @@ val fit_world : t -> unit
 
 val get_container : t -> Brr.El.t
 
-val on : event:'a Brr.Ev.type' -> handler:('a -> 'b) -> t -> unit
+val on : 'a Event.sub -> ('a Event.t -> 'b) -> t -> unit
 
 val get_center : t -> Latlng.t