From f4ab3e17ad5732a5589e17ad5c0991ab14164902 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Fri, 8 Apr 2022 22:43:31 +0200 Subject: [PATCH] use gadts for event, clean repo --- src/dune | 14 +++++++-- src/ev.ml | 31 -------------------- src/ev.mli | 66 ------------------------------------------ src/event.ml | 59 +++++++++++++++++++++++++++++++++++++ src/event.mli | 42 +++++++++++++++++++++++++++ src/leaflet.js.license | 3 -- src/map.ml | 18 ++++-------- src/map.mli | 11 +------ 8 files changed, 118 insertions(+), 126 deletions(-) delete mode 100644 src/ev.ml delete mode 100644 src/ev.mli create mode 100644 src/event.ml create mode 100644 src/event.mli delete mode 100644 src/leaflet.js.license diff --git a/src/dune b/src/dune index 8f28969..bce2f76 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,15 @@ (library - (name leaflet) (public_name leaflet) - (modules ev latlng geojson_layer tile_layer popup marker map global layer) - (libraries brr js_of_ocaml) + (modules + event + geojson_layer + global + latlng + layer + map + marker + popup + tile_layer) + (libraries brr) (js_of_ocaml (javascript_files leaflet.js))) diff --git a/src/ev.ml b/src/ev.ml deleted file mode 100644 index 7823351..0000000 --- a/src/ev.ml +++ /dev/null @@ -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 () diff --git a/src/ev.mli b/src/ev.mli deleted file mode 100644 index 520b5ff..0000000 --- a/src/ev.mli +++ /dev/null @@ -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 diff --git a/src/event.ml b/src/event.ml new file mode 100644 index 0000000..491f322 --- /dev/null +++ b/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 diff --git a/src/event.mli b/src/event.mli new file mode 100644 index 0000000..bf4f2d7 --- /dev/null +++ b/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 diff --git a/src/leaflet.js.license b/src/leaflet.js.license deleted file mode 100644 index 8f54aad..0000000 --- a/src/leaflet.js.license +++ /dev/null @@ -1,3 +0,0 @@ -SPDX-FileCopyrightText: 2010-2021 Vladimir Agafonkin - -SPDX-License-Identifier: BSD-2-Clause \ No newline at end of file diff --git a/src/map.ml b/src/map.ml index 3efedd7..e070351 100644 --- a/src/map.ml +++ b/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 name = Brr.Ev.Type.name event |> Jv.of_jstr in - ignore @@ Jv.call map "on" [| name; Jv.repr handler |] +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 get_center map = Latlng.of_jv_t @@ Jv.call map "getCenter" [||] diff --git a/src/map.mli b/src/map.mli index c373001..fdbd710 100644 --- a/src/map.mli +++ b/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