From 6d6e75f9f1289d5631499ff62018325fe7bf14d5 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 13 Dec 2020 11:47:44 +0000 Subject: [PATCH 001/109] Adding role to xdg_shell_surface --- lib/wlroots.mli | 1 + lib/xdg_shell.ml | 7 +++++++ types/types.ml | 17 +++++++++++++++++ 3 files changed, 25 insertions(+) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 7a39660..ded566f 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -223,6 +223,7 @@ module Xdg_shell : sig module Surface : sig include Comparable0 + val role : Xdg_shell.Surface.t -> Xdg_shell.Surface.role_t end val create : Wl.Display.t -> t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 8a27ede..3a657ed 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -7,7 +7,13 @@ module Types = Wlroots_ffi_f.Ffi.Types module Surface = struct type t = Types.Xdg_surface.t ptr let t = ptr Types.Xdg_surface.t + + type role_t = Types.Xdg_surface_role.role ptr + let role_t = ptr Types.Xdg_surface_role.t + include Ptr + + let role (surface : t) = surface |-> Types.Xdg_surface.role end type t = Types.Xdg_shell.t ptr @@ -20,3 +26,4 @@ let signal_new_surface (shell : t) : Surface.t Wl.Signal.t = { c = shell |-> Types.Xdg_shell.events_new_surface; typ = Surface.t; } + diff --git a/types/types.ml b/types/types.ml index 680b39e..4eef751 100644 --- a/types/types.ml +++ b/types/types.ml @@ -285,10 +285,27 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Xdg_surface_role = struct + (* The type of these may be compiler dependent *) + let none = constant "WLR_XDG_SURFACE_ROLE_NONE" int64_t + let top_level = constant "WLR_XDG_SURFACE_ROLE_TOPLEVEL" int64_t + let popup = constant "WLR_XDG_SURFACE_ROLE_POPUP" int64_t + + type role = None | TopLevel | Popup + + type t = [`xdg_surface_role] Ctypes.structure + let t : role typ = enum "wlr_xdg_surface_role" [ + None, none; + TopLevel, top_level; + Popup, popup; + ] + end + module Xdg_surface = struct type t = [`xdg_surface] Ctypes.structure let t : t typ = structure "wlr_xdg_surface" + let role = field t "role" Xdg_surface_role.t let () = seal t end From 87af175e973ef1b0226d4d3b5ef2fefb27926314 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 27 Dec 2020 14:20:25 +0000 Subject: [PATCH 002/109] Adding surface events --- lib/wlroots.mli | 11 +++++++++++ lib/xdg_shell.ml | 37 +++++++++++++++++++++++++++++++++++++ types/types.ml | 8 ++++++++ 3 files changed, 56 insertions(+) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index ded566f..5f77da3 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -224,6 +224,17 @@ module Xdg_shell : sig module Surface : sig include Comparable0 val role : Xdg_shell.Surface.t -> Xdg_shell.Surface.role_t + + module Events : sig + val destroy : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val ping_timeout : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val new_popup : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val map : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val unmap : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val configure : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val ack_configure : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + + end end val create : Wl.Display.t -> t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 3a657ed..ab91ceb 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -14,6 +14,43 @@ module Surface = struct include Ptr let role (surface : t) = surface |-> Types.Xdg_surface.role + + module Events = struct + let destroy (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_destroy; + typ = t; + } + + let ping_timeout (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_ping_timeout; + typ = t; + } + + let new_popup (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_new_popup; + typ = t; + } + + let map (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_map; + typ = t; + } + + let unmap (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_unmap; + typ = t; + } + + let configure (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_configure; + typ = t; + } + + let ack_configure (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_ack_configure; + typ = t; + } + end end type t = Types.Xdg_shell.t ptr diff --git a/types/types.ml b/types/types.ml index 4eef751..1b0c4cc 100644 --- a/types/types.ml +++ b/types/types.ml @@ -306,6 +306,14 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_xdg_surface" let role = field t "role" Xdg_surface_role.t + + let events_destroy = field t "events.destroy" Wl_signal.t + let events_ping_timeout = field t "events.ping_timeout" Wl_signal.t + let events_new_popup = field t "events.new_popup" Wl_signal.t + let events_map = field t "events.map" Wl_signal.t + let events_unmap = field t "events.unmap" Wl_signal.t + let events_configure = field t "events.configure" Wl_signal.t + let events_ack_configure = field t "events.ack_configure" Wl_signal.t let () = seal t end From e11ecb5dfdb7bf41c889d95763cb6d06da85afd5 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 27 Dec 2020 16:09:14 +0000 Subject: [PATCH 003/109] Work in progress filling out TinyWL --- tinywl/tinywl.ml | 49 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 39 insertions(+), 10 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index ef98f18..55fe23f 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,7 +1,11 @@ open Wlroots +open Ctypes + +type view = { + surface : Xdg_shell.Surface.t; + listener: Wl.Listener.t; +} -type view - type tinywl_output = { output : Output.t; @@ -43,26 +47,51 @@ let server_new_output st _ output = Output.create_global output; end -let server_new_xdg_surface _st _ _ = - failwith "todo" +let server_new_xdg_surface st _listener surf = + + let role = Xdg_shell.Surface.role surf in + begin match (!@ role) with + | None -> print_endline "Got None" + | TopLevel -> print_endline "Got TopLevel" + | Popup -> print_endline "Got Popup" + end; + + let view_listener = Wl.Listener.create () in + + let view = { + surface = surf; + listener = view_listener; + } in + + st.views <- view :: st.views; + + (* Start here *) + (* We want to add the signal handlers for the surface events using Wl.Signal.add *) + Wl.Signal.add (Xdg_shell.Surface.Events.destroy surf) view_listener + (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); + + (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) + (* (server_new_xdg_surface st); *) + + () let server_cursor_motion _st _ _ = - failwith "todo" + failwith "server_cursor_motion" let server_cursor_motion_absolute _st _ _ = - failwith "todo" + failwith "server_cursor_motion_absolute" let server_cursor_button _st _ _ = - failwith "todo" + failwith "server_cursor_button" let server_cursor_axis _st _ _ = - failwith "todo" + failwith "server_cursor_axis" let server_cursor_frame _st _ _ = - failwith "todo" + failwith "server_cursor_frame" let server_new_keyboard _st (_keyboard: Keyboard.t) = - failwith "todo" + failwith "server_new_keyboard" let server_new_pointer st (pointer: Input_device.t) = Cursor.attach_input_device st.cursor pointer From 1d16d8fdce282de3937ed9c1f20a3712a9ec8f46 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 3 Jan 2021 12:24:49 -0800 Subject: [PATCH 004/109] wlroots: Refer to implicit t in xdg_shell.surface sig. --- lib/wlroots.mli | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 5f77da3..866d6ba 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -223,16 +223,16 @@ module Xdg_shell : sig module Surface : sig include Comparable0 - val role : Xdg_shell.Surface.t -> Xdg_shell.Surface.role_t + val role : t -> Xdg_shell.Surface.role_t module Events : sig - val destroy : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val ping_timeout : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val new_popup : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val map : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val unmap : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val configure : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t - val ack_configure : Xdg_shell.Surface.t -> Xdg_shell.Surface.t Wl.Signal.t + val destroy : t -> t Wl.Signal.t + val ping_timeout : t -> t Wl.Signal.t + val new_popup : t -> t Wl.Signal.t + val map : t -> t Wl.Signal.t + val unmap : t -> t Wl.Signal.t + val configure : t -> t Wl.Signal.t + val ack_configure : t -> t Wl.Signal.t end end From f726517fb571f40079b3d14a8d18fc6c7991bf7a Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 3 Jan 2021 14:10:07 -0800 Subject: [PATCH 005/109] Remove CTypes from tinywl. * Get back pure ocaml type from Xdg_shell.Surface.role. --- lib/wlroots.mli | 3 ++- lib/xdg_shell.ml | 6 +++--- tinywl/tinywl.ml | 7 ++----- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 866d6ba..2dc9e3e 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -223,7 +223,8 @@ module Xdg_shell : sig module Surface : sig include Comparable0 - val role : t -> Xdg_shell.Surface.role_t + type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role + val role : t -> role module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index ab91ceb..014c53c 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -8,12 +8,12 @@ module Surface = struct type t = Types.Xdg_surface.t ptr let t = ptr Types.Xdg_surface.t - type role_t = Types.Xdg_surface_role.role ptr - let role_t = ptr Types.Xdg_surface_role.t + type role = Types.Xdg_surface_role.role include Ptr - let role (surface : t) = surface |-> Types.Xdg_surface.role + let role (surface : t) : role = + surface |->> Types.Xdg_surface.role module Events = struct let destroy (surface : t) : t Wl.Signal.t = { diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 55fe23f..fd26c0e 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,5 +1,4 @@ open Wlroots -open Ctypes type view = { surface : Xdg_shell.Surface.t; @@ -47,10 +46,8 @@ let server_new_output st _ output = Output.create_global output; end -let server_new_xdg_surface st _listener surf = - - let role = Xdg_shell.Surface.role surf in - begin match (!@ role) with +let server_new_xdg_surface st _listener (surf : Xdg_shell.Surface.t) = + begin match Xdg_shell.Surface.role surf with | None -> print_endline "Got None" | TopLevel -> print_endline "Got TopLevel" | Popup -> print_endline "Got Popup" From 192592484263416bfe21c9f58f7b8e8e744fb8fb Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 3 Jan 2021 17:36:49 -0800 Subject: [PATCH 006/109] Add keyboard_state field to Seat. --- lib/seat.ml | 10 ++++++++++ lib/wlroots.mli | 7 +++++++ types/types.ml | 10 ++++++++++ 3 files changed, 27 insertions(+) diff --git a/lib/seat.ml b/lib/seat.ml index f7eb320..e57233e 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -37,7 +37,17 @@ module Pointer_state = struct st |->> Types.Seat_pointer_state.focused_client end +module Keyboard_state = struct + type t = Types.Seat_keyboard_state.t ptr + let t = ptr Types.Seat_keyboard_state.t + include Ptr + + let focused_surface (st : t) = + st |->> Types.Seat_keyboard_state.focused_surface +end + let pointer_state seat = seat |-> Types.Seat.pointer_state +let keyboard_state seat = seat |-> Types.Seat.keyboard_state let create = Bindings.wlr_seat_create diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 2dc9e3e..c53e482 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -277,6 +277,12 @@ module Seat : sig val focused_client : t -> Client.t end + module Keyboard_state : sig + include Comparable0 + + val focused_surface : t -> Surface.t + end + module Pointer_request_set_cursor_event : sig include Comparable0 @@ -287,6 +293,7 @@ module Seat : sig end val pointer_state : t -> Pointer_state.t + val keyboard_state : t -> Keyboard_state.t val create : Wl.Display.t -> string -> t val signal_request_set_cursor : diff --git a/types/types.ml b/types/types.ml index 1b0c4cc..222dd35 100644 --- a/types/types.ml +++ b/types/types.ml @@ -358,6 +358,14 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Seat_keyboard_state = struct + type t = [`seat_keyboard_state] Ctypes.structure + let t : t typ = structure "wlr_seat_keyboard_state" + let focused_surface = field t "focused_surface" + (ptr Surface.t) + let () = seal t + end + module Seat = struct type t = [`seat] Ctypes.structure let t : t typ = structure "wlr_seat" @@ -366,6 +374,8 @@ module Make (S : Cstubs_structs.TYPE) = struct field t "events.request_set_cursor" Wl_signal.t let pointer_state = field t "pointer_state" Seat_pointer_state.t + let keyboard_state = + field t "keyboard_state" Seat_keyboard_state.t let () = seal t end From 0d8e5d4dfadcb529c97b0fe25ff539afb66bac94 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 3 Jan 2021 18:43:05 -0800 Subject: [PATCH 007/109] Rename Xdg_shell.Surface -> Xdg_shell.Xdg_surface. --- lib/wlroots.mli | 4 ++-- lib/xdg_shell.ml | 7 +++---- tinywl/tinywl.ml | 8 ++++---- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c53e482..c6a0c16 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -221,7 +221,7 @@ end module Xdg_shell : sig include Comparable0 - module Surface : sig + module Xdg_surface : sig include Comparable0 type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role val role : t -> role @@ -239,7 +239,7 @@ module Xdg_shell : sig end val create : Wl.Display.t -> t - val signal_new_surface : t -> Surface.t Wl.Signal.t + val signal_new_surface : t -> Xdg_surface.t Wl.Signal.t end module Cursor : sig diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 014c53c..5d72ca5 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -4,7 +4,7 @@ open Wlroots_common.Utils module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) module Types = Wlroots_ffi_f.Ffi.Types -module Surface = struct +module Xdg_surface = struct type t = Types.Xdg_surface.t ptr let t = ptr Types.Xdg_surface.t @@ -59,8 +59,7 @@ include Ptr let create = Bindings.wlr_xdg_shell_create -let signal_new_surface (shell : t) : Surface.t Wl.Signal.t = { +let signal_new_surface (shell : t) : Xdg_surface.t Wl.Signal.t = { c = shell |-> Types.Xdg_shell.events_new_surface; - typ = Surface.t; + typ = Xdg_surface.t; } - diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index fd26c0e..6546e63 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,7 +1,7 @@ open Wlroots type view = { - surface : Xdg_shell.Surface.t; + surface : Xdg_shell.Xdg_surface.t; listener: Wl.Listener.t; } @@ -46,8 +46,8 @@ let server_new_output st _ output = Output.create_global output; end -let server_new_xdg_surface st _listener (surf : Xdg_shell.Surface.t) = - begin match Xdg_shell.Surface.role surf with +let server_new_xdg_surface st _listener (surf : Xdg_shell.Xdg_surface.t) = + begin match Xdg_shell.Xdg_surface.role surf with | None -> print_endline "Got None" | TopLevel -> print_endline "Got TopLevel" | Popup -> print_endline "Got Popup" @@ -64,7 +64,7 @@ let server_new_xdg_surface st _listener (surf : Xdg_shell.Surface.t) = (* Start here *) (* We want to add the signal handlers for the surface events using Wl.Signal.add *) - Wl.Signal.add (Xdg_shell.Surface.Events.destroy surf) view_listener + Wl.Signal.add (Xdg_shell.Xdg_surface.Events.destroy surf) view_listener (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) From c9a39be0ad6253c8e1c440c729a540176eb9be69 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 3 Jan 2021 18:49:29 -0800 Subject: [PATCH 008/109] Add surface field to Xdg_surface. --- lib/wlroots.mli | 2 ++ lib/xdg_shell.ml | 2 ++ types/types.ml | 1 + 3 files changed, 5 insertions(+) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c6a0c16..27cdf1a 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -224,7 +224,9 @@ module Xdg_shell : sig module Xdg_surface : sig include Comparable0 type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role + val role : t -> role + val surface : t -> Surface.t module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 5d72ca5..8269611 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -14,6 +14,8 @@ module Xdg_surface = struct let role (surface : t) : role = surface |->> Types.Xdg_surface.role + let surface (surface : t) : Surface.t = + surface |-> Types.Xdg_surface.surface module Events = struct let destroy (surface : t) : t Wl.Signal.t = { diff --git a/types/types.ml b/types/types.ml index 222dd35..08c53d3 100644 --- a/types/types.ml +++ b/types/types.ml @@ -306,6 +306,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_xdg_surface" let role = field t "role" Xdg_surface_role.t + let surface = field t "surface" Surface.t let events_destroy = field t "events.destroy" Wl_signal.t let events_ping_timeout = field t "events.ping_timeout" Wl_signal.t From 01d322234c48a06629e2a1e9748acc39632dea9f Mon Sep 17 00:00:00 2001 From: John Soo Date: Mon, 4 Jan 2021 10:31:27 -0800 Subject: [PATCH 009/109] Seat: Return option for focused_surface. --- lib/seat.ml | 5 ++++- lib/wlroots.mli | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/seat.ml b/lib/seat.ml index e57233e..6b61a50 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -43,7 +43,10 @@ module Keyboard_state = struct include Ptr let focused_surface (st : t) = - st |->> Types.Seat_keyboard_state.focused_surface + let surf = st |-> Types.Seat_keyboard_state.focused_surface in + if is_null surf + then None + else Some (!@ surf) end let pointer_state seat = seat |-> Types.Seat.pointer_state diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 27cdf1a..648bf79 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -282,7 +282,7 @@ module Seat : sig module Keyboard_state : sig include Comparable0 - val focused_surface : t -> Surface.t + val focused_surface : t -> Surface.t option end module Pointer_request_set_cursor_event : sig From 0770122b93dbcba67cd5e17b37c5a0f6c3815c28 Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 6 Jan 2021 11:16:40 -0800 Subject: [PATCH 010/109] xdg_surface: Add from_surface. * Corresponds to wlr_xdg_surface_from_surface in xdg_shell. --- ffi/ffi.ml | 10 ++++++++++ lib/wlroots.mli | 2 ++ lib/xdg_shell.ml | 9 +++++++++ 3 files changed, 21 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 4e3c681..a93c399 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -229,6 +229,16 @@ struct let wlr_xdg_shell_create = foreign "wlr_xdg_shell_create" (wl_display_p @-> returning wlr_xdg_shell_p) + (* wlr_xdg_surface *) + + let wlr_xdg_surface_p = ptr Xdg_surface.t + + let wlr_surface_is_xdg_surface = foreign "wlr_surface_is_xdg_surface" + (wlr_surface_p @-> returning bool) + + let wlr_xdg_surface_from_wlr_surface = foreign "wlr_xdg_surface_from_wlr_surface" + (wlr_surface_p @-> returning wlr_xdg_surface_p) + (* wlr_input_device *) let wlr_input_device_p = ptr Input_device.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 648bf79..7b3d545 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -228,6 +228,8 @@ module Xdg_shell : sig val role : t -> role val surface : t -> Surface.t + val from_surface : Surface.t -> t option + module Events : sig val destroy : t -> t Wl.Signal.t val ping_timeout : t -> t Wl.Signal.t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 8269611..4be81df 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -17,6 +17,15 @@ module Xdg_surface = struct let surface (surface : t) : Surface.t = surface |-> Types.Xdg_surface.surface + let from_surface (surface : Surface.t) : t option = + (* This is not exactly a verbatim binding but it is safer *) + (* Worth it? *) + if Bindings.wlr_surface_is_xdg_surface surface + then + (* assert is called so this might blow up *) + Some (Bindings.wlr_xdg_surface_from_wlr_surface surface) + else None + module Events = struct let destroy (surface : t) : t Wl.Signal.t = { c = surface |-> Types.Xdg_surface.events_destroy; From aa7c61beccc4320839f99af106fa42a5034aea90 Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 6 Jan 2021 11:27:40 -0800 Subject: [PATCH 011/109] xdg_surface: Move into separate directory. --- lib/dune | 4 +-- lib/wlroots.ml | 1 + lib/wlroots.mli | 34 ++++++++++++------------- lib/xdg_shell.ml | 60 ------------------------------------------- lib/xdg_surface.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++++ tinywl/tinywl.ml | 8 +++--- 6 files changed, 87 insertions(+), 83 deletions(-) create mode 100644 lib/xdg_surface.ml diff --git a/lib/dune b/lib/dune index 9b028b8..fe5b558 100644 --- a/lib/dune +++ b/lib/dune @@ -16,8 +16,8 @@ generated_ffi wl log texture surface box matrix output keyboard pointer touch tablet_tool tablet_pad input_device - backend renderer data_device compositor xdg_shell cursor - xcursor_manager seat output_layout) + backend renderer data_device compositor xdg_shell xdg_surface + cursor xcursor_manager seat output_layout) (c_names generated_ffi_stubs) (c_flags (:standard -Werror -pedantic -Wall -Wunused -DWLR_USE_UNSTABLE -O0) -w (:include ../config/wlroots-ccopt.sexp) diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 50312c0..526d75e 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -5,6 +5,7 @@ module Seat = Seat module Xcursor_manager = Xcursor_manager module Cursor = Cursor module Xdg_shell = Xdg_shell +module Xdg_surface = Xdg_surface module Compositor = Compositor module Data_device = Data_device module Backend = Backend diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 7b3d545..0b34b64 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -218,29 +218,29 @@ module Compositor : sig val create : Wl.Display.t -> Renderer.t -> t end -module Xdg_shell : sig +module Xdg_surface : sig include Comparable0 + type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role - module Xdg_surface : sig - include Comparable0 - type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role - - val role : t -> role - val surface : t -> Surface.t + val role : t -> role + val surface : t -> Surface.t - val from_surface : Surface.t -> t option + val from_surface : Surface.t -> t option - module Events : sig - val destroy : t -> t Wl.Signal.t - val ping_timeout : t -> t Wl.Signal.t - val new_popup : t -> t Wl.Signal.t - val map : t -> t Wl.Signal.t - val unmap : t -> t Wl.Signal.t - val configure : t -> t Wl.Signal.t - val ack_configure : t -> t Wl.Signal.t + module Events : sig + val destroy : t -> t Wl.Signal.t + val ping_timeout : t -> t Wl.Signal.t + val new_popup : t -> t Wl.Signal.t + val map : t -> t Wl.Signal.t + val unmap : t -> t Wl.Signal.t + val configure : t -> t Wl.Signal.t + val ack_configure : t -> t Wl.Signal.t - end end +end + +module Xdg_shell : sig + include Comparable0 val create : Wl.Display.t -> t val signal_new_surface : t -> Xdg_surface.t Wl.Signal.t diff --git a/lib/xdg_shell.ml b/lib/xdg_shell.ml index 4be81df..8327e56 100644 --- a/lib/xdg_shell.ml +++ b/lib/xdg_shell.ml @@ -4,66 +4,6 @@ open Wlroots_common.Utils module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) module Types = Wlroots_ffi_f.Ffi.Types -module Xdg_surface = struct - type t = Types.Xdg_surface.t ptr - let t = ptr Types.Xdg_surface.t - - type role = Types.Xdg_surface_role.role - - include Ptr - - let role (surface : t) : role = - surface |->> Types.Xdg_surface.role - let surface (surface : t) : Surface.t = - surface |-> Types.Xdg_surface.surface - - let from_surface (surface : Surface.t) : t option = - (* This is not exactly a verbatim binding but it is safer *) - (* Worth it? *) - if Bindings.wlr_surface_is_xdg_surface surface - then - (* assert is called so this might blow up *) - Some (Bindings.wlr_xdg_surface_from_wlr_surface surface) - else None - - module Events = struct - let destroy (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_destroy; - typ = t; - } - - let ping_timeout (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_ping_timeout; - typ = t; - } - - let new_popup (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_new_popup; - typ = t; - } - - let map (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_map; - typ = t; - } - - let unmap (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_unmap; - typ = t; - } - - let configure (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_configure; - typ = t; - } - - let ack_configure (surface : t) : t Wl.Signal.t = { - c = surface |-> Types.Xdg_surface.events_ack_configure; - typ = t; - } - end -end - type t = Types.Xdg_shell.t ptr let t = ptr Types.Xdg_shell.t include Ptr diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml new file mode 100644 index 0000000..d26d8cd --- /dev/null +++ b/lib/xdg_surface.ml @@ -0,0 +1,63 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Xdg_surface.t ptr +let t = ptr Types.Xdg_surface.t + +type role = Types.Xdg_surface_role.role + +include Ptr + +let role (surface : t) : role = + surface |->> Types.Xdg_surface.role +let surface (surface : t) : Surface.t = + surface |-> Types.Xdg_surface.surface + +let from_surface (surface : Surface.t) : t option = + (* This is not exactly a verbatim binding but it is safer *) + (* Worth it? *) + if Bindings.wlr_surface_is_xdg_surface surface + then + (* assert is called so this might blow up *) + Some (Bindings.wlr_xdg_surface_from_wlr_surface surface) + else None + +module Events = struct + let destroy (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_destroy; + typ = t; + } + + let ping_timeout (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_ping_timeout; + typ = t; + } + + let new_popup (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_new_popup; + typ = t; + } + + let map (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_map; + typ = t; + } + + let unmap (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_unmap; + typ = t; + } + + let configure (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_configure; + typ = t; + } + + let ack_configure (surface : t) : t Wl.Signal.t = { + c = surface |-> Types.Xdg_surface.events_ack_configure; + typ = t; + } +end diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 6546e63..28194ff 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,7 +1,7 @@ open Wlroots type view = { - surface : Xdg_shell.Xdg_surface.t; + surface : Xdg_surface.t; listener: Wl.Listener.t; } @@ -46,8 +46,8 @@ let server_new_output st _ output = Output.create_global output; end -let server_new_xdg_surface st _listener (surf : Xdg_shell.Xdg_surface.t) = - begin match Xdg_shell.Xdg_surface.role surf with +let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = + begin match Xdg_surface.role surf with | None -> print_endline "Got None" | TopLevel -> print_endline "Got TopLevel" | Popup -> print_endline "Got Popup" @@ -64,7 +64,7 @@ let server_new_xdg_surface st _listener (surf : Xdg_shell.Xdg_surface.t) = (* Start here *) (* We want to add the signal handlers for the surface events using Wl.Signal.add *) - Wl.Signal.add (Xdg_shell.Xdg_surface.Events.destroy surf) view_listener + Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) From 3ac5ce5e8d260aa12004be154bc98fcba489544d Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 6 Jan 2021 15:53:21 -0800 Subject: [PATCH 012/109] wlr_xdg_toplevel: Add wlr_xdg_toplevel_set_activated. --- ffi/ffi.ml | 5 +++++ lib/wlroots.mli | 1 + lib/xdg_surface.ml | 3 +++ 3 files changed, 9 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index a93c399..3c7f49f 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -239,6 +239,11 @@ struct let wlr_xdg_surface_from_wlr_surface = foreign "wlr_xdg_surface_from_wlr_surface" (wlr_surface_p @-> returning wlr_xdg_surface_p) + (* wlr_xdg_toplevel *) + + let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated" + (wlr_xdg_surface_p @-> bool @-> returning uint32_t) + (* wlr_input_device *) let wlr_input_device_p = ptr Input_device.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 0b34b64..350b412 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -226,6 +226,7 @@ module Xdg_surface : sig val surface : t -> Surface.t val from_surface : Surface.t -> t option + val toplevel_set_activated : t -> bool -> Unsigned.uint32 module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index d26d8cd..1b26f76 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -25,6 +25,9 @@ let from_surface (surface : Surface.t) : t option = Some (Bindings.wlr_xdg_surface_from_wlr_surface surface) else None +let toplevel_set_activated = + Bindings.wlr_xdg_toplevel_set_activated + module Events = struct let destroy (surface : t) : t Wl.Signal.t = { c = surface |-> Types.Xdg_surface.events_destroy; From b2bdb00b8c5f69faa50059982c3f831e4fffd8aa Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 6 Jan 2021 15:54:06 -0800 Subject: [PATCH 013/109] [WIP] tinywl: Set previous surface to deactivated on xdg_surface.mapped. --- tinywl/tinywl.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 28194ff..8278e2a 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -46,6 +46,21 @@ let server_new_output st _ output = Output.create_global output; end +let focus_view st _listener surf = + let seat = Seat.keyboard_state st.seat in + let prev_surface = Seat.Keyboard_state.focused_surface seat in + let to_deactivate = + Option.bind prev_surface (fun prev -> + if prev == Xdg_surface.surface surf + then None + else Xdg_surface.from_surface prev + ) + in + Option.iter (fun s -> + let _ = Xdg_surface.toplevel_set_activated s false in ()) + to_deactivate; + () + let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = begin match Xdg_surface.role surf with | None -> print_endline "Got None" @@ -67,6 +82,8 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); + Wl.Signal.add (Xdg_surface.Events.map surf) view_listener + (focus_view st); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) From 5e1e2dc5c378a58f369c7ba87bd5a457dcb4e0e2 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 10 Jan 2021 10:05:32 -0800 Subject: [PATCH 014/109] Add keyboard, modifiers struct and keyboard, modifiers fields. Needed to do keyboard_notify_enter. --- ffi/ffi.ml | 2 ++ lib/keyboard_modifiers.ml | 8 ++++++++ lib/seat.ml | 2 ++ lib/wlroots.mli | 1 + types/types.ml | 8 ++++++++ 5 files changed, 21 insertions(+) create mode 100644 lib/keyboard_modifiers.ml diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 3c7f49f..121b2b5 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -192,6 +192,8 @@ struct let wlr_keyboard_set_keymap = foreign "wlr_keyboard_set_keymap" (wlr_keyboard_p @-> Xkbcommon.Keymap.t @-> returning bool) + let wlr_keyboard_modifiers_p = ptr Keyboard_modifiers.t + (* wlr_backend *) let wlr_backend_p = ptr Backend.t diff --git a/lib/keyboard_modifiers.ml b/lib/keyboard_modifiers.ml new file mode 100644 index 0000000..9a2b14c --- /dev/null +++ b/lib/keyboard_modifiers.ml @@ -0,0 +1,8 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Keyboard_modifiers.t ptr +include Ptr diff --git a/lib/seat.ml b/lib/seat.ml index 6b61a50..e61a270 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -42,6 +42,8 @@ module Keyboard_state = struct let t = ptr Types.Seat_keyboard_state.t include Ptr + let keyboard = getfield Types.Seat_keyboard_state.keyboard + let focused_surface (st : t) = let surf = st |-> Types.Seat_keyboard_state.focused_surface in if is_null surf diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 350b412..168ee7c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -285,6 +285,7 @@ module Seat : sig module Keyboard_state : sig include Comparable0 + val keyboard : t -> Keyboard.t val focused_surface : t -> Surface.t option end diff --git a/types/types.ml b/types/types.ml index 08c53d3..b591b6c 100644 --- a/types/types.ml +++ b/types/types.ml @@ -144,11 +144,18 @@ module Make (S : Cstubs_structs.TYPE) = struct let state = field t "state" Key_state.t end + module Keyboard_modifiers = struct + type t = [`keyboard_modifier] Ctypes.structure + let t : t typ = structure "wlr_keyboard_modifiers" + let () = seal t + end + module Keyboard = struct type t = [`keyboard] Ctypes.structure let t : t typ = structure "wlr_keyboard" let xkb_state = field t "xkb_state" (lift_typ Xkbcommon.State.t) + let modifiers = field t "modifiers" Keyboard_modifiers.t let events_key = field t "events.key" Wl_signal.t let () = seal t end @@ -364,6 +371,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_seat_keyboard_state" let focused_surface = field t "focused_surface" (ptr Surface.t) + let keyboard = field t "keyboard" (ptr Keyboard.t) let () = seal t end From 321482c1a62b7cc94e1a64881cad1fb6e63e913a Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 10 Jan 2021 10:08:46 -0800 Subject: [PATCH 015/109] [WIP] tinywl: Notify keyboard enter in focus_view. --- tinywl/tinywl.ml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 8278e2a..b547e9f 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -46,9 +46,9 @@ let server_new_output st _ output = Output.create_global output; end -let focus_view st _listener surf = - let seat = Seat.keyboard_state st.seat in - let prev_surface = Seat.Keyboard_state.focused_surface seat in +let focus_view st view _listener surf = + let keyboard_state = Seat.keyboard_state st.seat in + let prev_surface = Seat.Keyboard_state.focused_surface keyboard_state in let to_deactivate = Option.bind prev_surface (fun prev -> if prev == Xdg_surface.surface surf @@ -56,10 +56,13 @@ let focus_view st _listener surf = else Xdg_surface.from_surface prev ) in - Option.iter (fun s -> - let _ = Xdg_surface.toplevel_set_activated s false in ()) + let discard _ = () in + Option.iter (fun s -> discard (Xdg_surface.toplevel_set_activated s false)) to_deactivate; - () + let keyboard = Seat.Keyboard_state.keyboard keyboard_state in + st.views <- view :: List.filter ((!=) view) st.views; + discard (Xdg_surface.toplevel_set_activated surf true); + Seat.keyboard_notify_enter let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = begin match Xdg_surface.role surf with @@ -83,7 +86,7 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (focus_view st); + (focus_view st view); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) From a5f7978dc8e09ee813b4c93a029a5d00302335e0 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 14:58:37 +0000 Subject: [PATCH 016/109] Fixed type of modifiers field --- types/types.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/types/types.ml b/types/types.ml index b591b6c..83a3fdf 100644 --- a/types/types.ml +++ b/types/types.ml @@ -155,7 +155,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_keyboard" let xkb_state = field t "xkb_state" (lift_typ Xkbcommon.State.t) - let modifiers = field t "modifiers" Keyboard_modifiers.t + let modifiers = field t "modifiers" (ptr Keyboard_modifiers.t) let events_key = field t "events.key" Wl_signal.t let () = seal t end From ddb0f28e11f3509335357db0c3c7dea5cb3c9bb0 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 15:01:43 +0000 Subject: [PATCH 017/109] Expose the Keyboard_modifiers module. --- lib/dune | 1 + lib/wlroots.ml | 1 + lib/wlroots.mli | 4 ++++ 3 files changed, 6 insertions(+) diff --git a/lib/dune b/lib/dune index fe5b558..8dcc5f4 100644 --- a/lib/dune +++ b/lib/dune @@ -16,6 +16,7 @@ generated_ffi wl log texture surface box matrix output keyboard pointer touch tablet_tool tablet_pad input_device + keyboard_modifiers backend renderer data_device compositor xdg_shell xdg_surface cursor xcursor_manager seat output_layout) (c_names generated_ffi_stubs) diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 526d75e..c25a8e3 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -12,6 +12,7 @@ module Backend = Backend module Output = Output module Input_device = Input_device module Keyboard = Keyboard +module Keyboard_modifiers = Keyboard_modifiers module Pointer = Pointer module Touch = Touch module Tablet_tool = Tablet_tool diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 168ee7c..892bab9 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -112,6 +112,10 @@ module Output_layout : sig val add_auto : t -> Output.t -> unit end +module Keyboard_modifiers : sig + include Comparable0 +end + module Keyboard : sig include Comparable0 From b72fc83b3dfdaefe51229a1cb61c0c7de7ed9e46 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 15:04:42 +0000 Subject: [PATCH 018/109] Add the Keycodes type and module. Keycodes is not in Wlroots, but CTypes does not support abstract arrays. So we're using this as a wrapper with a void*. --- lib/dune | 1 + lib/keycodes.ml | 7 +++++++ lib/wlroots.ml | 1 + lib/wlroots.mli | 4 ++++ types/types.ml | 6 ++++++ 5 files changed, 19 insertions(+) create mode 100644 lib/keycodes.ml diff --git a/lib/dune b/lib/dune index 8dcc5f4..3739373 100644 --- a/lib/dune +++ b/lib/dune @@ -17,6 +17,7 @@ wl log texture surface box matrix output keyboard pointer touch tablet_tool tablet_pad input_device keyboard_modifiers + keycodes backend renderer data_device compositor xdg_shell xdg_surface cursor xcursor_manager seat output_layout) (c_names generated_ffi_stubs) diff --git a/lib/keycodes.ml b/lib/keycodes.ml new file mode 100644 index 0000000..659486b --- /dev/null +++ b/lib/keycodes.ml @@ -0,0 +1,7 @@ +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Keycodes.t +include Ptr diff --git a/lib/wlroots.ml b/lib/wlroots.ml index c25a8e3..89b815f 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -13,6 +13,7 @@ module Output = Output module Input_device = Input_device module Keyboard = Keyboard module Keyboard_modifiers = Keyboard_modifiers +module Keycodes = Keycodes module Pointer = Pointer module Touch = Touch module Tablet_tool = Tablet_tool diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 892bab9..ecf586a 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -112,6 +112,10 @@ module Output_layout : sig val add_auto : t -> Output.t -> unit end +module Keycodes : sig + include Comparable0 +end + module Keyboard_modifiers : sig include Comparable0 end diff --git a/types/types.ml b/types/types.ml index 83a3fdf..78f146d 100644 --- a/types/types.ml +++ b/types/types.ml @@ -135,6 +135,12 @@ module Make (S : Cstubs_structs.TYPE) = struct ] end + (* This is an array of unit32_t keycodes: uint32_t keycodes[] *) + module Keycodes = struct + type t = unit ptr + let t : t typ = ptr void + end + module Event_keyboard_key = struct type t = [`event_keyboard_key] Ctypes.structure let t : t typ = structure "wlr_event_keyboard_key" From ed6953dd64f2f77445983a49377883ec0c97f4eb Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 15:09:06 +0000 Subject: [PATCH 019/109] Format Wlroots modules on new lines for better commits. --- lib/dune | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/lib/dune b/lib/dune index 3739373..1e8f873 100644 --- a/lib/dune +++ b/lib/dune @@ -14,12 +14,31 @@ (public_name wlroots) (modules wlroots generated_ffi - wl log texture surface box matrix output - keyboard pointer touch tablet_tool tablet_pad input_device + wl + log + texture + surface + box + matrix + output + keyboard + pointer + touch + tablet_tool + tablet_pad + input_device keyboard_modifiers keycodes - backend renderer data_device compositor xdg_shell xdg_surface - cursor xcursor_manager seat output_layout) + backend + renderer + data_device + compositor + xdg_shell + xdg_surface + cursor + xcursor_manager + seat + output_layout) (c_names generated_ffi_stubs) (c_flags (:standard -Werror -pedantic -Wall -Wunused -DWLR_USE_UNSTABLE -O0) -w (:include ../config/wlroots-ccopt.sexp) From eff3a34bae4c4baf608ed7338b7d018fbda5bb6e Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 15:10:37 +0000 Subject: [PATCH 020/109] Add Keycodes, Num_keycodes, and Modifier fields to Keyboard. --- lib/keyboard.ml | 4 ++++ lib/wlroots.mli | 3 +++ types/types.ml | 2 ++ 3 files changed, 9 insertions(+) diff --git a/lib/keyboard.ml b/lib/keyboard.ml index 67f33b5..b204453 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -21,6 +21,10 @@ end let xkb_state = getfield Types.Keyboard.xkb_state +let modifiers = getfield Types.Keyboard.modifiers +let keycodes = getfield Types.Keyboard.keycodes +let num_keycodes = getfield Types.Keyboard.num_keycodes + let signal_key (keyboard : t) : Event_key.t Wl.Signal.t = { c = keyboard |-> Types.Keyboard.events_key; typ = ptr Types.Event_keyboard_key.t; diff --git a/lib/wlroots.mli b/lib/wlroots.mli index ecf586a..9a4b968 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -135,6 +135,9 @@ module Keyboard : sig end val xkb_state : t -> Xkbcommon.State.t + val modifiers : t -> Keyboard_modifiers.t + val keycodes : t -> Keycodes.t + val num_keycodes : t -> Unsigned.size_t val signal_key : t -> Event_key.t Wl.Signal.t val set_keymap : t -> Xkbcommon.Keymap.t -> bool end diff --git a/types/types.ml b/types/types.ml index 78f146d..a8ad279 100644 --- a/types/types.ml +++ b/types/types.ml @@ -163,6 +163,8 @@ module Make (S : Cstubs_structs.TYPE) = struct let xkb_state = field t "xkb_state" (lift_typ Xkbcommon.State.t) let modifiers = field t "modifiers" (ptr Keyboard_modifiers.t) let events_key = field t "events.key" Wl_signal.t + let keycodes = field t "keycodes" Keycodes.t + let num_keycodes = field t "num_keycodes" size_t let () = seal t end From f228aa08ed89b847d82179fbfc756afa1d27d37b Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 10 Jan 2021 10:08:02 -0800 Subject: [PATCH 021/109] Add keyboard_notify_enter. This is to finish focus_view in tinywl. --- ffi/ffi.ml | 8 ++++++++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 13 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 121b2b5..c7e16f9 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -289,6 +289,14 @@ struct let wlr_seat_set_capabilities = foreign "wlr_seat_set_capabilities" (wlr_seat_p @-> Wl_seat_capability.t @-> returning void) + let wlr_seat_keyboard_notify_enter = foreign "wlr_seat_keyboard_notify_enter" + (wlr_seat_p + @-> wlr_surface_p + @-> Keycodes.t + @-> size_t + @-> wlr_keyboard_modifiers_p + @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index e61a270..6886056 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -64,3 +64,6 @@ let signal_request_set_cursor (seat: t) : _ Wl.Signal.t = { let set_capabilities seat caps = Bindings.wlr_seat_set_capabilities seat (coerce Wl.Seat_capability.t uint64_t caps) + +let keyboard_notify_enter = + Bindings.wlr_seat_keyboard_notify_enter diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 9a4b968..de8e0a1 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -316,6 +316,8 @@ module Seat : sig val signal_request_set_cursor : t -> Pointer_request_set_cursor_event.t Wl.Signal.t val set_capabilities : t -> Wl.Seat_capability.t -> unit + val keyboard_notify_enter : + t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard_modifiers.t -> unit end module Log : sig From 97752b3a5d5e3aa9114694cd908a9d91b8b57799 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 15:12:43 +0000 Subject: [PATCH 022/109] tinywl: Finish focus_view. --- tinywl/tinywl.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index b547e9f..99e0fee 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -63,6 +63,11 @@ let focus_view st view _listener surf = st.views <- view :: List.filter ((!=) view) st.views; discard (Xdg_surface.toplevel_set_activated surf true); Seat.keyboard_notify_enter + st.seat + (Xdg_surface.surface surf) + (Keyboard.keycodes keyboard) + (Keyboard.num_keycodes keyboard) + (Keyboard.modifiers keyboard) let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = begin match Xdg_surface.role surf with From 51e477009749edaa7c3d9a8602c07d1c2bab8c00 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 19:08:06 +0000 Subject: [PATCH 023/109] Add mapped property to view. --- tinywl/tinywl.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 99e0fee..fcbe314 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -3,6 +3,7 @@ open Wlroots type view = { surface : Xdg_surface.t; listener: Wl.Listener.t; + mapped: bool; } type tinywl_output = { From 7063ea64b761d693361dd10c8f24ed59ba3d0fee Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 19:09:25 +0000 Subject: [PATCH 024/109] Make view a ref. We need to mutate this value after it's held, so we need to make it into a ref. --- tinywl/tinywl.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index fcbe314..786dbfe 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -79,20 +79,20 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = let view_listener = Wl.Listener.create () in - let view = { + let view = ref { surface = surf; listener = view_listener; + mapped = false; } in - st.views <- view :: st.views; + st.views <- !view :: st.views; - (* Start here *) (* We want to add the signal handlers for the surface events using Wl.Signal.add *) Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener - (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); + (fun _ _ -> st.views <- List.filter (fun item -> not (item == !view)) st.views;); Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (focus_view st view); + (focus_view st !view); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) From 0477c1a09a20ce0414514ba9d2fc893c03fbb2d1 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 10 Jan 2021 19:10:20 +0000 Subject: [PATCH 025/109] Add unmap callback. --- tinywl/tinywl.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 786dbfe..563b00b 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -93,6 +93,12 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = Wl.Signal.add (Xdg_surface.Events.map surf) view_listener (focus_view st !view); + Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener + (fun _ _ -> view := { + surface = surf; + listener = view_listener; + mapped = false; + }); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) From 2a17b405e8b904f46aa8342ae4346e00f28e9853 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 24 Jan 2021 16:32:41 +0000 Subject: [PATCH 026/109] xdg_toplevel: Creates types, interfaces, and events Needed for move and resize events in tinywl. --- lib/dune | 1 + lib/wlroots.ml | 1 + lib/wlroots.mli | 10 ++++++++++ lib/xdg_surface.ml | 2 ++ lib/xdg_toplevel.ml | 22 ++++++++++++++++++++++ types/types.ml | 11 +++++++++++ 6 files changed, 47 insertions(+) create mode 100644 lib/xdg_toplevel.ml diff --git a/lib/dune b/lib/dune index 1e8f873..b32a356 100644 --- a/lib/dune +++ b/lib/dune @@ -35,6 +35,7 @@ compositor xdg_shell xdg_surface + xdg_toplevel cursor xcursor_manager seat diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 89b815f..0b587c2 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -6,6 +6,7 @@ module Xcursor_manager = Xcursor_manager module Cursor = Cursor module Xdg_shell = Xdg_shell module Xdg_surface = Xdg_surface +module Xdg_toplevel = Xdg_toplevel module Compositor = Compositor module Data_device = Data_device module Backend = Backend diff --git a/lib/wlroots.mli b/lib/wlroots.mli index de8e0a1..c950ab5 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -229,12 +229,22 @@ module Compositor : sig val create : Wl.Display.t -> Renderer.t -> t end +module Xdg_toplevel: sig + include Comparable0 + + module Events: sig + val request_move : t -> t Wl.Signal.t + val request_resize : t -> t Wl.Signal.t + end +end + module Xdg_surface : sig include Comparable0 type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role val role : t -> role val surface : t -> Surface.t + val toplevel : t -> Xdg_toplevel.t val from_surface : Surface.t -> t option val toplevel_set_activated : t -> bool -> Unsigned.uint32 diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 1b26f76..7473df0 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -15,6 +15,8 @@ let role (surface : t) : role = surface |->> Types.Xdg_surface.role let surface (surface : t) : Surface.t = surface |-> Types.Xdg_surface.surface +let toplevel (surface : t) : Xdg_toplevel.t = + surface |-> Types.Xdg_surface.toplevel let from_surface (surface : Surface.t) : t option = (* This is not exactly a verbatim binding but it is safer *) diff --git a/lib/xdg_toplevel.ml b/lib/xdg_toplevel.ml new file mode 100644 index 0000000..a091a25 --- /dev/null +++ b/lib/xdg_toplevel.ml @@ -0,0 +1,22 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Xdg_toplevel.t ptr +let t = ptr Types.Xdg_toplevel.t + +include Ptr + +module Events = struct + let request_move (toplevel : t) : t Wl.Signal.t = { + c = toplevel |-> Types.Xdg_toplevel.events_request_move; + typ = t; + } + + let request_resize (toplevel : t) : t Wl.Signal.t = { + c = toplevel |-> Types.Xdg_toplevel.events_request_resize; + typ = t; + } +end diff --git a/types/types.ml b/types/types.ml index a8ad279..01fd6ef 100644 --- a/types/types.ml +++ b/types/types.ml @@ -316,12 +316,23 @@ module Make (S : Cstubs_structs.TYPE) = struct ] end + module Xdg_toplevel = struct + type t = [`xdg_toplevel] Ctypes.structure + let t : t typ = structure "wlr_xdg_toplevel" + + let events_request_move = field t "events.request_move" Wl_signal.t + let events_request_resize = field t "events.request_resize" Wl_signal.t + + let () = seal t + end + module Xdg_surface = struct type t = [`xdg_surface] Ctypes.structure let t : t typ = structure "wlr_xdg_surface" let role = field t "role" Xdg_surface_role.t let surface = field t "surface" Surface.t + let toplevel = field t "toplevel" Xdg_toplevel.t let events_destroy = field t "events.destroy" Wl_signal.t let events_ping_timeout = field t "events.ping_timeout" Wl_signal.t From 1a4089ab05f42dbff7a9631eecc9ce87cd023eff Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 24 Jan 2021 16:37:25 +0000 Subject: [PATCH 027/109] view:mutability Change from a ref to mutable on mapped. Don't need to make the entire thing a ref. Just make the specific field we are concerned with mutable. --- tinywl/tinywl.ml | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 563b00b..7a4b537 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -3,7 +3,7 @@ open Wlroots type view = { surface : Xdg_surface.t; listener: Wl.Listener.t; - mapped: bool; + mutable mapped: bool; } type tinywl_output = { @@ -79,26 +79,22 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = let view_listener = Wl.Listener.create () in - let view = ref { + let view = { surface = surf; listener = view_listener; mapped = false; } in - st.views <- !view :: st.views; + st.views <- view :: st.views; (* We want to add the signal handlers for the surface events using Wl.Signal.add *) Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener - (fun _ _ -> st.views <- List.filter (fun item -> not (item == !view)) st.views;); + (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (focus_view st !view); + (focus_view st view) ; Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener - (fun _ _ -> view := { - surface = surf; - listener = view_listener; - mapped = false; - }); + (fun _ _ -> view.mapped <- false;); (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) From 9f49b2ec6f60ff0ca2c3c4e3f1ba2f50a235c35b Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 24 Jan 2021 16:38:59 +0000 Subject: [PATCH 028/109] tinywl: Stub out begin interactive. Need to handle the interactive events (moving or resizing a winodw). Need a new data type for the what the cursor is trying to do. --- tinywl/tinywl.ml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 7a4b537..b068eb1 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -26,6 +26,10 @@ type tinywl_server = { new_output : Wl.Listener.t; } +type cursor_mode = Passthrough + | Move + | Resize of Unsigned.uint32 + let output_frame _st _ _ = failwith "todo" @@ -47,6 +51,9 @@ let server_new_output st _ output = Output.create_global output; end +let begin_interactive _st (_view: view) (_mode: cursor_mode) = + print_endline "Begin interactive" + let focus_view st view _listener surf = let keyboard_state = Seat.keyboard_state st.seat in let prev_surface = Seat.Keyboard_state.focused_surface keyboard_state in @@ -98,6 +105,14 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) (* (server_new_xdg_surface st); *) + (* cotd *) + let toplevel = Xdg_surface.toplevel surf in + + Wl.Signal.add (Xdg_toplevel.Events.request_move toplevel) view_listener + (fun _ _ -> begin_interactive st view Move); + Wl.Signal.add (Xdg_toplevel.Events.request_resize toplevel) view_listener + (* FIXME: Need to actually get the edges from the event to pass with Resize *) + (fun _ _ -> begin_interactive st view (Resize (Unsigned.UInt32.of_int 0))); () let server_cursor_motion _st _ _ = From b8194afbfe692abb33cf6717265bca638a20d777 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 24 Jan 2021 16:44:28 +0000 Subject: [PATCH 029/109] tinywl:new_xdg_surface Comment about making mapped true. Might never be set to true. Do we need to handle this? --- tinywl/tinywl.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index b068eb1..68ed2d8 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -98,6 +98,7 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); + (* Might need to make mapped true in this guy *) Wl.Signal.add (Xdg_surface.Events.map surf) view_listener (focus_view st view) ; Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener From b4503e19accc40e76020629c7aae958247bcb45e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 24 Jan 2021 14:40:57 -0800 Subject: [PATCH 030/109] tinywl: Begin implementation of server_new_keyboard. --- tinywl/tinywl.ml | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 68ed2d8..f64a75e 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,4 +1,5 @@ open Wlroots +open Xkbcommon type view = { surface : Xdg_surface.t; @@ -6,6 +7,11 @@ type view = { mutable mapped: bool; } +type keyboard = { + device: Keyboard.t; + listener: Wl.Listener.t; +} + type tinywl_output = { output : Output.t; @@ -21,7 +27,7 @@ type tinywl_server = { cursor : Cursor.t; mutable outputs : tinywl_output list; mutable views : view list; - mutable keyboards : Keyboard.t list; + mutable keyboards : keyboard list; new_output : Wl.Listener.t; } @@ -30,6 +36,14 @@ type cursor_mode = Passthrough | Move | Resize of Unsigned.uint32 +let default_xkb_rules : Xkbcommon.Rule_names.t = { + rules = None; + model = None; + layout = None; + variant = None; + options = None; +} + let output_frame _st _ _ = failwith "todo" @@ -131,8 +145,17 @@ let server_cursor_axis _st _ _ = let server_cursor_frame _st _ _ = failwith "server_cursor_frame" -let server_new_keyboard _st (_keyboard: Keyboard.t) = - failwith "server_new_keyboard" +let server_new_keyboard st (keyboard: Keyboard.t) = + let listener = Wl.Listener.create () in + let tinywl_keyboard = { + device = keyboard; + listener = listener; + } in + let keymap = Xkbcommon.Keymap.new_from_names + (Xkbcommon.Context.create [] ()) + default_xkb_rules + in + () let server_new_pointer st (pointer: Input_device.t) = Cursor.attach_input_device st.cursor pointer From 883195b62a5dc442d5f2b7db9999146970880ee7 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 14 Feb 2021 12:51:59 -0800 Subject: [PATCH 031/109] tinywl: Set repeat info in server_new_keyboard. --- ffi/ffi.ml | 3 +++ lib/keyboard.ml | 6 ++++++ lib/wlroots.mli | 1 + tinywl/tinywl.ml | 20 ++++++++++++++++---- 4 files changed, 26 insertions(+), 4 deletions(-) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index c7e16f9..16bb4c6 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -194,6 +194,9 @@ struct let wlr_keyboard_modifiers_p = ptr Keyboard_modifiers.t + let wlr_keyboard_set_repeat_info = foreign "wlr_keyboard_set_repeat_info" + (wlr_keyboard_p @-> int32_t @-> int32_t @-> returning void) + (* wlr_backend *) let wlr_backend_p = ptr Backend.t diff --git a/lib/keyboard.ml b/lib/keyboard.ml index b204453..b1aca10 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -31,3 +31,9 @@ let signal_key (keyboard : t) : Event_key.t Wl.Signal.t = { } let set_keymap = Bindings.wlr_keyboard_set_keymap + +let set_repeat_info keyboard rate delay = + Bindings.wlr_keyboard_set_repeat_info + keyboard + (Signed.Int32.of_int rate) + (Signed.Int32.of_int delay) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c950ab5..d9f0580 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -140,6 +140,7 @@ module Keyboard : sig val num_keycodes : t -> Unsigned.size_t val signal_key : t -> Event_key.t Wl.Signal.t val set_keymap : t -> Xkbcommon.Keymap.t -> bool + val set_repeat_info : t -> int -> int -> unit end module Pointer : sig diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index f64a75e..141953a 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -1,5 +1,4 @@ open Wlroots -open Xkbcommon type view = { surface : Xdg_surface.t; @@ -151,10 +150,23 @@ let server_new_keyboard st (keyboard: Keyboard.t) = device = keyboard; listener = listener; } in - let keymap = Xkbcommon.Keymap.new_from_names - (Xkbcommon.Context.create [] ()) - default_xkb_rules + let xkb_context = match Xkbcommon.Context.create () with + | Some ctx -> ctx + | None -> failwith "Xkbcommon.Context.create" in + let keymap = match Xkbcommon.Keymap.new_from_names xkb_context default_xkb_rules with + | Some m -> m + | None -> failwith "Xkbcommon.Keymap.new_from_names" + in + let _ = Keyboard.set_keymap keyboard keymap in + (* Is this for some reference counting stuff?????? *) + let _ = Xkbcommon.Keymap.unref keymap in + let _ = Xkbcommon.Context.unref xkb_context in + let _ = Keyboard.set_repeat_info keyboard 25 6000 in + + (* TODO: insert our event handlers *) + + st.keyboards <- tinywl_keyboard :: st.keyboards; () let server_new_pointer st (pointer: Input_device.t) = From 7a5efa2fd9b3a348ee86ed8c7896b9a4186e845e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 11:06:26 -0800 Subject: [PATCH 032/109] keyboard: Add modifiers event, create Events module. --- lib/keyboard.ml | 17 ++++++++++++----- lib/wlroots.mli | 8 ++++++-- types/types.ml | 1 + 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/keyboard.ml b/lib/keyboard.ml index b1aca10..469ce65 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -25,11 +25,6 @@ let modifiers = getfield Types.Keyboard.modifiers let keycodes = getfield Types.Keyboard.keycodes let num_keycodes = getfield Types.Keyboard.num_keycodes -let signal_key (keyboard : t) : Event_key.t Wl.Signal.t = { - c = keyboard |-> Types.Keyboard.events_key; - typ = ptr Types.Event_keyboard_key.t; -} - let set_keymap = Bindings.wlr_keyboard_set_keymap let set_repeat_info keyboard rate delay = @@ -37,3 +32,15 @@ let set_repeat_info keyboard rate delay = keyboard (Signed.Int32.of_int rate) (Signed.Int32.of_int delay) + +module Events = struct + let key (keyboard : t) : Event_key.t Wl.Signal.t = { + c = keyboard |-> Types.Keyboard.events_key; + typ = ptr Types.Event_keyboard_key.t; + } + + let modifiers (keyboard : t) : t Wl.Signal.t = { + c = keyboard |-> Types.Keyboard.events_modifiers; + typ = ptr Types.Keyboard.t; + } +end diff --git a/lib/wlroots.mli b/lib/wlroots.mli index d9f0580..6615e38 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -138,9 +138,13 @@ module Keyboard : sig val modifiers : t -> Keyboard_modifiers.t val keycodes : t -> Keycodes.t val num_keycodes : t -> Unsigned.size_t - val signal_key : t -> Event_key.t Wl.Signal.t val set_keymap : t -> Xkbcommon.Keymap.t -> bool val set_repeat_info : t -> int -> int -> unit + + module Events : sig + val key : t -> Event_key.t Wl.Signal.t + val modifiers : t -> t Wl.Signal.t + end end module Pointer : sig @@ -276,7 +280,7 @@ module Cursor : sig val attach_output_layout : t -> Output_layout.t -> unit val attach_input_device : t -> Input_device.t -> unit val set_surface : t -> Surface.t -> int -> int -> unit - + val signal_motion : t -> Pointer.Event_motion.t Wl.Signal.t val signal_motion_absolute : t -> Pointer.Event_motion_absolute.t Wl.Signal.t val signal_button : t -> Pointer.Event_button.t Wl.Signal.t diff --git a/types/types.ml b/types/types.ml index 01fd6ef..74be597 100644 --- a/types/types.ml +++ b/types/types.ml @@ -163,6 +163,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let xkb_state = field t "xkb_state" (lift_typ Xkbcommon.State.t) let modifiers = field t "modifiers" (ptr Keyboard_modifiers.t) let events_key = field t "events.key" Wl_signal.t + let events_modifiers = field t "events.modifiers" Wl_signal.t let keycodes = field t "keycodes" Keycodes.t let num_keycodes = field t "num_keycodes" size_t let () = seal t From 5c8627aca5bf488313d2794b965b52faeb5b0ae6 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 11:07:24 -0800 Subject: [PATCH 033/109] tinywl: Stub keyboard handlers. --- tinywl/tinywl.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 141953a..777cdd3 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -8,7 +8,8 @@ type view = { type keyboard = { device: Keyboard.t; - listener: Wl.Listener.t; + modifiers: Wl.Listener.t; + key: Wl.Listener.t; } type tinywl_output = { @@ -90,6 +91,8 @@ let focus_view st view _listener surf = (Keyboard.num_keycodes keyboard) (Keyboard.modifiers keyboard) +let keyboard_handle_modifiers _ _keyboard = () + let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = begin match Xdg_surface.role surf with | None -> print_endline "Got None" @@ -144,11 +147,15 @@ let server_cursor_axis _st _ _ = let server_cursor_frame _st _ _ = failwith "server_cursor_frame" +let keyboard_handle_key _ _key_evt = () + let server_new_keyboard st (keyboard: Keyboard.t) = - let listener = Wl.Listener.create () in + let modifiers = Wl.Listener.create () in + let key = Wl.Listener.create () in let tinywl_keyboard = { device = keyboard; - listener = listener; + modifiers = modifiers; + key = key; } in let xkb_context = match Xkbcommon.Context.create () with | Some ctx -> ctx @@ -164,7 +171,10 @@ let server_new_keyboard st (keyboard: Keyboard.t) = let _ = Xkbcommon.Context.unref xkb_context in let _ = Keyboard.set_repeat_info keyboard 25 6000 in - (* TODO: insert our event handlers *) + Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers + keyboard_handle_modifiers; + Wl.Signal.add (Keyboard.Events.key keyboard) key + keyboard_handle_key; st.keyboards <- tinywl_keyboard :: st.keyboards; () From 046fa8fc450ab7e22307edf42a5a53d44b3823c5 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 11:54:58 -0800 Subject: [PATCH 034/109] seat: Add set_keyboard and seat_keyboard_notify_modifiers. --- ffi/ffi.ml | 6 ++++++ lib/seat.ml | 6 ++++++ lib/wlroots.mli | 2 ++ 3 files changed, 14 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 16bb4c6..72f1fa0 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -292,6 +292,12 @@ struct let wlr_seat_set_capabilities = foreign "wlr_seat_set_capabilities" (wlr_seat_p @-> Wl_seat_capability.t @-> returning void) + let wlr_seat_set_keyboard = foreign "wlr_seat_set_keyboard" + (wlr_seat_p @-> wlr_input_device_p @-> returning void) + + let wlr_seat_keyboard_notify_modifiers = foreign "wlr_seat_keyboard_notify_modifiers" + (wlr_seat_p @-> wlr_keyboard_modifiers_p @-> returning void) + let wlr_seat_keyboard_notify_enter = foreign "wlr_seat_keyboard_notify_enter" (wlr_seat_p @-> wlr_surface_p diff --git a/lib/seat.ml b/lib/seat.ml index 6886056..3b84555 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -65,5 +65,11 @@ let set_capabilities seat caps = Bindings.wlr_seat_set_capabilities seat (coerce Wl.Seat_capability.t uint64_t caps) +let set_keyboard = + Bindings.wlr_seat_set_keyboard + +let keyboard_notify_modifiers = + Bindings.wlr_seat_keyboard_notify_modifiers + let keyboard_notify_enter = Bindings.wlr_seat_keyboard_notify_enter diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 6615e38..255d147 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -331,6 +331,8 @@ module Seat : sig val signal_request_set_cursor : t -> Pointer_request_set_cursor_event.t Wl.Signal.t val set_capabilities : t -> Wl.Seat_capability.t -> unit + val set_keyboard : t -> Input_device.t -> unit + val keyboard_notify_modifiers : t -> Keyboard_modifiers.t -> unit val keyboard_notify_enter : t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard_modifiers.t -> unit end From f507fba8b27990c9a2bbedf3cc97068d14ad8c14 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 11:55:59 -0800 Subject: [PATCH 035/109] tinwyl: Add keyboard_handle_modifiers. --- tinywl/tinywl.ml | 45 ++++++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 777cdd3..587606a 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -91,7 +91,10 @@ let focus_view st view _listener surf = (Keyboard.num_keycodes keyboard) (Keyboard.modifiers keyboard) -let keyboard_handle_modifiers _ _keyboard = () +let keyboard_handle_modifiers st device _ keyboard = + let _ = Seat.set_keyboard st.seat device in + let _ = Seat.keyboard_notify_modifiers st.seat (Keyboard.modifiers keyboard) in + () let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = begin match Xdg_surface.role surf with @@ -149,14 +152,7 @@ let server_cursor_frame _st _ _ = let keyboard_handle_key _ _key_evt = () -let server_new_keyboard st (keyboard: Keyboard.t) = - let modifiers = Wl.Listener.create () in - let key = Wl.Listener.create () in - let tinywl_keyboard = { - device = keyboard; - modifiers = modifiers; - key = key; - } in +let server_new_keyboard_set_settings (keyboard: Keyboard.t) = let xkb_context = match Xkbcommon.Context.create () with | Some ctx -> ctx | None -> failwith "Xkbcommon.Context.create" @@ -169,23 +165,34 @@ let server_new_keyboard st (keyboard: Keyboard.t) = (* Is this for some reference counting stuff?????? *) let _ = Xkbcommon.Keymap.unref keymap in let _ = Xkbcommon.Context.unref xkb_context in - let _ = Keyboard.set_repeat_info keyboard 25 6000 in - - Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers - keyboard_handle_modifiers; - Wl.Signal.add (Keyboard.Events.key keyboard) key - keyboard_handle_key; + Keyboard.set_repeat_info keyboard 25 6000 - st.keyboards <- tinywl_keyboard :: st.keyboards; - () +let server_new_keyboard st (device: Input_device.t) = + match Input_device.typ device with + | Input_device.Keyboard keyboard -> + server_new_keyboard_set_settings keyboard; + let modifiers = Wl.Listener.create () in + let key = Wl.Listener.create () in + Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers + (keyboard_handle_modifiers st device); + Wl.Signal.add (Keyboard.Events.key keyboard) key + keyboard_handle_key; + let tinywl_keyboard = { + device = keyboard; + modifiers = modifiers; + key = key; + } in + + st.keyboards <- tinywl_keyboard :: st.keyboards; + | _ -> () let server_new_pointer st (pointer: Input_device.t) = Cursor.attach_input_device st.cursor pointer let server_new_input st _ (device: Input_device.t) = begin match Input_device.typ device with - | Input_device.Keyboard keyboard -> - server_new_keyboard st keyboard + | Input_device.Keyboard _ -> + server_new_keyboard st device | Input_device.Pointer _ -> server_new_pointer st device | _ -> From 0c8865c67bd02a411146875e3d243c148f1d2341 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 12:46:06 -0800 Subject: [PATCH 036/109] keyboard: Add get_modifiers. --- ffi/ffi.ml | 3 +++ lib/keyboard.ml | 1 + lib/wlroots.mli | 1 + 3 files changed, 5 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 72f1fa0..57b5494 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -197,6 +197,9 @@ struct let wlr_keyboard_set_repeat_info = foreign "wlr_keyboard_set_repeat_info" (wlr_keyboard_p @-> int32_t @-> int32_t @-> returning void) + let wlr_keyboard_get_modifiers = foreign "wlr_keyboard_get_modifiers" + (wlr_keyboard_p @-> returning uint32_t) + (* wlr_backend *) let wlr_backend_p = ptr Backend.t diff --git a/lib/keyboard.ml b/lib/keyboard.ml index 469ce65..c5e9a7f 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -26,6 +26,7 @@ let keycodes = getfield Types.Keyboard.keycodes let num_keycodes = getfield Types.Keyboard.num_keycodes let set_keymap = Bindings.wlr_keyboard_set_keymap +let get_modifiers = Bindings.wlr_keyboard_get_modifiers let set_repeat_info keyboard rate delay = Bindings.wlr_keyboard_set_repeat_info diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 255d147..b6f260c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -140,6 +140,7 @@ module Keyboard : sig val num_keycodes : t -> Unsigned.size_t val set_keymap : t -> Xkbcommon.Keymap.t -> bool val set_repeat_info : t -> int -> int -> unit + val get_modifiers : t -> Unsigned.uint32 module Events : sig val key : t -> Event_key.t Wl.Signal.t From d63becb8d781fff1f0b8bcbadf00d17285b38da4 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 12:46:27 -0800 Subject: [PATCH 037/109] types: Add wlr_keyboard_modifier. --- types/types.ml | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/types/types.ml b/types/types.ml index 74be597..ce0fcd3 100644 --- a/types/types.ml +++ b/types/types.ml @@ -150,6 +150,31 @@ module Make (S : Cstubs_structs.TYPE) = struct let state = field t "state" Key_state.t end + module Keyboard_modifier = struct + type modifier = + Shift | Caps | Ctrl | Alt | Mod2 | Mod3 | Logo | Mod5 + + let _WLR_MODIFIER_SHIFT = constant "WLR_MODIFIER_SHIFT" int64_t + let _WLR_MODIFIER_CAPS = constant "WLR_MODIFIER_CAPS" int64_t + let _WLR_MODIFIER_CTRL = constant "WLR_MODIFIER_CTRL" int64_t + let _WLR_MODIFIER_ALT = constant "WLR_MODIFIER_ALT" int64_t + let _WLR_MODIFIER_MOD2 = constant "WLR_MODIFIER_MOD2" int64_t + let _WLR_MODIFIER_MOD3 = constant "WLR_MODIFIER_MOD3" int64_t + let _WLR_MODIFIER_LOGO = constant "WLR_MODIFIER_LOGO" int64_t + let _WLR_MODIFIER_MOD5 = constant "WLR_MODIFIER_MOD5" int64_t + + let modifier : modifier typ = + enum "wlr_keyboard_modifier" [ + Shift, _WLR_MODIFIER_SHIFT; + Ctrl, _WLR_MODIFIER_CTRL; + Alt, _WLR_MODIFIER_ALT; + Mod2, _WLR_MODIFIER_MOD2; + Mod3, _WLR_MODIFIER_MOD3; + Logo, _WLR_MODIFIER_LOGO; + Mod5, _WLR_MODIFIER_MOD5; + ] + end + module Keyboard_modifiers = struct type t = [`keyboard_modifier] Ctypes.structure let t : t typ = structure "wlr_keyboard_modifiers" From b6e41adcac4d41df3185eaccc0e8dafac0eab9fd Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 12:46:55 -0800 Subject: [PATCH 038/109] keyboard_modifiers: Add has_alt. --- lib/keyboard_modifiers.ml | 6 ++++++ lib/wlroots.mli | 1 + 2 files changed, 7 insertions(+) diff --git a/lib/keyboard_modifiers.ml b/lib/keyboard_modifiers.ml index 9a2b14c..1f8eba3 100644 --- a/lib/keyboard_modifiers.ml +++ b/lib/keyboard_modifiers.ml @@ -6,3 +6,9 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Keyboard_modifiers.t ptr include Ptr + +let has_alt modifiers = + Ctypes.coerce int64_t bool + (Signed.Int64.logand + (Ctypes.coerce uint32_t int64_t modifiers) + Types.Keyboard_modifier._WLR_MODIFIER_ALT) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index b6f260c..9dd5ca7 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -118,6 +118,7 @@ end module Keyboard_modifiers : sig include Comparable0 + val has_alt : Unsigned.uint32 -> bool end module Keyboard : sig From 492a38e563831dc5023d3eb7b3897d0dce85c803 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 28 Feb 2021 13:06:24 -0800 Subject: [PATCH 039/109] [WIP] tinywl: Stub handle_keybinding --- tinywl/tinywl.ml | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 587606a..683c41b 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -97,6 +97,7 @@ let keyboard_handle_modifiers st device _ keyboard = () let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = + (* TODO: Only do the rest if the surface is toplevel *) begin match Xdg_surface.role surf with | None -> print_endline "Got None" | TopLevel -> print_endline "Got TopLevel" @@ -150,7 +151,20 @@ let server_cursor_axis _st _ _ = let server_cursor_frame _st _ _ = failwith "server_cursor_frame" -let keyboard_handle_key _ _key_evt = () +let handle_keybinding _st _sym = + +let keyboard_handle_key st keyboard _ key_evt = + let keycode = Keyboard.Event_key.keycode key_evt in + let syms = Xkbcommon.State.key_get_syms (Keyboard.xkb_state keyboard) keycode in + let modifiers = Keyboard.get_modifiers keyboard in + let handled = + if Keyboard_modifiers.has_alt modifiers && Keyboard.Event_key.state key_evt == Keyboard.Pressed + then List.fold_left (fun _ sym -> handle_keybinding st sym) false syms + else false + in + if not handled + then + else () let server_new_keyboard_set_settings (keyboard: Keyboard.t) = let xkb_context = match Xkbcommon.Context.create () with @@ -176,7 +190,7 @@ let server_new_keyboard st (device: Input_device.t) = Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers (keyboard_handle_modifiers st device); Wl.Signal.add (Keyboard.Events.key keyboard) key - keyboard_handle_key; + (keyboard_handle_key st keyboard); let tinywl_keyboard = { device = keyboard; modifiers = modifiers; From f812bdc857938318a3657d10a7ffdd8b243e3f7e Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 24 Jan 2021 23:43:26 +0000 Subject: [PATCH 040/109] tinywl:server_new_sdg_surface Remove unneeded reference comment. --- tinywl/tinywl.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 683c41b..a1106b3 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -123,8 +123,6 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = (focus_view st view) ; Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener (fun _ _ -> view.mapped <- false;); - (* Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface *) - (* (server_new_xdg_surface st); *) (* cotd *) let toplevel = Xdg_surface.toplevel surf in From 9d306939a3baea2f5f2f878696d1d98a2eb30a42 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 14 Mar 2021 11:49:40 -0700 Subject: [PATCH 041/109] tinywl: Only do new_xdg_surface handling if TopLevel. --- tinywl/tinywl.ml | 68 +++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 35 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index a1106b3..7386305 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -97,42 +97,40 @@ let keyboard_handle_modifiers st device _ keyboard = () let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = - (* TODO: Only do the rest if the surface is toplevel *) begin match Xdg_surface.role surf with - | None -> print_endline "Got None" - | TopLevel -> print_endline "Got TopLevel" - | Popup -> print_endline "Got Popup" - end; - - let view_listener = Wl.Listener.create () in - - let view = { - surface = surf; - listener = view_listener; - mapped = false; - } in - - st.views <- view :: st.views; - - (* We want to add the signal handlers for the surface events using Wl.Signal.add *) - Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener - (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); - - (* Might need to make mapped true in this guy *) - Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (focus_view st view) ; - Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener - (fun _ _ -> view.mapped <- false;); - - (* cotd *) - let toplevel = Xdg_surface.toplevel surf in - - Wl.Signal.add (Xdg_toplevel.Events.request_move toplevel) view_listener - (fun _ _ -> begin_interactive st view Move); - Wl.Signal.add (Xdg_toplevel.Events.request_resize toplevel) view_listener - (* FIXME: Need to actually get the edges from the event to pass with Resize *) - (fun _ _ -> begin_interactive st view (Resize (Unsigned.UInt32.of_int 0))); - () + | None -> () + | Popup -> () + | TopLevel -> + let view_listener = Wl.Listener.create () in + + let view = { + surface = surf; + listener = view_listener; + mapped = false; + } in + + st.views <- view :: st.views; + + (* We want to add the signal handlers for the surface events using Wl.Signal.add *) + Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener + (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); + + (* Might need to make mapped true in this guy *) + Wl.Signal.add (Xdg_surface.Events.map surf) view_listener + (focus_view st view) ; + Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener + (fun _ _ -> view.mapped <- false;); + + (* cotd *) + let toplevel = Xdg_surface.toplevel surf in + + Wl.Signal.add (Xdg_toplevel.Events.request_move toplevel) view_listener + (fun _ _ -> begin_interactive st view Move); + Wl.Signal.add (Xdg_toplevel.Events.request_resize toplevel) view_listener + (* FIXME: Need to actually get the edges from the event to pass with Resize *) + (fun _ _ -> begin_interactive st view (Resize (Unsigned.UInt32.of_int 0))); + () + end let server_cursor_motion _st _ _ = failwith "server_cursor_motion" From 4d7409b9068a5e38e6b138d32f41887b9d01199e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 14 Mar 2021 13:00:42 -0700 Subject: [PATCH 042/109] seat: Add keyboard_notify_key. --- ffi/ffi.ml | 3 +++ lib/seat.ml | 7 +++++++ lib/wlroots.mli | 2 ++ 3 files changed, 12 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 57b5494..f733b15 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -309,6 +309,9 @@ struct @-> wlr_keyboard_modifiers_p @-> returning void) + let wlr_seat_keyboard_notify_key = foreign "wlr_seat_keyboard_notify_key" + (wlr_seat_p @-> uint32_t @-> uint32_t @-> uint32_t @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index 3b84555..7270842 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -73,3 +73,10 @@ let keyboard_notify_modifiers = let keyboard_notify_enter = Bindings.wlr_seat_keyboard_notify_enter + +let keyboard_notify_key seat evt = + Bindings.wlr_seat_keyboard_notify_key + seat + (Keyboard.Event_key.time_msec evt) + (Unsigned.UInt32.of_int (Keyboard.Event_key.keycode evt)) + (coerce Types.Key_state.t uint32_t (Keyboard.Event_key.state evt)) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 9dd5ca7..6197257 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -337,6 +337,8 @@ module Seat : sig val keyboard_notify_modifiers : t -> Keyboard_modifiers.t -> unit val keyboard_notify_enter : t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard_modifiers.t -> unit + val keyboard_notify_key : + t -> Keyboard.Event_key.t -> unit end module Log : sig From 84e48124813a5250a64742d2778830190838c24b Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 14 Mar 2021 13:00:52 -0700 Subject: [PATCH 043/109] Fill in handle_keybinding --- tinywl/tinywl.ml | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 7386305..7c33eda 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -147,9 +147,23 @@ let server_cursor_axis _st _ _ = let server_cursor_frame _st _ _ = failwith "server_cursor_frame" -let handle_keybinding _st _sym = - -let keyboard_handle_key st keyboard _ key_evt = +let handle_keybinding st sym = + if sym == Xkbcommon.Keysyms._Escape + then + let () = Wl.Display.terminate st.display in + true + else if sym == Xkbcommon.Keysyms._F1 + then + match st.views with + | [] -> true + | [_] -> true + | (x :: y :: xs) -> + let () = focus_view st y y.listener y.surface in + st.views <- y :: List.append xs [x]; + true + else false + +let keyboard_handle_key st keyboard device _ key_evt = let keycode = Keyboard.Event_key.keycode key_evt in let syms = Xkbcommon.State.key_get_syms (Keyboard.xkb_state keyboard) keycode in let modifiers = Keyboard.get_modifiers keyboard in @@ -158,9 +172,11 @@ let keyboard_handle_key st keyboard _ key_evt = then List.fold_left (fun _ sym -> handle_keybinding st sym) false syms else false in - if not handled - then - else () + if handled + then () + else + let () = Seat.set_keyboard st.seat device in + Seat.keyboard_notify_key st.seat key_evt let server_new_keyboard_set_settings (keyboard: Keyboard.t) = let xkb_context = match Xkbcommon.Context.create () with @@ -186,7 +202,7 @@ let server_new_keyboard st (device: Input_device.t) = Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers (keyboard_handle_modifiers st device); Wl.Signal.add (Keyboard.Events.key keyboard) key - (keyboard_handle_key st keyboard); + (keyboard_handle_key st keyboard device); let tinywl_keyboard = { device = keyboard; modifiers = modifiers; From 6a50824f0c7e1b88d7a2553dfc737a751beae2cc Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 14 Mar 2021 14:02:34 -0700 Subject: [PATCH 044/109] keyboard_modifiers: Fix has_alt coercions. --- lib/keyboard_modifiers.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/keyboard_modifiers.ml b/lib/keyboard_modifiers.ml index 1f8eba3..b3f4a9d 100644 --- a/lib/keyboard_modifiers.ml +++ b/lib/keyboard_modifiers.ml @@ -8,7 +8,7 @@ type t = Types.Keyboard_modifiers.t ptr include Ptr let has_alt modifiers = - Ctypes.coerce int64_t bool - (Signed.Int64.logand - (Ctypes.coerce uint32_t int64_t modifiers) - Types.Keyboard_modifier._WLR_MODIFIER_ALT) + Signed.Int64.of_int 0 != + Signed.Int64.logand + (Unsigned.UInt32.to_int64 modifiers) + Types.Keyboard_modifier._WLR_MODIFIER_ALT From 9bb93e098482c1cda4917994f89d55b47b70ed9a Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 21 Mar 2021 15:04:20 +0000 Subject: [PATCH 045/109] cursor_move: Added ffi and functions. Amended after hunting down some module shenanigans. Need to have Event_pointer_motion below Input_device or else you get some real weird module reference, makes you feel a bit crazy. Also moved Event_pointer_motion to it's own module. Needed to get the input device from the event. Had cyclical dependency if the event was on the pointer module. --- ffi/ffi.ml | 4 ++++ lib/cursor.ml | 5 +++-- lib/dune | 1 + lib/event_pointer_motion.ml | 14 ++++++++++++++ lib/pointer.ml | 6 ------ lib/wlroots.ml | 1 + lib/wlroots.mli | 15 +++++++++++---- types/types.ml | 19 ++++++++++++------- 8 files changed, 46 insertions(+), 19 deletions(-) create mode 100644 lib/event_pointer_motion.ml diff --git a/ffi/ffi.ml b/ffi/ffi.ml index f733b15..0e82bae 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -275,6 +275,10 @@ struct foreign "wlr_cursor_set_surface" (wlr_cursor_p @-> wlr_surface_p @-> int @-> int @-> returning void) + let wlr_cursor_move = + foreign "wlr_cursor_move" + (wlr_cursor_p @-> wlr_input_device_p @-> double @-> double @-> returning void) + (* wlr_xcursor_manager *) let wlr_xcursor_manager_p = ptr Xcursor_manager.t diff --git a/lib/cursor.ml b/lib/cursor.ml index 2529e4f..b315146 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -11,10 +11,11 @@ let create = Bindings.wlr_cursor_create let attach_output_layout = Bindings.wlr_cursor_attach_output_layout let attach_input_device = Bindings.wlr_cursor_attach_input_device let set_surface = Bindings.wlr_cursor_set_surface +let move = Bindings.wlr_cursor_move -let signal_motion (cursor: t) : Pointer.Event_motion.t Wl.Signal.t = { +let signal_motion (cursor: t) : Event_pointer_motion.t Wl.Signal.t = { c = cursor |-> Types.Cursor.events_motion; - typ = Pointer.Event_motion.t; + typ = Event_pointer_motion.t; } let signal_motion_absolute (cursor: t) : diff --git a/lib/dune b/lib/dune index b32a356..c72fab4 100644 --- a/lib/dune +++ b/lib/dune @@ -23,6 +23,7 @@ output keyboard pointer + event_pointer_motion touch tablet_tool tablet_pad diff --git a/lib/event_pointer_motion.ml b/lib/event_pointer_motion.ml new file mode 100644 index 0000000..f21ee11 --- /dev/null +++ b/lib/event_pointer_motion.ml @@ -0,0 +1,14 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Event_pointer_motion.t ptr +let t = ptr Types.Event_pointer_motion.t +include Ptr + +let device = getfield Types.Event_pointer_motion.device +let time_msec = getfield Types.Event_pointer_motion.time_msec +let delta_x = getfield Types.Event_pointer_motion.delta_x +let delta_y = getfield Types.Event_pointer_motion.delta_y diff --git a/lib/pointer.ml b/lib/pointer.ml index 50f4188..c15a0ef 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -7,12 +7,6 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Pointer.t ptr include Ptr -module Event_motion = struct - type t = Types.Event_pointer_motion.t ptr - let t = ptr Types.Event_pointer_motion.t - include Ptr -end - module Event_motion_absolute = struct type t = Types.Event_pointer_motion_absolute.t ptr let t = ptr Types.Event_pointer_motion_absolute.t diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 0b587c2..1a86db8 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -16,6 +16,7 @@ module Keyboard = Keyboard module Keyboard_modifiers = Keyboard_modifiers module Keycodes = Keycodes module Pointer = Pointer +module Event_pointer_motion = Event_pointer_motion module Touch = Touch module Tablet_tool = Tablet_tool module Tablet_pad = Tablet_pad diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 6197257..9afbc48 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -152,9 +152,6 @@ end module Pointer : sig include Comparable0 - module Event_motion : sig - include Comparable0 - end module Event_motion_absolute : sig include Comparable0 @@ -199,6 +196,15 @@ module Input_device : sig val signal_destroy : t -> t Wl.Signal.t end +module Event_pointer_motion : sig + include Comparable0 + + val device : t -> Input_device.t + val time_msec : t -> Unsigned.uint32 + val delta_x : t -> float + val delta_y : t -> float +end + module Renderer : sig include Comparable0 @@ -282,8 +288,9 @@ module Cursor : sig val attach_output_layout : t -> Output_layout.t -> unit val attach_input_device : t -> Input_device.t -> unit val set_surface : t -> Surface.t -> int -> int -> unit + val move : t -> Input_device.t -> float -> float -> unit - val signal_motion : t -> Pointer.Event_motion.t Wl.Signal.t + val signal_motion : t -> Event_pointer_motion.t Wl.Signal.t val signal_motion_absolute : t -> Pointer.Event_motion_absolute.t Wl.Signal.t val signal_button : t -> Pointer.Event_button.t Wl.Signal.t val signal_axis : t -> Pointer.Event_axis.t Wl.Signal.t diff --git a/types/types.ml b/types/types.ml index ce0fcd3..1d4ae97 100644 --- a/types/types.ml +++ b/types/types.ml @@ -201,13 +201,6 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end - module Event_pointer_motion = struct - type t = [`event_pointer_motion] Ctypes.structure - let t : t typ = structure "wlr_event_pointer_motion" - - let () = seal t - end - module Event_pointer_motion_absolute = struct type t = [`event_pointer_motion_absolute] Ctypes.structure let t : t typ = structure "wlr_event_pointer_motion_absolute" @@ -293,6 +286,18 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Event_pointer_motion = struct + type t = [`event_pointer_motion] Ctypes.structure + let t : t typ = structure "wlr_event_pointer_motion" + + let device = field t "device" (ptr Input_device.t) + let time_msec = field t "time_msec" uint32_t + let delta_x = field t "delta_x" double + let delta_y = field t "delta_y" double + + let () = seal t + end + module Backend = struct type t = [`backend] Ctypes.structure let t : t typ = structure "wlr_backend" From 16dde28aa0b3fa1d162717c0b2179f944cb813fa Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 21 Mar 2021 16:44:24 +0000 Subject: [PATCH 046/109] cursor: Add x & y fields --- lib/cursor.ml | 4 ++++ lib/wlroots.mli | 3 +++ types/types.ml | 3 +++ 3 files changed, 10 insertions(+) diff --git a/lib/cursor.ml b/lib/cursor.ml index b315146..67f54cb 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -7,6 +7,10 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Cursor.t ptr include Ptr +let x = getfield Types.Cursor.x +let y = getfield Types.Cursor.y + + let create = Bindings.wlr_cursor_create let attach_output_layout = Bindings.wlr_cursor_attach_output_layout let attach_input_device = Bindings.wlr_cursor_attach_input_device diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 9afbc48..9cd4948 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -284,6 +284,9 @@ end module Cursor : sig include Comparable0 + val x : t -> float + val y : t -> float + val create : unit -> t val attach_output_layout : t -> Output_layout.t -> unit val attach_input_device : t -> Input_device.t -> unit diff --git a/types/types.ml b/types/types.ml index 1d4ae97..362a89c 100644 --- a/types/types.ml +++ b/types/types.ml @@ -388,6 +388,9 @@ module Make (S : Cstubs_structs.TYPE) = struct type t = [`cursor] Ctypes.structure let t : t typ = structure "wlr_cursor" + let x = field t "x" double + let y = field t "y" double + let events_motion = field t "events.motion" Wl_signal.t let events_motion_absolute = field t "events.motion_absolute" Wl_signal.t let events_button = field t "events.button" Wl_signal.t From 9fd4ed02c33103645ffe27907bba4a6c0ccd49b8 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 21 Mar 2021 16:44:55 +0000 Subject: [PATCH 047/109] [WIP] tinywl: process_cursor_motion --- tinywl/tinywl.ml | 52 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 46 insertions(+), 6 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 7c33eda..6690a08 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -4,6 +4,22 @@ type view = { surface : Xdg_surface.t; listener: Wl.Listener.t; mutable mapped: bool; + mutable x: int; + mutable y: int; +} + +type box = { + x: int; + y: int; + width: int; + height: int; +} + +type grab = { + view: view; + x: float; + y: float; + geobox: box; } type keyboard = { @@ -18,6 +34,10 @@ type tinywl_output = { frame : Wl.Listener.t; } +type cursor_mode = Passthrough + | Move + | Resize of Unsigned.uint32 + type tinywl_server = { display : Wl.Display.t; backend : Backend.t; @@ -25,16 +45,15 @@ type tinywl_server = { output_layout : Output_layout.t; seat : Seat.t; cursor : Cursor.t; + cursor_mode : cursor_mode; mutable outputs : tinywl_output list; mutable views : view list; mutable keyboards : keyboard list; new_output : Wl.Listener.t; -} -type cursor_mode = Passthrough - | Move - | Resize of Unsigned.uint32 + grab: grab option; +} let default_xkb_rules : Xkbcommon.Rule_names.t = { rules = None; @@ -107,6 +126,8 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = surface = surf; listener = view_listener; mapped = false; + x = 0; + y = 0; } in st.views <- view :: st.views; @@ -132,8 +153,27 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = () end -let server_cursor_motion _st _ _ = - failwith "server_cursor_motion" +let process_cursor_move st _time = + Option.iter (fun grab -> + grab.view.x <- truncate (Float.sub (Cursor.x st.cursor) grab.x); + grab.view.y <- truncate (Float.sub (Cursor.y st.cursor) grab.y); + ) st.grab + +let process_cursor_motion st time = + begin match st.cursor_mode with + | Move -> + process_cursor_move st time + | Resize _x -> + process_cursor_resize st time + | Passthrough -> + failwith "Write it!" + end + +let server_cursor_motion st _ (evt: Event_pointer_motion.t) = + Cursor.move st.cursor + (Event_pointer_motion.device evt) + (Event_pointer_motion.delta_x evt) + (Event_pointer_motion.delta_y evt) let server_cursor_motion_absolute _st _ _ = failwith "server_cursor_motion_absolute" From dda4e273fde2c8e2ab0d8b1da817b8eb91eca887 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 28 Mar 2021 14:37:08 +0000 Subject: [PATCH 048/109] edges: Add module --- lib/dune | 1 + lib/edges.ml | 7 +++++++ lib/wlroots.ml | 1 + lib/wlroots.mli | 4 ++++ types/types.ml | 19 +++++++++++++++++++ 5 files changed, 32 insertions(+) create mode 100644 lib/edges.ml diff --git a/lib/dune b/lib/dune index c72fab4..3f7db50 100644 --- a/lib/dune +++ b/lib/dune @@ -24,6 +24,7 @@ keyboard pointer event_pointer_motion + edges touch tablet_tool tablet_pad diff --git a/lib/edges.ml b/lib/edges.ml new file mode 100644 index 0000000..edab017 --- /dev/null +++ b/lib/edges.ml @@ -0,0 +1,7 @@ +(* open Ctypes *) +(* open Wlroots_common.Utils *) + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Edges.t = None | Top | Bottom | Left | Right diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 1a86db8..91589f8 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -17,6 +17,7 @@ module Keyboard_modifiers = Keyboard_modifiers module Keycodes = Keycodes module Pointer = Pointer module Event_pointer_motion = Event_pointer_motion +module Edges = Edges module Touch = Touch module Tablet_tool = Tablet_tool module Tablet_pad = Tablet_pad diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 9cd4948..d9089e6 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -166,6 +166,10 @@ module Pointer : sig end end +module Edges : sig + type t = None | Top | Bottom | Left | Right +end + module Touch : sig include Comparable0 end diff --git a/types/types.ml b/types/types.ml index 362a89c..d003c37 100644 --- a/types/types.ml +++ b/types/types.ml @@ -222,6 +222,25 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Edges = struct + type t = None | Top | Bottom | Left | Right + + let _WLR_EDGE_NONE = constant "WLR_EDGE_NONE" int64_t + let _WLR_EDGE_TOP = constant "WLR_EDGE_TOP" int64_t + let _WLR_EDGE_BOTTOM = constant "WLR_EDGE_BOTTOM" int64_t + let _WLR_EDGE_LEFT = constant "WLR_EDGE_LEFT" int64_t + let _WLR_EDGE_RIGHT = constant "WLR_EDGE_RIGHT" int64_t + + let t : t typ = + enum "wlr_edges" [ + None, _WLR_EDGE_NONE; + Top, _WLR_EDGE_TOP; + Bottom, _WLR_EDGE_BOTTOM; + Left, _WLR_EDGE_LEFT; + Right, _WLR_EDGE_RIGHT; + ] + end + module Touch = struct type t = [`touch] Ctypes.structure let t : t typ = structure "wlr_touch" From cbeb048b1409194fcf28c70f6e9d2625beb3a6cd Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 9 May 2021 12:47:22 -0700 Subject: [PATCH 049/109] ffi: Add wlr_xdg_surface_get_geometry. --- ffi/ffi.ml | 3 +++ lib/wlroots.mli | 1 + lib/xdg_surface.ml | 5 +++++ 3 files changed, 9 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 0e82bae..2eb46de 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -247,6 +247,9 @@ struct let wlr_xdg_surface_from_wlr_surface = foreign "wlr_xdg_surface_from_wlr_surface" (wlr_surface_p @-> returning wlr_xdg_surface_p) + let wlr_xdg_surface_get_geometry = foreign "wlr_xdg_surface_get_geometry" + (wlr_xdg_surface_p @-> wlr_box_p @-> returning void) + (* wlr_xdg_toplevel *) let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated" diff --git a/lib/wlroots.mli b/lib/wlroots.mli index d9089e6..ec9c351 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -264,6 +264,7 @@ module Xdg_surface : sig val toplevel : t -> Xdg_toplevel.t val from_surface : Surface.t -> t option + val get_geometry : t -> Box.t val toplevel_set_activated : t -> bool -> Unsigned.uint32 module Events : sig diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 7473df0..383535a 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -27,6 +27,11 @@ let from_surface (surface : Surface.t) : t option = Some (Bindings.wlr_xdg_surface_from_wlr_surface surface) else None +let get_geometry (surface : t) = + let box = make Types.Box.t in + let () = Bindings.wlr_xdg_surface_get_geometry surface (addr box) in + Box.of_c (addr box) + let toplevel_set_activated = Bindings.wlr_xdg_toplevel_set_activated From 7420b8781f3abd7723d492ddba678c9060089f25 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 9 May 2021 12:38:10 -0700 Subject: [PATCH 050/109] ffi: Add wlr_xdg_toplevel_set_size. --- ffi/ffi.ml | 3 +++ lib/wlroots.mli | 1 + lib/xdg_surface.ml | 3 +++ 3 files changed, 7 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 2eb46de..23c7285 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -255,6 +255,9 @@ struct let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated" (wlr_xdg_surface_p @-> bool @-> returning uint32_t) + let wlr_xdg_toplevel_set_size = foreign "wlr_xdg_toplevel_set_size" + (wlr_xdg_surface_p @-> int @-> int @-> returning uint32_t) + (* wlr_input_device *) let wlr_input_device_p = ptr Input_device.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index ec9c351..92d3107 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -266,6 +266,7 @@ module Xdg_surface : sig val from_surface : Surface.t -> t option val get_geometry : t -> Box.t val toplevel_set_activated : t -> bool -> Unsigned.uint32 + val toplevel_set_size : t -> int -> int -> Unsigned.uint32 module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 383535a..4a59bbd 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -35,6 +35,9 @@ let get_geometry (surface : t) = let toplevel_set_activated = Bindings.wlr_xdg_toplevel_set_activated +let toplevel_set_size = + Bindings.wlr_xdg_toplevel_set_size + module Events = struct let destroy (surface : t) : t Wl.Signal.t = { c = surface |-> Types.Xdg_surface.events_destroy; From 26e88543ccf0a67d72959ac2adc0789a9e06e365 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 9 May 2021 12:47:48 -0700 Subject: [PATCH 051/109] tinywl: Change Tinywl.box to Box.t. --- tinywl/tinywl.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 6690a08..ebceaf1 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -8,18 +8,11 @@ type view = { mutable y: int; } -type box = { - x: int; - y: int; - width: int; - height: int; -} - type grab = { view: view; x: float; y: float; - geobox: box; + geobox: Box.t; } type keyboard = { From 3d338fcb85b4726f8feba9e31b1b77e5b87030ba Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 28 Mar 2021 14:38:37 +0000 Subject: [PATCH 052/109] tinywl: process_cursor_resize Added edge processing. * Move discard to toplevel. --- tinywl/tinywl.ml | 55 ++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 53 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index ebceaf1..0444288 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -13,6 +13,7 @@ type grab = { x: float; y: float; geobox: Box.t; + resize_edges: Edges.t; } type keyboard = { @@ -31,6 +32,8 @@ type cursor_mode = Passthrough | Move | Resize of Unsigned.uint32 +let discard _ = () + type tinywl_server = { display : Wl.Display.t; backend : Backend.t; @@ -90,7 +93,6 @@ let focus_view st view _listener surf = else Xdg_surface.from_surface prev ) in - let discard _ = () in Option.iter (fun s -> discard (Xdg_surface.toplevel_set_activated s false)) to_deactivate; let keyboard = Seat.Keyboard_state.keyboard keyboard_state in @@ -152,6 +154,54 @@ let process_cursor_move st _time = grab.view.y <- truncate (Float.sub (Cursor.y st.cursor) grab.y); ) st.grab +let process_cursor_resize st _time = + Option.iter (fun grab -> + let view = grab.view in + let border_x = Float.sub (Cursor.x st.cursor) grab.x in + let border_y = Float.sub (Cursor.y st.cursor) grab.y in + + let (new_top, new_bottom) = + match grab.resize_edges with + | Edges.Top -> + let new_top = border_y in + let new_bottom = grab.geobox.y + grab.geobox.height in + if new_top >= Float.of_int new_bottom + then (new_bottom - 1, new_bottom) + else (truncate new_top, new_bottom) + | Edges.Bottom -> + let new_top = grab.geobox.y in + let new_bottom = border_y in + if new_bottom <= Float.of_int new_top + then (new_top, new_top + 1) + else (new_top, truncate new_bottom) + | _ -> (grab.geobox.y, grab.geobox.y + grab.geobox.height) + in + let (new_left, new_right) = + match grab.resize_edges with + | Edges.Left -> + let new_left = border_x in + let new_right = grab.geobox.x + grab.geobox.width in + if new_left >= Float.of_int new_right + then (new_right - 1, new_right) + else (truncate new_left, new_right) + | Edges.Right -> + let new_left = grab.geobox.x in + let new_right = border_x in + if new_right <= Float.of_int new_left + then (new_left, new_left + 1) + else (new_left, truncate new_right) + | _ -> (grab.geobox.x, grab.geobox.x + grab.geobox.width) in + + let geobox = Xdg_surface.get_geometry view.surface in + view.x <- new_left - geobox.x; + view.y <- new_top - geobox.y; + + let new_width = new_right - new_left in + let new_height = new_bottom - new_top in + + discard (Xdg_surface.toplevel_set_size view.surface, new_width, new_height) + ) st.grab + let process_cursor_motion st time = begin match st.cursor_mode with | Move -> @@ -316,7 +366,8 @@ let () = let new_input = Wl.Listener.create () in let request_cursor = Wl.Listener.create () in let st = { display; backend; renderer; output_layout; new_output; seat; - cursor; outputs = []; views = []; keyboards = [] } in + cursor; cursor_mode = Passthrough; outputs = []; views = []; + keyboards = []; grab = None } in Wl.Signal.add (Backend.signal_new_output backend) new_output (server_new_output st); From 0309baf7bb0beb68f800f72ce3854067b2c178e8 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 9 May 2021 17:43:01 +0000 Subject: [PATCH 053/109] ffi: Add wlr_xdg_surface_surface_at --- ffi/ffi.ml | 3 +++ lib/wlroots.mli | 1 + lib/xdg_surface.ml | 8 ++++++++ 3 files changed, 12 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 23c7285..1aff806 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -250,6 +250,9 @@ struct let wlr_xdg_surface_get_geometry = foreign "wlr_xdg_surface_get_geometry" (wlr_xdg_surface_p @-> wlr_box_p @-> returning void) + let wlr_xdg_surface_surface_at = foreign "wlr_xdg_surface_surface_at" + (wlr_xdg_surface_p @-> double @-> double @-> ptr double @-> ptr double @-> returning wlr_surface_p) + (* wlr_xdg_toplevel *) let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated" diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 92d3107..c4950d0 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -267,6 +267,7 @@ module Xdg_surface : sig val get_geometry : t -> Box.t val toplevel_set_activated : t -> bool -> Unsigned.uint32 val toplevel_set_size : t -> int -> int -> Unsigned.uint32 + val surface_at : t -> float -> float -> (Surface.t * float * float) option module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 4a59bbd..1186e7e 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -32,6 +32,14 @@ let get_geometry (surface : t) = let () = Bindings.wlr_xdg_surface_get_geometry surface (addr box) in Box.of_c (addr box) +let surface_at (surface : t) sx sy = + let sub_x = allocate double 0.0 in + let sub_y = allocate double 0.0 in + let found_surf = Bindings.wlr_xdg_surface_surface_at surface sx sy sub_x sub_y in + if is_null found_surf + then None + else Some (found_surf, !@ sub_x, !@ sub_y) + let toplevel_set_activated = Bindings.wlr_xdg_toplevel_set_activated From 05ad4a160fe20ca06ee3ce92719ff5ddbd172512 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 9 May 2021 18:08:04 +0000 Subject: [PATCH 054/109] ffi: Add wlr_xcursor_manager_set_cursor_image --- ffi/ffi.ml | 3 +++ lib/wlroots.mli | 1 + lib/xcursor_manager.ml | 1 + 3 files changed, 5 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 1aff806..8b78433 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -298,6 +298,9 @@ struct let wlr_xcursor_manager_load = foreign "wlr_xcursor_manager_load" (wlr_xcursor_manager_p @-> float @-> returning int) + let wlr_xcursor_manager_set_cursor_image = foreign "wlr_xcursor_manager_set_cursor_image" + (wlr_xcursor_manager_p @-> string @-> wlr_cursor_p @-> returning void) + (* wlr_seat *) let wlr_seat_p = ptr Seat.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c4950d0..cf6d931 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -312,6 +312,7 @@ module Xcursor_manager : sig val create : string option -> int -> t val load : t -> float -> int + val set_cursor_image : t -> string -> Cursor.t -> unit end module Seat : sig diff --git a/lib/xcursor_manager.ml b/lib/xcursor_manager.ml index 29ece3c..1d8ad63 100644 --- a/lib/xcursor_manager.ml +++ b/lib/xcursor_manager.ml @@ -9,3 +9,4 @@ include Ptr let create = Bindings.wlr_xcursor_manager_create let load = Bindings.wlr_xcursor_manager_load +let set_cursor_image = Bindings.wlr_xcursor_manager_set_cursor_image From 0b2a5f1d66c399f863b359c4c3567bad06223e25 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 16 May 2021 16:26:33 +0000 Subject: [PATCH 055/109] ffi:seat Add wlr_seat_notify_pointer_enter --- ffi/ffi.ml | 3 +++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 8 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 8b78433..c477d28 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -328,6 +328,9 @@ struct let wlr_seat_keyboard_notify_key = foreign "wlr_seat_keyboard_notify_key" (wlr_seat_p @-> uint32_t @-> uint32_t @-> uint32_t @-> returning void) + let wlr_seat_pointer_notify_enter = foreign "wlr_seat_pointer_notify_enter" + (wlr_seat_p @-> wlr_surface_p @-> double @-> double @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index 7270842..bbeed56 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -80,3 +80,6 @@ let keyboard_notify_key seat evt = (Keyboard.Event_key.time_msec evt) (Unsigned.UInt32.of_int (Keyboard.Event_key.keycode evt)) (coerce Types.Key_state.t uint32_t (Keyboard.Event_key.state evt)) + +let pointer_notify_enter = + Bindings.wlr_seat_pointer_notify_enter diff --git a/lib/wlroots.mli b/lib/wlroots.mli index cf6d931..bf701b5 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -357,6 +357,8 @@ module Seat : sig t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard_modifiers.t -> unit val keyboard_notify_key : t -> Keyboard.Event_key.t -> unit + val pointer_notify_enter : + t -> Surface.t -> float -> float -> unit end module Log : sig From 23b8b9a570eae80add66a954240153862a924cc1 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 16 May 2021 16:38:03 +0000 Subject: [PATCH 056/109] ffi:seat Add wlr_seat_pointer_clear_focus --- ffi/ffi.ml | 3 +++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 8 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index c477d28..740c0c6 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -331,6 +331,9 @@ struct let wlr_seat_pointer_notify_enter = foreign "wlr_seat_pointer_notify_enter" (wlr_seat_p @-> wlr_surface_p @-> double @-> double @-> returning void) + let wlr_seat_pointer_clear_focus = foreign "wlr_seat_pointer_clear_focus" + (wlr_seat_p @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index bbeed56..2a73d4a 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -83,3 +83,6 @@ let keyboard_notify_key seat evt = let pointer_notify_enter = Bindings.wlr_seat_pointer_notify_enter + +let pointer_clear_focus = + Bindings.wlr_seat_pointer_clear_focus diff --git a/lib/wlroots.mli b/lib/wlroots.mli index bf701b5..0ba05f8 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -359,6 +359,8 @@ module Seat : sig t -> Keyboard.Event_key.t -> unit val pointer_notify_enter : t -> Surface.t -> float -> float -> unit + val pointer_clear_focus : + t -> unit end module Log : sig From e0d9302ce2050f11aafd14337c16855ae6d9db48 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 16 May 2021 16:53:22 +0000 Subject: [PATCH 057/109] types:pointer_state Add focused_surface --- lib/seat.ml | 2 ++ lib/wlroots.mli | 1 + types/types.ml | 2 ++ 3 files changed, 5 insertions(+) diff --git a/lib/seat.ml b/lib/seat.ml index 2a73d4a..d650bf9 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -35,6 +35,8 @@ module Pointer_state = struct let focused_client (st: t) = st |->> Types.Seat_pointer_state.focused_client + let focused_surface = + getfield Types.Seat_pointer_state.focused_surface end module Keyboard_state = struct diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 0ba05f8..1cede66 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -326,6 +326,7 @@ module Seat : sig include Comparable0 val focused_client : t -> Client.t + val focused_surface : t -> Surface.t end module Keyboard_state : sig diff --git a/types/types.ml b/types/types.ml index d003c37..4bd5890 100644 --- a/types/types.ml +++ b/types/types.ml @@ -435,6 +435,8 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_seat_pointer_state" let focused_client = field t "focused_client" (ptr Seat_client.t) + let focused_surface = field t "focused_surface" + (ptr Surface.t) let () = seal t end From c8b571efb4bf393e7906b935f10f363216f08ca5 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 16 May 2021 16:54:16 +0000 Subject: [PATCH 058/109] ffi:seat Add wlr_seat_pointer_notify_motion --- ffi/ffi.ml | 3 +++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 8 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 740c0c6..08cdcde 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -334,6 +334,9 @@ struct let wlr_seat_pointer_clear_focus = foreign "wlr_seat_pointer_clear_focus" (wlr_seat_p @-> returning void) + let wlr_seat_pointer_notify_motion = foreign "wlr_seat_pointer_notify_motion" + (wlr_seat_p @-> uint32_t @-> double @-> double @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index d650bf9..763b62f 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -88,3 +88,6 @@ let pointer_notify_enter = let pointer_clear_focus = Bindings.wlr_seat_pointer_clear_focus + +let pointer_notify_motion = + Bindings.wlr_seat_pointer_notify_motion diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 1cede66..1b2711e 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -362,6 +362,8 @@ module Seat : sig t -> Surface.t -> float -> float -> unit val pointer_clear_focus : t -> unit + val pointer_notify_motion : + t -> Unsigned.uint32 -> float -> float -> unit end module Log : sig From 0349b37f5625131f6339fd9b6391a44fa58193b4 Mon Sep 17 00:00:00 2001 From: Peter Morris Date: Sun, 9 May 2021 18:20:36 +0000 Subject: [PATCH 059/109] tinywl: Finish server_cursor_motion --- tinywl/tinywl.ml | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 0444288..27e1d24 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -42,6 +42,7 @@ type tinywl_server = { seat : Seat.t; cursor : Cursor.t; cursor_mode : cursor_mode; + cursor_mgr : Xcursor_manager.t; mutable outputs : tinywl_output list; mutable views : view list; mutable keyboards : keyboard list; @@ -202,6 +203,14 @@ let process_cursor_resize st _time = discard (Xdg_surface.toplevel_set_size view.surface, new_width, new_height) ) st.grab +let view_at lx ly (view : view) = + let view_sx = Float.sub lx (Float.of_int view.x) in + let view_sy = Float.sub ly (Float.of_int view.y) in + Xdg_surface.surface_at view.surface view_sx view_sy + +let desktop_view_at cursor view = + view_at (Cursor.x cursor) (Cursor.y cursor) view + let process_cursor_motion st time = begin match st.cursor_mode with | Move -> @@ -209,14 +218,25 @@ let process_cursor_motion st time = | Resize _x -> process_cursor_resize st time | Passthrough -> - failwith "Write it!" + let view = List.find_map (desktop_view_at st.cursor) st.views in + match view with + | None -> + Xcursor_manager.set_cursor_image st.cursor_mgr "left_ptr" st.cursor; + Seat.pointer_clear_focus st.seat + | Some (surf, sub_x, sub_y) -> + let focus_changed = (Seat.Pointer_state.focused_surface (Seat.pointer_state st.seat)) != surf in + Seat.pointer_notify_enter st.seat surf sub_x sub_y; + if not focus_changed + then Seat.pointer_notify_motion st.seat time sub_x sub_y + else () end let server_cursor_motion st _ (evt: Event_pointer_motion.t) = Cursor.move st.cursor (Event_pointer_motion.device evt) (Event_pointer_motion.delta_x evt) - (Event_pointer_motion.delta_y evt) + (Event_pointer_motion.delta_y evt); + process_cursor_motion st (Event_pointer_motion.time_msec evt) let server_cursor_motion_absolute _st _ _ = failwith "server_cursor_motion_absolute" @@ -366,8 +386,8 @@ let () = let new_input = Wl.Listener.create () in let request_cursor = Wl.Listener.create () in let st = { display; backend; renderer; output_layout; new_output; seat; - cursor; cursor_mode = Passthrough; outputs = []; views = []; - keyboards = []; grab = None } in + cursor; cursor_mode = Passthrough; cursor_mgr; outputs = []; + views = []; keyboards = []; grab = None } in Wl.Signal.add (Backend.signal_new_output backend) new_output (server_new_output st); From 757d53d6fadff2feadbdecca71ee3fe156f19521 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 14:44:19 -0700 Subject: [PATCH 060/109] ffi: Add wlr_cursor_warp_absolute. --- ffi/ffi.ml | 3 +++ lib/cursor.ml | 2 ++ lib/wlroots.mli | 1 + 3 files changed, 6 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 08cdcde..514c3fa 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -288,6 +288,9 @@ struct foreign "wlr_cursor_move" (wlr_cursor_p @-> wlr_input_device_p @-> double @-> double @-> returning void) + let wlr_cursor_warp_absolute = foreign "wlr_cursor_warp_absolute" + (wlr_cursor_p @-> wlr_input_device_p @-> double @-> double @-> returning void) + (* wlr_xcursor_manager *) let wlr_xcursor_manager_p = ptr Xcursor_manager.t diff --git a/lib/cursor.ml b/lib/cursor.ml index 67f54cb..496635d 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -42,3 +42,5 @@ let signal_frame (cursor: t) : unit Wl.Signal.t = { c = cursor |-> Types.Cursor.events_frame; typ = void; } + +let warp_absolute = Bindings.wlr_cursor_warp_absolute diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 1b2711e..6c1a8f3 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -305,6 +305,7 @@ module Cursor : sig val signal_button : t -> Pointer.Event_button.t Wl.Signal.t val signal_axis : t -> Pointer.Event_axis.t Wl.Signal.t val signal_frame : t -> unit (* ? *) Wl.Signal.t + val warp_absolute : t -> Input_device.t -> float -> float -> unit end module Xcursor_manager : sig From 0611f49805c07db517aa3b04042bbbbc2ffcc5c5 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 14:49:53 -0700 Subject: [PATCH 061/109] types: Add device field to Event_pointer_motion_absolute. --- lib/pointer.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 15 ++++++++------- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/lib/pointer.ml b/lib/pointer.ml index c15a0ef..382879f 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -10,6 +10,7 @@ include Ptr module Event_motion_absolute = struct type t = Types.Event_pointer_motion_absolute.t ptr let t = ptr Types.Event_pointer_motion_absolute.t + let device = getfield Types.Event_pointer_motion_absolute.device include Ptr end diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 6c1a8f3..e5706e4 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -155,6 +155,7 @@ module Pointer : sig module Event_motion_absolute : sig include Comparable0 + val device : t -> Input_device.t end module Event_button : sig diff --git a/types/types.ml b/types/types.ml index 4bd5890..4a60787 100644 --- a/types/types.ml +++ b/types/types.ml @@ -201,13 +201,6 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end - module Event_pointer_motion_absolute = struct - type t = [`event_pointer_motion_absolute] Ctypes.structure - let t : t typ = structure "wlr_event_pointer_motion_absolute" - - let () = seal t - end - module Event_pointer_button = struct type t = [`event_pointer_button] Ctypes.structure let t : t typ = structure "wlr_event_pointer_button" @@ -305,6 +298,14 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Event_pointer_motion_absolute = struct + type t = [`event_pointer_motion_absolute] Ctypes.structure + let t : t typ = structure "wlr_event_pointer_motion_absolute" + + let device = field t "device" (ptr Input_device.t) + let () = seal t + end + module Event_pointer_motion = struct type t = [`event_pointer_motion] Ctypes.structure let t : t typ = structure "wlr_event_pointer_motion" From d2d3a1649924e6e8e0d8e1f9bf50231ab318ea8d Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:00:18 -0700 Subject: [PATCH 062/109] types: Add x and y fields to wlr_event_pointer_motion_absolute. --- lib/pointer.ml | 2 ++ lib/wlroots.mli | 2 ++ types/types.ml | 2 ++ 3 files changed, 6 insertions(+) diff --git a/lib/pointer.ml b/lib/pointer.ml index 382879f..f1ea619 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -11,6 +11,8 @@ module Event_motion_absolute = struct type t = Types.Event_pointer_motion_absolute.t ptr let t = ptr Types.Event_pointer_motion_absolute.t let device = getfield Types.Event_pointer_motion_absolute.device + let x = getfield Types.Event_pointer_motion_absolute.x + let y = getfield Types.Event_pointer_motion_absolute.y include Ptr end diff --git a/lib/wlroots.mli b/lib/wlroots.mli index e5706e4..5f439f6 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -156,6 +156,8 @@ module Pointer : sig module Event_motion_absolute : sig include Comparable0 val device : t -> Input_device.t + val x : t -> float + val y : t -> float end module Event_button : sig diff --git a/types/types.ml b/types/types.ml index 4a60787..4646383 100644 --- a/types/types.ml +++ b/types/types.ml @@ -303,6 +303,8 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_event_pointer_motion_absolute" let device = field t "device" (ptr Input_device.t) + let x = field t "x" double + let y = field t "y" double let () = seal t end From 1ea917b98af3bbfe155c77524a2dbe608fba973e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:02:29 -0700 Subject: [PATCH 063/109] lib/event_pointer_motion_absolute: Move module out of Pointer. This matches the module Event_pointer_motion. --- lib/cursor.ml | 4 ++-- lib/dune | 1 + lib/event_pointer_motion_absolute.ml | 13 +++++++++++++ lib/pointer.ml | 9 --------- lib/wlroots.ml | 1 + lib/wlroots.mli | 18 +++++++++--------- 6 files changed, 26 insertions(+), 20 deletions(-) create mode 100644 lib/event_pointer_motion_absolute.ml diff --git a/lib/cursor.ml b/lib/cursor.ml index 496635d..c09868c 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -23,9 +23,9 @@ let signal_motion (cursor: t) : Event_pointer_motion.t Wl.Signal.t = { } let signal_motion_absolute (cursor: t) : - Pointer.Event_motion_absolute.t Wl.Signal.t = { + Event_pointer_motion_absolute.t Wl.Signal.t = { c = cursor |-> Types.Cursor.events_motion_absolute; - typ = Pointer.Event_motion_absolute.t; + typ = Event_pointer_motion_absolute.t; } let signal_button (cursor: t) : Pointer.Event_button.t Wl.Signal.t = { diff --git a/lib/dune b/lib/dune index 3f7db50..d910f34 100644 --- a/lib/dune +++ b/lib/dune @@ -24,6 +24,7 @@ keyboard pointer event_pointer_motion + event_pointer_motion_absolute edges touch tablet_tool diff --git a/lib/event_pointer_motion_absolute.ml b/lib/event_pointer_motion_absolute.ml new file mode 100644 index 0000000..f573977 --- /dev/null +++ b/lib/event_pointer_motion_absolute.ml @@ -0,0 +1,13 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Event_pointer_motion_absolute.t ptr +let t = ptr Types.Event_pointer_motion_absolute.t +include Ptr + +let device = getfield Types.Event_pointer_motion_absolute.device +let x = getfield Types.Event_pointer_motion_absolute.x +let y = getfield Types.Event_pointer_motion_absolute.y diff --git a/lib/pointer.ml b/lib/pointer.ml index f1ea619..646e3e9 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -7,15 +7,6 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Pointer.t ptr include Ptr -module Event_motion_absolute = struct - type t = Types.Event_pointer_motion_absolute.t ptr - let t = ptr Types.Event_pointer_motion_absolute.t - let device = getfield Types.Event_pointer_motion_absolute.device - let x = getfield Types.Event_pointer_motion_absolute.x - let y = getfield Types.Event_pointer_motion_absolute.y - include Ptr -end - module Event_button = struct type t = Types.Event_pointer_button.t ptr let t = ptr Types.Event_pointer_button.t diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 91589f8..5e19e93 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -17,6 +17,7 @@ module Keyboard_modifiers = Keyboard_modifiers module Keycodes = Keycodes module Pointer = Pointer module Event_pointer_motion = Event_pointer_motion +module Event_pointer_motion_absolute = Event_pointer_motion_absolute module Edges = Edges module Touch = Touch module Tablet_tool = Tablet_tool diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 5f439f6..8b3b8f2 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -152,14 +152,6 @@ end module Pointer : sig include Comparable0 - - module Event_motion_absolute : sig - include Comparable0 - val device : t -> Input_device.t - val x : t -> float - val y : t -> float - end - module Event_button : sig include Comparable0 end @@ -212,6 +204,14 @@ module Event_pointer_motion : sig val delta_y : t -> float end +module Event_pointer_motion_absolute : sig + include Comparable0 + + val device : t -> Input_device.t + val x : t -> float + val y : t -> float +end + module Renderer : sig include Comparable0 @@ -304,7 +304,7 @@ module Cursor : sig val move : t -> Input_device.t -> float -> float -> unit val signal_motion : t -> Event_pointer_motion.t Wl.Signal.t - val signal_motion_absolute : t -> Pointer.Event_motion_absolute.t Wl.Signal.t + val signal_motion_absolute : t -> Event_pointer_motion_absolute.t Wl.Signal.t val signal_button : t -> Pointer.Event_button.t Wl.Signal.t val signal_axis : t -> Pointer.Event_axis.t Wl.Signal.t val signal_frame : t -> unit (* ? *) Wl.Signal.t From 224e614d394312f82bd85ceb7f7ed9d124c2c56e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:05:27 -0700 Subject: [PATCH 064/109] event_pointer_motion_absolute: Add time_msec field. --- lib/event_pointer_motion_absolute.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_motion_absolute.ml b/lib/event_pointer_motion_absolute.ml index f573977..22dfb82 100644 --- a/lib/event_pointer_motion_absolute.ml +++ b/lib/event_pointer_motion_absolute.ml @@ -11,3 +11,4 @@ include Ptr let device = getfield Types.Event_pointer_motion_absolute.device let x = getfield Types.Event_pointer_motion_absolute.x let y = getfield Types.Event_pointer_motion_absolute.y +let time_msec = getfield Types.Event_pointer_motion_absolute.time_msec diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 8b3b8f2..ad9089c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -210,6 +210,7 @@ module Event_pointer_motion_absolute : sig val device : t -> Input_device.t val x : t -> float val y : t -> float + val time_msec : t -> Unsigned.uint32 end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index 4646383..fff76de 100644 --- a/types/types.ml +++ b/types/types.ml @@ -305,6 +305,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let device = field t "device" (ptr Input_device.t) let x = field t "x" double let y = field t "y" double + let time_msec = field t "time_msec" uint32_t let () = seal t end From 8d07b276e467f92fa00aa01fddebc83ee0555ac4 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:07:42 -0700 Subject: [PATCH 065/109] tinywl: Finish server_cursor_motion_absolute. --- tinywl/tinywl.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 27e1d24..cfb5508 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -238,8 +238,14 @@ let server_cursor_motion st _ (evt: Event_pointer_motion.t) = (Event_pointer_motion.delta_y evt); process_cursor_motion st (Event_pointer_motion.time_msec evt) -let server_cursor_motion_absolute _st _ _ = - failwith "server_cursor_motion_absolute" +let server_cursor_motion_absolute st _ (evt: Event_pointer_motion_absolute.t) = + Cursor.warp_absolute + st.cursor + (Event_pointer_motion_absolute.device evt) + (Event_pointer_motion_absolute.x evt) + (Event_pointer_motion_absolute.y evt); + process_cursor_motion st (Event_pointer_motion_absolute.time_msec evt) + let server_cursor_button _st _ _ = failwith "server_cursor_button" From 88cf008e3ae012f49aaddd231dde541b10a101f4 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:19:11 -0700 Subject: [PATCH 066/109] wlroots: Move Event_pointer_button to separate module. This matches event_pointer_motion*. --- lib/cursor.ml | 4 ++-- lib/dune | 1 + lib/event_pointer_button.ml | 9 +++++++++ lib/pointer.ml | 6 ------ lib/wlroots.ml | 1 + lib/wlroots.mli | 10 +++++----- 6 files changed, 18 insertions(+), 13 deletions(-) create mode 100644 lib/event_pointer_button.ml diff --git a/lib/cursor.ml b/lib/cursor.ml index c09868c..91ba588 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -28,9 +28,9 @@ let signal_motion_absolute (cursor: t) : typ = Event_pointer_motion_absolute.t; } -let signal_button (cursor: t) : Pointer.Event_button.t Wl.Signal.t = { +let signal_button (cursor: t) : Event_pointer_button.t Wl.Signal.t = { c = cursor |-> Types.Cursor.events_button; - typ = Pointer.Event_button.t; + typ = Event_pointer_button.t; } let signal_axis (cursor: t) : Pointer.Event_axis.t Wl.Signal.t = { diff --git a/lib/dune b/lib/dune index d910f34..eed8b3a 100644 --- a/lib/dune +++ b/lib/dune @@ -23,6 +23,7 @@ output keyboard pointer + event_pointer_button event_pointer_motion event_pointer_motion_absolute edges diff --git a/lib/event_pointer_button.ml b/lib/event_pointer_button.ml new file mode 100644 index 0000000..69552ba --- /dev/null +++ b/lib/event_pointer_button.ml @@ -0,0 +1,9 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Event_pointer_button.t ptr +let t = ptr Types.Event_pointer_button.t +include Ptr diff --git a/lib/pointer.ml b/lib/pointer.ml index 646e3e9..8e93171 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -7,12 +7,6 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Pointer.t ptr include Ptr -module Event_button = struct - type t = Types.Event_pointer_button.t ptr - let t = ptr Types.Event_pointer_button.t - include Ptr -end - module Event_axis = struct type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 5e19e93..0142827 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -18,6 +18,7 @@ module Keycodes = Keycodes module Pointer = Pointer module Event_pointer_motion = Event_pointer_motion module Event_pointer_motion_absolute = Event_pointer_motion_absolute +module Event_pointer_button = Event_pointer_button module Edges = Edges module Touch = Touch module Tablet_tool = Tablet_tool diff --git a/lib/wlroots.mli b/lib/wlroots.mli index ad9089c..f5313dc 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -152,10 +152,6 @@ end module Pointer : sig include Comparable0 - module Event_button : sig - include Comparable0 - end - module Event_axis : sig include Comparable0 end @@ -213,6 +209,10 @@ module Event_pointer_motion_absolute : sig val time_msec : t -> Unsigned.uint32 end +module Event_pointer_button : sig + include Comparable0 +end + module Renderer : sig include Comparable0 @@ -306,7 +306,7 @@ module Cursor : sig val signal_motion : t -> Event_pointer_motion.t Wl.Signal.t val signal_motion_absolute : t -> Event_pointer_motion_absolute.t Wl.Signal.t - val signal_button : t -> Pointer.Event_button.t Wl.Signal.t + val signal_button : t -> Event_pointer_button.t Wl.Signal.t val signal_axis : t -> Pointer.Event_axis.t Wl.Signal.t val signal_frame : t -> unit (* ? *) Wl.Signal.t val warp_absolute : t -> Input_device.t -> float -> float -> unit From 17ebc7aaf5757f419874287c73c6ab76e316505b Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:22:28 -0700 Subject: [PATCH 067/109] event_pointer_button: Add time_msec field. --- lib/event_pointer_button.ml | 2 ++ lib/wlroots.mli | 2 ++ types/types.ml | 1 + 3 files changed, 5 insertions(+) diff --git a/lib/event_pointer_button.ml b/lib/event_pointer_button.ml index 69552ba..34a3225 100644 --- a/lib/event_pointer_button.ml +++ b/lib/event_pointer_button.ml @@ -7,3 +7,5 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Event_pointer_button.t ptr let t = ptr Types.Event_pointer_button.t include Ptr + +let time_msec = getfield Types.Event_pointer_button.time_msec diff --git a/lib/wlroots.mli b/lib/wlroots.mli index f5313dc..33e65d2 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -211,6 +211,8 @@ end module Event_pointer_button : sig include Comparable0 + + val time_msec : t -> Unsigned.uint32 end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index fff76de..8325aee 100644 --- a/types/types.ml +++ b/types/types.ml @@ -205,6 +205,7 @@ module Make (S : Cstubs_structs.TYPE) = struct type t = [`event_pointer_button] Ctypes.structure let t : t typ = structure "wlr_event_pointer_button" + let time_msec = field t "time_msec" uint32_t let () = seal t end From 69d547ca06a5b272a984b5cfaa02376ece0592e4 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:24:47 -0700 Subject: [PATCH 068/109] event_pointer_button: Add button field. --- lib/event_pointer_button.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_button.ml b/lib/event_pointer_button.ml index 34a3225..4c2d3f6 100644 --- a/lib/event_pointer_button.ml +++ b/lib/event_pointer_button.ml @@ -9,3 +9,4 @@ let t = ptr Types.Event_pointer_button.t include Ptr let time_msec = getfield Types.Event_pointer_button.time_msec +let button = getfield Types.Event_pointer_button.button diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 33e65d2..35a693c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -213,6 +213,7 @@ module Event_pointer_button : sig include Comparable0 val time_msec : t -> Unsigned.uint32 + val button : t -> Unsigned.uint32 end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index 8325aee..64c48e7 100644 --- a/types/types.ml +++ b/types/types.ml @@ -206,6 +206,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_event_pointer_button" let time_msec = field t "time_msec" uint32_t + let button = field t "button" uint32_t let () = seal t end From 60301e12a4a1053c94349b6636d061a9e1a216bf Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:43:03 -0700 Subject: [PATCH 069/109] types: Add Button_state. --- lib/pointer.ml | 2 ++ lib/wlroots.mli | 2 ++ types/types.ml | 12 ++++++++++++ 3 files changed, 16 insertions(+) diff --git a/lib/pointer.ml b/lib/pointer.ml index 8e93171..2c9dcd0 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -7,6 +7,8 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Pointer.t ptr include Ptr +type button_state = Types.Button_state.t = Released | Pressed + module Event_axis = struct type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 35a693c..0a94188 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -152,6 +152,8 @@ end module Pointer : sig include Comparable0 + type button_state = Released | Pressed + module Event_axis : sig include Comparable0 end diff --git a/types/types.ml b/types/types.ml index 64c48e7..23ce9ac 100644 --- a/types/types.ml +++ b/types/types.ml @@ -135,6 +135,18 @@ module Make (S : Cstubs_structs.TYPE) = struct ] end + module Button_state = struct + type t = Released | Pressed + + let _RELEASED = constant "WLR_BUTTON_RELEASED" int64_t + let _PRESSED = constant "WLR_BUTTON_PRESSED" int64_t + + let t : t typ = enum "wlr_button_state" [ + Released, _RELEASED; + Pressed, _PRESSED; + ] + end + (* This is an array of unit32_t keycodes: uint32_t keycodes[] *) module Keycodes = struct type t = unit ptr From 80ccc9bded8a47b6b7e0df5bd0a157da8bd0c266 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:43:41 -0700 Subject: [PATCH 070/109] event_pointer_button: Add state field. --- lib/event_pointer_button.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_button.ml b/lib/event_pointer_button.ml index 4c2d3f6..663d98f 100644 --- a/lib/event_pointer_button.ml +++ b/lib/event_pointer_button.ml @@ -10,3 +10,4 @@ include Ptr let time_msec = getfield Types.Event_pointer_button.time_msec let button = getfield Types.Event_pointer_button.button +let state = getfield Types.Event_pointer_button.state diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 0a94188..4f6afdb 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -216,6 +216,7 @@ module Event_pointer_button : sig val time_msec : t -> Unsigned.uint32 val button : t -> Unsigned.uint32 + val state : t -> Pointer.button_state end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index 23ce9ac..41f4769 100644 --- a/types/types.ml +++ b/types/types.ml @@ -219,6 +219,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let time_msec = field t "time_msec" uint32_t let button = field t "button" uint32_t + let state = field t "state" Button_state.t let () = seal t end From 57e3ffa5b48afbeb2909af878b3ffa4d91c2485b Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 15:59:27 -0700 Subject: [PATCH 071/109] ffi: Add wlr_seat_pointer_notify_button. --- ffi/ffi.ml | 3 +++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 8 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 514c3fa..64cff1e 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -340,6 +340,9 @@ struct let wlr_seat_pointer_notify_motion = foreign "wlr_seat_pointer_notify_motion" (wlr_seat_p @-> uint32_t @-> double @-> double @-> returning void) + let wlr_seat_pointer_notify_button = foreign "wlr_seat_pointer_notify_button" + (wlr_seat_p @-> uint32_t @-> uint32_t @-> Button_state.t @-> returning uint32_t) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index 763b62f..d9e8d5a 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -91,3 +91,6 @@ let pointer_clear_focus = let pointer_notify_motion = Bindings.wlr_seat_pointer_notify_motion + +let pointer_notify_button = + Bindings.wlr_seat_pointer_notify_button diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 4f6afdb..b2e2ead 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -375,6 +375,8 @@ module Seat : sig t -> unit val pointer_notify_motion : t -> Unsigned.uint32 -> float -> float -> unit + val pointer_notify_button : + t -> Unsigned.uint32 -> Unsigned.uint32 -> Pointer.button_state -> Unsigned.uint32 end module Log : sig From 01cc9ba015c5bb9bc17c5a8d86402f54856d2f65 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 17:10:59 -0700 Subject: [PATCH 072/109] tinywl: Finish server_cursor_button. * Change type of desktop_view_at. * Make st.cursor_mode mutable. --- tinywl/tinywl.ml | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index cfb5508..fabcbe1 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -41,7 +41,7 @@ type tinywl_server = { output_layout : Output_layout.t; seat : Seat.t; cursor : Cursor.t; - cursor_mode : cursor_mode; + mutable cursor_mode : cursor_mode; cursor_mgr : Xcursor_manager.t; mutable outputs : tinywl_output list; mutable views : view list; @@ -208,8 +208,10 @@ let view_at lx ly (view : view) = let view_sy = Float.sub ly (Float.of_int view.y) in Xdg_surface.surface_at view.surface view_sx view_sy -let desktop_view_at cursor view = - view_at (Cursor.x cursor) (Cursor.y cursor) view +let desktop_view_at cursor = + List.find_map (fun view -> + Option.map (fun (surf, x, y) -> (view, surf, x, y)) + (view_at (Cursor.x cursor) (Cursor.y cursor) view)) let process_cursor_motion st time = begin match st.cursor_mode with @@ -218,12 +220,12 @@ let process_cursor_motion st time = | Resize _x -> process_cursor_resize st time | Passthrough -> - let view = List.find_map (desktop_view_at st.cursor) st.views in + let view = desktop_view_at st.cursor st.views in match view with | None -> Xcursor_manager.set_cursor_image st.cursor_mgr "left_ptr" st.cursor; Seat.pointer_clear_focus st.seat - | Some (surf, sub_x, sub_y) -> + | Some (_view, surf, sub_x, sub_y) -> let focus_changed = (Seat.Pointer_state.focused_surface (Seat.pointer_state st.seat)) != surf in Seat.pointer_notify_enter st.seat surf sub_x sub_y; if not focus_changed @@ -246,9 +248,21 @@ let server_cursor_motion_absolute st _ (evt: Event_pointer_motion_absolute.t) = (Event_pointer_motion_absolute.y evt); process_cursor_motion st (Event_pointer_motion_absolute.time_msec evt) - -let server_cursor_button _st _ _ = - failwith "server_cursor_button" +let server_cursor_button st _ (evt: Event_pointer_button.t) = + let button_state = Event_pointer_button.state evt in + discard (Seat.pointer_notify_button + st.seat + (Event_pointer_button.time_msec evt) + (Event_pointer_button.button evt) + button_state); + if button_state == Pointer.Released + then st.cursor_mode <- Passthrough + else + let found_view = desktop_view_at st.cursor st.views in + Option.iter (fun (view, surf, _, _) -> + Option.iter (fun xdg_surf -> focus_view st view () xdg_surf) + (Xdg_surface.from_surface surf)) + found_view let server_cursor_axis _st _ _ = failwith "server_cursor_axis" From 4b0c83462964cfb8ca5e45528e654205b2f4c358 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 17:51:00 -0700 Subject: [PATCH 073/109] types: Add wlr_axis_source enum. --- lib/pointer.ml | 2 ++ lib/wlroots.mli | 1 + types/types.ml | 16 ++++++++++++++++ 3 files changed, 19 insertions(+) diff --git a/lib/pointer.ml b/lib/pointer.ml index 2c9dcd0..7cae81e 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -9,6 +9,8 @@ include Ptr type button_state = Types.Button_state.t = Released | Pressed +type axis_source = Types.Axis_source.t = Wheel | Finger | Continuous | Wheel_tilt + module Event_axis = struct type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index b2e2ead..131e15b 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -153,6 +153,7 @@ module Pointer : sig include Comparable0 type button_state = Released | Pressed + type axis_source = Wheel | Finger | Continuous | Wheel_tilt module Event_axis : sig include Comparable0 diff --git a/types/types.ml b/types/types.ml index 41f4769..c9d2acb 100644 --- a/types/types.ml +++ b/types/types.ml @@ -223,6 +223,22 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Axis_source = struct + type t = Wheel | Finger | Continuous | Wheel_tilt + + let _WLR_AXIS_SOURCE_WHEEL = constant "WLR_AXIS_SOURCE_WHEEL" int64_t + let _WLR_AXIS_SOURCE_FINGER = constant "WLR_AXIS_SOURCE_FINGER" int64_t + let _WLR_AXIS_SOURCE_CONTINUOUS = constant "WLR_AXIS_SOURCE_CONTINUOUS" int64_t + let _WLR_AXIS_SOURCE_WHEEL_TILT = constant "WLR_AXIS_SOURCE_WHEEL_TILT" int64_t + + let t : t typ = enum "wlr_axis_source" [ + Wheel, _WLR_AXIS_SOURCE_WHEEL; + Finger, _WLR_AXIS_SOURCE_FINGER; + Continuous, _WLR_AXIS_SOURCE_CONTINUOUS; + Wheel_tilt, _WLR_AXIS_SOURCE_WHEEL_TILT; + ] + end + module Event_pointer_axis = struct type t = [`event_pointer_axis] Ctypes.structure let t : t typ = structure "wlr_event_pointer_axis" From 2d7deacf8e35caf4f7573f6e62bf7d6c7757c59d Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 17:54:19 -0700 Subject: [PATCH 074/109] types: Add wlr_axis_orientation enum. --- lib/pointer.ml | 2 ++ lib/wlroots.mli | 1 + types/types.ml | 12 ++++++++++++ 3 files changed, 15 insertions(+) diff --git a/lib/pointer.ml b/lib/pointer.ml index 7cae81e..65feed6 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -11,6 +11,8 @@ type button_state = Types.Button_state.t = Released | Pressed type axis_source = Types.Axis_source.t = Wheel | Finger | Continuous | Wheel_tilt +type axis_orientation = Types.Axis_orientation.t = Vertical | Horizontal + module Event_axis = struct type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 131e15b..a50c4ef 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -154,6 +154,7 @@ module Pointer : sig type button_state = Released | Pressed type axis_source = Wheel | Finger | Continuous | Wheel_tilt + type axis_orientation = Vertical | Horizontal module Event_axis : sig include Comparable0 diff --git a/types/types.ml b/types/types.ml index c9d2acb..8f3d9f5 100644 --- a/types/types.ml +++ b/types/types.ml @@ -239,6 +239,18 @@ module Make (S : Cstubs_structs.TYPE) = struct ] end + module Axis_orientation = struct + type t = Vertical | Horizontal + + let _WLR_AXIS_ORIENTATION_VERTICAL = constant "WLR_AXIS_ORIENTATION_VERTICAL" int64_t + let _WLR_AXIS_ORIENTATION_HORIZONTAL = constant "WLR_AXIS_ORIENTATION_HORIZONTAL" int64_t + + let t : t typ = enum "wlr_axis_orientation" [ + Vertical, _WLR_AXIS_ORIENTATION_VERTICAL; + Horizontal, _WLR_AXIS_ORIENTATION_HORIZONTAL; + ] + end + module Event_pointer_axis = struct type t = [`event_pointer_axis] Ctypes.structure let t : t typ = structure "wlr_event_pointer_axis" From fefa49b881cf6aa69bf1d583dd7168662e635f25 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:00:48 -0700 Subject: [PATCH 075/109] event_pointer_axis: Move Event_pointer_axis module to separate file. --- lib/cursor.ml | 4 ++-- lib/dune | 1 + lib/event_pointer_axis.ml | 9 +++++++++ lib/pointer.ml | 6 ------ lib/wlroots.ml | 1 + lib/wlroots.mli | 10 +++++----- 6 files changed, 18 insertions(+), 13 deletions(-) create mode 100644 lib/event_pointer_axis.ml diff --git a/lib/cursor.ml b/lib/cursor.ml index 91ba588..dd2ca18 100644 --- a/lib/cursor.ml +++ b/lib/cursor.ml @@ -33,9 +33,9 @@ let signal_button (cursor: t) : Event_pointer_button.t Wl.Signal.t = { typ = Event_pointer_button.t; } -let signal_axis (cursor: t) : Pointer.Event_axis.t Wl.Signal.t = { +let signal_axis (cursor: t) : Event_pointer_axis.t Wl.Signal.t = { c = cursor |-> Types.Cursor.events_axis; - typ = Pointer.Event_axis.t; + typ = Event_pointer_axis.t; } let signal_frame (cursor: t) : unit Wl.Signal.t = { diff --git a/lib/dune b/lib/dune index eed8b3a..6637e7d 100644 --- a/lib/dune +++ b/lib/dune @@ -26,6 +26,7 @@ event_pointer_button event_pointer_motion event_pointer_motion_absolute + event_pointer_axis edges touch tablet_tool diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml new file mode 100644 index 0000000..21aae9c --- /dev/null +++ b/lib/event_pointer_axis.ml @@ -0,0 +1,9 @@ +open Ctypes +open Wlroots_common.Utils + +module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) +module Types = Wlroots_ffi_f.Ffi.Types + +type t = Types.Event_pointer_axis.t ptr +let t = ptr Types.Event_pointer_axis.t +include Ptr diff --git a/lib/pointer.ml b/lib/pointer.ml index 65feed6..673383e 100644 --- a/lib/pointer.ml +++ b/lib/pointer.ml @@ -12,9 +12,3 @@ type button_state = Types.Button_state.t = Released | Pressed type axis_source = Types.Axis_source.t = Wheel | Finger | Continuous | Wheel_tilt type axis_orientation = Types.Axis_orientation.t = Vertical | Horizontal - -module Event_axis = struct - type t = Types.Event_pointer_axis.t ptr - let t = ptr Types.Event_pointer_axis.t - include Ptr -end diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 0142827..f376b21 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -19,6 +19,7 @@ module Pointer = Pointer module Event_pointer_motion = Event_pointer_motion module Event_pointer_motion_absolute = Event_pointer_motion_absolute module Event_pointer_button = Event_pointer_button +module Event_pointer_axis = Event_pointer_axis module Edges = Edges module Touch = Touch module Tablet_tool = Tablet_tool diff --git a/lib/wlroots.mli b/lib/wlroots.mli index a50c4ef..6c3e1a4 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -155,10 +155,6 @@ module Pointer : sig type button_state = Released | Pressed type axis_source = Wheel | Finger | Continuous | Wheel_tilt type axis_orientation = Vertical | Horizontal - - module Event_axis : sig - include Comparable0 - end end module Edges : sig @@ -221,6 +217,10 @@ module Event_pointer_button : sig val state : t -> Pointer.button_state end +module Event_pointer_axis : sig + include Comparable0 +end + module Renderer : sig include Comparable0 @@ -315,7 +315,7 @@ module Cursor : sig val signal_motion : t -> Event_pointer_motion.t Wl.Signal.t val signal_motion_absolute : t -> Event_pointer_motion_absolute.t Wl.Signal.t val signal_button : t -> Event_pointer_button.t Wl.Signal.t - val signal_axis : t -> Pointer.Event_axis.t Wl.Signal.t + val signal_axis : t -> Event_pointer_axis.t Wl.Signal.t val signal_frame : t -> unit (* ? *) Wl.Signal.t val warp_absolute : t -> Input_device.t -> float -> float -> unit end From d706005edd58d28a41f32a4e0154926d15d8d56f Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:03:34 -0700 Subject: [PATCH 076/109] types: Add field orientation of wlr_event_pointer_axis. --- lib/event_pointer_axis.ml | 2 ++ lib/wlroots.mli | 2 ++ types/types.ml | 1 + 3 files changed, 5 insertions(+) diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml index 21aae9c..91e99b0 100644 --- a/lib/event_pointer_axis.ml +++ b/lib/event_pointer_axis.ml @@ -7,3 +7,5 @@ module Types = Wlroots_ffi_f.Ffi.Types type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t include Ptr + +let orientation = getfield Types.Event_pointer_axis.orientation diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 6c3e1a4..6977bb8 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -219,6 +219,8 @@ end module Event_pointer_axis : sig include Comparable0 + + val orientation : t -> Pointer.axis_orientation end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index 8f3d9f5..c48935f 100644 --- a/types/types.ml +++ b/types/types.ml @@ -255,6 +255,7 @@ module Make (S : Cstubs_structs.TYPE) = struct type t = [`event_pointer_axis] Ctypes.structure let t : t typ = structure "wlr_event_pointer_axis" + let orientation = field t "orientation" Axis_orientation.t let () = seal t end From 1dc5bb15265bd19c532a31a06d4494ad95ae4692 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:05:03 -0700 Subject: [PATCH 077/109] types: Add delta field of wlr_event_pointer_axis. --- lib/event_pointer_axis.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml index 91e99b0..72851e7 100644 --- a/lib/event_pointer_axis.ml +++ b/lib/event_pointer_axis.ml @@ -9,3 +9,4 @@ let t = ptr Types.Event_pointer_axis.t include Ptr let orientation = getfield Types.Event_pointer_axis.orientation +let delta = getfield Types.Event_pointer_axis.delta diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 6977bb8..c2ccef2 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -221,6 +221,7 @@ module Event_pointer_axis : sig include Comparable0 val orientation : t -> Pointer.axis_orientation + val delta : t -> float end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index c48935f..bd3e222 100644 --- a/types/types.ml +++ b/types/types.ml @@ -256,6 +256,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_event_pointer_axis" let orientation = field t "orientation" Axis_orientation.t + let delta = field t "delta" double let () = seal t end From fc34992e5c3e6e6d5a09ac585bc93beb9fad0c6d Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:08:57 -0700 Subject: [PATCH 078/109] types: Add delta_discrete field of wlr_event_pointer_axis. --- lib/event_pointer_axis.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml index 72851e7..63bc403 100644 --- a/lib/event_pointer_axis.ml +++ b/lib/event_pointer_axis.ml @@ -10,3 +10,4 @@ include Ptr let orientation = getfield Types.Event_pointer_axis.orientation let delta = getfield Types.Event_pointer_axis.delta +let delta_discrete = getfield Types.Event_pointer_axis.delta_discrete diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c2ccef2..c819efe 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -222,6 +222,7 @@ module Event_pointer_axis : sig val orientation : t -> Pointer.axis_orientation val delta : t -> float + val delta_discrete : t -> Signed.Int32.t end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index bd3e222..8ca5309 100644 --- a/types/types.ml +++ b/types/types.ml @@ -257,6 +257,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let orientation = field t "orientation" Axis_orientation.t let delta = field t "delta" double + let delta_discrete = field t "delta_discrete" int32_t let () = seal t end From 743196f92f56754a88fa84c82a3f65d232dd4224 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:10:32 -0700 Subject: [PATCH 079/109] types: Add source field of wlr_event_pointer_axis. --- lib/event_pointer_axis.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml index 63bc403..9177d07 100644 --- a/lib/event_pointer_axis.ml +++ b/lib/event_pointer_axis.ml @@ -11,3 +11,4 @@ include Ptr let orientation = getfield Types.Event_pointer_axis.orientation let delta = getfield Types.Event_pointer_axis.delta let delta_discrete = getfield Types.Event_pointer_axis.delta_discrete +let source = getfield Types.Event_pointer_axis.source diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c819efe..e4908b8 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -223,6 +223,7 @@ module Event_pointer_axis : sig val orientation : t -> Pointer.axis_orientation val delta : t -> float val delta_discrete : t -> Signed.Int32.t + val source : t -> Pointer.axis_source end module Renderer : sig diff --git a/types/types.ml b/types/types.ml index 8ca5309..102f775 100644 --- a/types/types.ml +++ b/types/types.ml @@ -258,6 +258,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let orientation = field t "orientation" Axis_orientation.t let delta = field t "delta" double let delta_discrete = field t "delta_discrete" int32_t + let source = field t "source" Axis_source.t let () = seal t end From 71d4e5a42502cd078fcd5fcc2070bc42b26d59a4 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:14:10 -0700 Subject: [PATCH 080/109] ffi: Add wlr_seat_pointer_notify_axis. --- ffi/ffi.ml | 9 +++++++++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 14 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 64cff1e..1762b91 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -343,6 +343,15 @@ struct let wlr_seat_pointer_notify_button = foreign "wlr_seat_pointer_notify_button" (wlr_seat_p @-> uint32_t @-> uint32_t @-> Button_state.t @-> returning uint32_t) + let wlr_seat_pointer_notify_axis = foreign "wlr_seat_pointer_notify_axis" + (wlr_seat_p + @-> uint32_t + @-> Axis_orientation.t + @-> double + @-> int32_t + @-> Axis_source.t + @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index d9e8d5a..a472a4f 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -94,3 +94,6 @@ let pointer_notify_motion = let pointer_notify_button = Bindings.wlr_seat_pointer_notify_button + +let pointer_notify_axis = + Bindings.wlr_seat_pointer_notify_axis diff --git a/lib/wlroots.mli b/lib/wlroots.mli index e4908b8..4d3f59a 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -384,6 +384,8 @@ module Seat : sig t -> Unsigned.uint32 -> float -> float -> unit val pointer_notify_button : t -> Unsigned.uint32 -> Unsigned.uint32 -> Pointer.button_state -> Unsigned.uint32 + val pointer_notify_axis : + t -> Unsigned.uint32 -> Pointer.axis_orientation -> float -> Signed.Int32.t -> Pointer.axis_source -> unit end module Log : sig From d09affec31e4fee28ecd44c208f819b2faa02b3a Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:17:40 -0700 Subject: [PATCH 081/109] types: Add field time_msec of wlr_event_pointer_axis. --- lib/event_pointer_axis.ml | 1 + lib/wlroots.mli | 1 + types/types.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/lib/event_pointer_axis.ml b/lib/event_pointer_axis.ml index 9177d07..95aa3ec 100644 --- a/lib/event_pointer_axis.ml +++ b/lib/event_pointer_axis.ml @@ -8,6 +8,7 @@ type t = Types.Event_pointer_axis.t ptr let t = ptr Types.Event_pointer_axis.t include Ptr +let time_msec = getfield Types.Event_pointer_axis.time_msec let orientation = getfield Types.Event_pointer_axis.orientation let delta = getfield Types.Event_pointer_axis.delta let delta_discrete = getfield Types.Event_pointer_axis.delta_discrete diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 4d3f59a..7da8284 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -220,6 +220,7 @@ end module Event_pointer_axis : sig include Comparable0 + val time_msec : t -> Unsigned.uint32 val orientation : t -> Pointer.axis_orientation val delta : t -> float val delta_discrete : t -> Signed.Int32.t diff --git a/types/types.ml b/types/types.ml index 102f775..0274123 100644 --- a/types/types.ml +++ b/types/types.ml @@ -255,6 +255,7 @@ module Make (S : Cstubs_structs.TYPE) = struct type t = [`event_pointer_axis] Ctypes.structure let t : t typ = structure "wlr_event_pointer_axis" + let time_msec = field t "time_msec" uint32_t let orientation = field t "orientation" Axis_orientation.t let delta = field t "delta" double let delta_discrete = field t "delta_discrete" int32_t From 3010ad20f03ac3e4ceb5dc930a6bcd6b105f390d Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:19:53 -0700 Subject: [PATCH 082/109] tinywl: Finish server_cursor_axis. --- tinywl/tinywl.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index fabcbe1..6a383fb 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -264,8 +264,14 @@ let server_cursor_button st _ (evt: Event_pointer_button.t) = (Xdg_surface.from_surface surf)) found_view -let server_cursor_axis _st _ _ = - failwith "server_cursor_axis" +let server_cursor_axis st _ (evt : Event_pointer_axis.t) = + Seat.pointer_notify_axis + st.seat + (Event_pointer_axis.time_msec evt) + (Event_pointer_axis.orientation evt) + (Event_pointer_axis.delta evt) + (Event_pointer_axis.delta_discrete evt) + (Event_pointer_axis.source evt) let server_cursor_frame _st _ _ = failwith "server_cursor_frame" From ad2500ea179ed9549b755bebc4f63903bbf5670f Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:23:46 -0700 Subject: [PATCH 083/109] ffi: Add wlr_seat_pointer_notify_frame. --- ffi/ffi.ml | 3 +++ lib/seat.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 8 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 1762b91..f7f6323 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -352,6 +352,9 @@ struct @-> Axis_source.t @-> returning void) + let wlr_seat_pointer_notify_frame = foreign "wlr_seat_pointer_notify_frame" + (wlr_seat_p @-> returning void) + (* wlr_log *) (* TODO *) diff --git a/lib/seat.ml b/lib/seat.ml index a472a4f..3db17e9 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -97,3 +97,6 @@ let pointer_notify_button = let pointer_notify_axis = Bindings.wlr_seat_pointer_notify_axis + +let pointer_notify_frame = + Bindings.wlr_seat_pointer_notify_frame diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 7da8284..28048c7 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -387,6 +387,8 @@ module Seat : sig t -> Unsigned.uint32 -> Unsigned.uint32 -> Pointer.button_state -> Unsigned.uint32 val pointer_notify_axis : t -> Unsigned.uint32 -> Pointer.axis_orientation -> float -> Signed.Int32.t -> Pointer.axis_source -> unit + val pointer_notify_frame : + t -> unit end module Log : sig From 248451cd5246f43ae714a4e7523a09a92608a195 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:24:34 -0700 Subject: [PATCH 084/109] tinywl: Finish server_cursor_frame. --- tinywl/tinywl.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 6a383fb..50ed059 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -273,8 +273,8 @@ let server_cursor_axis st _ (evt : Event_pointer_axis.t) = (Event_pointer_axis.delta_discrete evt) (Event_pointer_axis.source evt) -let server_cursor_frame _st _ _ = - failwith "server_cursor_frame" +let server_cursor_frame st _ _ = + Seat.pointer_notify_frame st.seat let handle_keybinding st sym = if sym == Xkbcommon.Keysyms._Escape From 704faace117d58372e8f2a99263f6da26ba19707 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:33:24 -0700 Subject: [PATCH 085/109] tiny: Make view.mapped = true when xdg_surface mapped event happens. * Remove listener from focus_event. --- tinywl/tinywl.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 50ed059..deb9256 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -84,7 +84,7 @@ let server_new_output st _ output = let begin_interactive _st (_view: view) (_mode: cursor_mode) = print_endline "Begin interactive" -let focus_view st view _listener surf = +let focus_view st view surf = let keyboard_state = Seat.keyboard_state st.seat in let prev_surface = Seat.Keyboard_state.focused_surface keyboard_state in let to_deactivate = @@ -134,7 +134,9 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = (* Might need to make mapped true in this guy *) Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (focus_view st view) ; + (fun _ _ -> + view.mapped <- true; + focus_view st view surf); Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener (fun _ _ -> view.mapped <- false;); @@ -260,8 +262,7 @@ let server_cursor_button st _ (evt: Event_pointer_button.t) = else let found_view = desktop_view_at st.cursor st.views in Option.iter (fun (view, surf, _, _) -> - Option.iter (fun xdg_surf -> focus_view st view () xdg_surf) - (Xdg_surface.from_surface surf)) + Option.iter (focus_view st view) (Xdg_surface.from_surface surf)) found_view let server_cursor_axis st _ (evt : Event_pointer_axis.t) = @@ -287,7 +288,7 @@ let handle_keybinding st sym = | [] -> true | [_] -> true | (x :: y :: xs) -> - let () = focus_view st y y.listener y.surface in + let () = focus_view st y y.surface in st.views <- y :: List.append xs [x]; true else false From b95bc3c862c825b1cbca9a71c63d151f9e0a0f0e Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 16 May 2021 18:38:23 -0700 Subject: [PATCH 086/109] tinywl: Create more descriptive failwiths. * Change print_endline back to failwith --- tinywl/tinywl.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index deb9256..500d241 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -61,7 +61,7 @@ let default_xkb_rules : Xkbcommon.Rule_names.t = { } let output_frame _st _ _ = - failwith "todo" + failwith "output_frame" let server_new_output st _ output = let output_ok = @@ -82,7 +82,7 @@ let server_new_output st _ output = end let begin_interactive _st (_view: view) (_mode: cursor_mode) = - print_endline "Begin interactive" + failwith "begin_interactive" let focus_view st view surf = let keyboard_state = Seat.keyboard_state st.seat in From 8e3a5f0c66eec53a86c281a61a29c5b66a81f2ec Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 23 May 2021 12:09:55 -0700 Subject: [PATCH 087/109] ffi: Add wlr_output_effective_resolution. --- ffi/ffi.ml | 3 +++ lib/output.ml | 6 ++++++ lib/wlroots.mli | 2 ++ 3 files changed, 11 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index f7f6323..b44bd5a 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -130,6 +130,9 @@ struct let wlr_output_enable = foreign "wlr_output_enable" (wlr_output_p @-> bool @-> returning void) + let wlr_output_effective_resolution = foreign "wlr_output_effective_resolution" + (wlr_output_p @-> ptr int @-> ptr int @-> returning void) + (* wlr_output_layout *) let wlr_output_layout_p = ptr Output_layout.t diff --git a/lib/output.ml b/lib/output.ml index 74545b3..7b7d76e 100644 --- a/lib/output.ml +++ b/lib/output.ml @@ -53,3 +53,9 @@ let commit (output : t): bool = Bindings.wlr_output_commit output let enable = Bindings.wlr_output_enable + +let effective_resolution (output: t) : int * int = + let width = allocate int 0 in + let height = allocate int 0 in + Bindings.wlr_output_effective_resolution output width height; + (!@ width, !@ height) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 28048c7..be20f17 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -101,6 +101,8 @@ module Output : sig val commit : t -> bool val enable : t -> bool -> unit + val effective_resolution : t -> int * int + val signal_frame : t -> t Wl.Signal.t val signal_destroy : t -> t Wl.Signal.t end From a565a8f3e07a7f958b350c607a81e009a9353570 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 15:29:46 -0700 Subject: [PATCH 088/109] types: Add wlr_surface_iterator_func_t. --- types/types.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/types/types.ml b/types/types.ml index 0274123..0c3d8de 100644 --- a/types/types.ml +++ b/types/types.ml @@ -80,6 +80,10 @@ module Make (S : Cstubs_structs.TYPE) = struct let pending = field t "pending" (ptr Surface_state.t) (* TODO *) let () = seal t + + type wlr_surface_iterator_func_t = t ptr -> int -> int -> unit ptr -> unit + let wlr_surface_iterator_func_t: wlr_surface_iterator_func_t typ = + lift_typ (Foreign.funptr (ptr t @-> int @-> int @-> ptr void @-> returning void)) end module Box = struct From 0b8b28bd7ca319b9e7bc0df208c5937ae5a38894 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 15:31:04 -0700 Subject: [PATCH 089/109] ffi: Add wlr_xdg_surface_for_each_surface. --- ffi/ffi.ml | 3 +++ lib/wlroots.mli | 1 + lib/xdg_surface.ml | 3 +++ 3 files changed, 7 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index b44bd5a..2531336 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -256,6 +256,9 @@ struct let wlr_xdg_surface_surface_at = foreign "wlr_xdg_surface_surface_at" (wlr_xdg_surface_p @-> double @-> double @-> ptr double @-> ptr double @-> returning wlr_surface_p) + let wlr_xdg_surface_for_each_surface = foreign "wlr_xdg_surface_for_each_surface" + (wlr_xdg_surface_p @-> Surface.wlr_surface_iterator_func_t @-> ptr void @-> returning void) + (* wlr_xdg_toplevel *) let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated" diff --git a/lib/wlroots.mli b/lib/wlroots.mli index be20f17..c60405c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -288,6 +288,7 @@ module Xdg_surface : sig val toplevel_set_activated : t -> bool -> Unsigned.uint32 val toplevel_set_size : t -> int -> int -> Unsigned.uint32 val surface_at : t -> float -> float -> (Surface.t * float * float) option + val for_each_surface : t -> (Surface.t -> int -> int -> unit) -> unit module Events : sig val destroy : t -> t Wl.Signal.t diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 1186e7e..5f94fc5 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -46,6 +46,9 @@ let toplevel_set_activated = let toplevel_set_size = Bindings.wlr_xdg_toplevel_set_size +let for_each_surface (surf : t) (f : Surface.t -> int -> int -> unit) = + Bindings.wlr_xdg_surface_for_each_surface surf (fun s x y _ -> f s x y) null + module Events = struct let destroy (surface : t) : t Wl.Signal.t = { c = surface |-> Types.Xdg_surface.events_destroy; From 880999f88b5cac30fb7ca5e5425955485c498877 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 15:50:25 -0700 Subject: [PATCH 090/109] ffi: Add wlr_surface_get_texture. --- ffi/ffi.ml | 3 +++ lib/surface.ml | 6 ++++++ lib/wlroots.mli | 1 + 3 files changed, 10 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 2531336..018d8a5 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -172,6 +172,9 @@ struct let wlr_surface_send_frame_done = foreign "wlr_surface_send_frame_done" (wlr_surface_p @-> time @-> returning void) + let wlr_surface_get_texture = foreign "wlr_surface_get_texture" + (wlr_surface_p @-> returning wlr_texture_p) + (* wlr_renderer *) let wlr_renderer_p = ptr Renderer.t diff --git a/lib/surface.ml b/lib/surface.ml index 22b48e0..62ba144 100644 --- a/lib/surface.ml +++ b/lib/surface.ml @@ -23,3 +23,9 @@ let current = getfield Types.Surface.current let pending = getfield Types.Surface.pending let send_frame_done = Bindings.wlr_surface_send_frame_done + +let get_texture surf = + let t = Bindings.wlr_surface_get_texture surf in + if is_null t + then None + else Some t diff --git a/lib/wlroots.mli b/lib/wlroots.mli index c60405c..90dde72 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -66,6 +66,7 @@ module Surface : sig val current : t -> State.t val pending : t -> State.t val send_frame_done : t -> Mtime.t -> unit + val get_texture : t -> Texture.t option end module Box : sig From 4b8dbf5b2c3da9eb71b95edee73a1f9b9eac4624 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 16:05:06 -0700 Subject: [PATCH 091/109] ffi: Add wlr_output_layout_output_coords. --- ffi/ffi.ml | 3 +++ lib/output_layout.ml | 6 ++++++ lib/wlroots.mli | 1 + 3 files changed, 10 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 018d8a5..df60513 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -143,6 +143,9 @@ struct let wlr_output_layout_add_auto = foreign "wlr_output_layout_add_auto" (wlr_output_layout_p @-> wlr_output_p @-> returning void) + let wlr_output_layout_output_coords = foreign "wlr_output_layout_output_coords" + (wlr_output_layout_p @-> wlr_output_p @-> ptr double @-> ptr double @-> returning void) + (* wlr_box *) let wlr_box_p = ptr Box.t diff --git a/lib/output_layout.ml b/lib/output_layout.ml index 837fe73..1165f0d 100644 --- a/lib/output_layout.ml +++ b/lib/output_layout.ml @@ -9,3 +9,9 @@ include Ptr let create = Bindings.wlr_output_layout_create let add_auto = Bindings.wlr_output_layout_add_auto + +let output_coords layout output x y = + let lx = allocate double x in + let ly = allocate double y in + Bindings.wlr_output_layout_output_coords layout output lx ly; + (!@ lx, !@ ly) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 90dde72..b107d26 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -113,6 +113,7 @@ module Output_layout : sig val create : unit -> t val add_auto : t -> Output.t -> unit + val output_coords : t -> Output.t -> float -> float -> float * float end module Keycodes : sig From c36922b368e21ddaf34b5907c90026312a822794 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 16:39:18 -0700 Subject: [PATCH 092/109] types: Add wlr_output.scale. --- lib/output.ml | 2 ++ lib/wlroots.mli | 2 ++ types/types.ml | 1 + 3 files changed, 5 insertions(+) diff --git a/lib/output.ml b/lib/output.ml index 7b7d76e..1296e02 100644 --- a/lib/output.ml +++ b/lib/output.ml @@ -54,6 +54,8 @@ let commit (output : t): bool = let enable = Bindings.wlr_output_enable +let scale = getfield Types.Output.scale + let effective_resolution (output: t) : int * int = let width = allocate int 0 in let height = allocate int 0 in diff --git a/lib/wlroots.mli b/lib/wlroots.mli index b107d26..e952ede 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -96,6 +96,8 @@ module Output : sig val set_mode : t -> Mode.t -> unit val preferred_mode : t -> Mode.t option + val scale : t -> float + val transform_matrix : t -> Matrix.t val create_global : t -> unit val attach_render : t -> bool diff --git a/types/types.ml b/types/types.ml index 0c3d8de..644d6dd 100644 --- a/types/types.ml +++ b/types/types.ml @@ -112,6 +112,7 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_output" let modes = field t "modes" Wl_list.t + let scale = field t "scale" double let current_mode = field t "current_mode" (ptr Output_mode.t) let events_destroy = field t "events.destroy" Wl_signal.t let events_frame = field t "events.frame" Wl_signal.t From 38a0a81ae66d9f0819cb5673e48ff33c9adc128a Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 17:10:11 -0700 Subject: [PATCH 093/109] types: Define enum for wl_output_transform. --- ffi/ffi.ml | 4 ++++ lib/output.ml | 2 ++ lib/wl.ml | 5 ----- lib/wlroots.mli | 9 +++------ types/types.ml | 29 ++++++++++++++++++++++++++--- 5 files changed, 35 insertions(+), 14 deletions(-) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index df60513..5c7a745 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -104,6 +104,10 @@ struct let wl_resource_p = ptr Wl_resource.t + (* wl_output_transform *) + + let wl_output_transform = Wl_output_transform.t + (* wlr_output_mode *) let wlr_output_mode_p = ptr Output_mode.t diff --git a/lib/output.ml b/lib/output.ml index 1296e02..5e5dfec 100644 --- a/lib/output.ml +++ b/lib/output.ml @@ -61,3 +61,5 @@ let effective_resolution (output: t) : int * int = let height = allocate int 0 in Bindings.wlr_output_effective_resolution output width height; (!@ width, !@ height) + +type transform = Types.Wl_output_transform.transform diff --git a/lib/wl.ml b/lib/wl.ml index 3cedaf8..1a8ff71 100644 --- a/lib/wl.ml +++ b/lib/wl.ml @@ -115,11 +115,6 @@ module Resource = struct include Ptr end -module Output_transform = struct - type t = Types.Wl_output_transform.t - include Poly -end - module Seat_capability = struct type cap = Pointer | Keyboard | Touch type t = cap list diff --git a/lib/wlroots.mli b/lib/wlroots.mli index e952ede..bcc8d5e 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -36,10 +36,6 @@ module Wl : sig include Comparable0 end - module Output_transform : sig - include Comparable0 - end - module Seat_capability : sig type cap = Pointer | Keyboard | Touch include Comparable0 with type t = cap list @@ -60,7 +56,7 @@ module Surface : sig include Comparable0 val width : t -> int val height : t -> int - val transform : t -> Wl.Output_transform.t + val transform : t -> Output.transform end val current : t -> State.t @@ -76,10 +72,11 @@ end module Matrix : sig include Comparable0 - val project_box : Box.t -> Wl.Output_transform.t -> rotation:float -> t -> t + val project_box : Box.t -> Output.transform -> rotation:float -> t -> t end module Output : sig + type transform = Wlroots_ffi_f.Ffi.Types.Wl_output_transform.transform include Comparable0 module Mode : sig diff --git a/types/types.ml b/types/types.ml index 644d6dd..29540b0 100644 --- a/types/types.ml +++ b/types/types.ml @@ -40,9 +40,32 @@ module Make (S : Cstubs_structs.TYPE) = struct end module Wl_output_transform = struct - (* FIXME *) - type t = int64 - let t : t typ = int64_t + type transform = Ninety + | OneEighty + | TwoSeventy + | Flipped + | FlippedNinety + | FlippedOneEighty + | FlippedTwoSeventy + + type t = [`wl_output_transform] Ctypes.structure + let _WL_OUTPUT_TRANSFORM_90 = constant "WL_OUTPUT_TRANSFORM_90" int64_t (* 1 *) + let _WL_OUTPUT_TRANSFORM_180 = constant "WL_OUTPUT_TRANSFORM_180" int64_t (* 2 *) + let _WL_OUTPUT_TRANSFORM_270 = constant "WL_OUTPUT_TRANSFORM_270" int64_t (* 3 *) + let _WL_OUTPUT_TRANSFORM_FLIPPED = constant "WL_OUTPUT_TRANSFORM_FLIPPED" int64_t (* 4 *) + let _WL_OUTPUT_TRANSFORM_FLIPPED_90 = constant "WL_OUTPUT_TRANSFORM_FLIPPED_90" int64_t (* 5 *) + let _WL_OUTPUT_TRANSFORM_FLIPPED_180 = constant "WL_OUTPUT_TRANSFORM_FLIPPED_180" int64_t (* 6 *) + let _WL_OUTPUT_TRANSFORM_FLIPPED_270 = constant "WL_OUTPUT_TRANSFORM_FLIPPED_270" int64_t (* 7 *) + + let t : transform typ = enum "wl_output_transform" [ + Ninety, _WL_OUTPUT_TRANSFORM_90; + OneEighty, _WL_OUTPUT_TRANSFORM_180; + TwoSeventy, _WL_OUTPUT_TRANSFORM_270; + Flipped, _WL_OUTPUT_TRANSFORM_FLIPPED; + FlippedNinety, _WL_OUTPUT_TRANSFORM_FLIPPED_90; + FlippedOneEighty, _WL_OUTPUT_TRANSFORM_FLIPPED_180; + FlippedTwoSeventy, _WL_OUTPUT_TRANSFORM_FLIPPED_270; + ] end module Wl_seat_capability = struct From 7504fe961bb9cc18f312b3ec9cc510a70a01e426 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 21:15:14 -0700 Subject: [PATCH 094/109] ffi: Add wlr_output_transform_invert. --- ffi/ffi.ml | 3 +++ lib/output.ml | 2 ++ lib/wlroots.mli | 2 ++ 3 files changed, 7 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 5c7a745..d60d362 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -137,6 +137,9 @@ struct let wlr_output_effective_resolution = foreign "wlr_output_effective_resolution" (wlr_output_p @-> ptr int @-> ptr int @-> returning void) + let wlr_output_transform_invert = foreign "wlr_output_transform_invert" + (wl_output_transform @-> returning wl_output_transform) + (* wlr_output_layout *) let wlr_output_layout_p = ptr Output_layout.t diff --git a/lib/output.ml b/lib/output.ml index 5e5dfec..21f7495 100644 --- a/lib/output.ml +++ b/lib/output.ml @@ -63,3 +63,5 @@ let effective_resolution (output: t) : int * int = (!@ width, !@ height) type transform = Types.Wl_output_transform.transform + +let transform_invert = Bindings.wlr_output_transform_invert diff --git a/lib/wlroots.mli b/lib/wlroots.mli index bcc8d5e..13b503d 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -105,6 +105,8 @@ module Output : sig val signal_frame : t -> t Wl.Signal.t val signal_destroy : t -> t Wl.Signal.t + + val transform_invert : transform -> transform end module Output_layout : sig From 03bd56682a3bdb3099b2e97d984380073fe2b65a Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 21:56:57 -0700 Subject: [PATCH 095/109] ffi: Add wlr_renderer_render_texture_with_matrix. --- ffi/ffi.ml | 3 +++ lib/renderer.ml | 3 +++ lib/wlroots.mli | 1 + 3 files changed, 7 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index d60d362..6ec4cf6 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -201,6 +201,9 @@ struct let wlr_renderer_init_wl_display = foreign "wlr_renderer_init_wl_display" (wlr_renderer_p @-> wl_display_p @-> returning bool) + let wlr_render_texture_with_matrix = foreign "wlr_render_texture_with_matrix" + (wlr_renderer_p @-> wlr_texture_p @-> ptr double @-> double @-> returning bool) + (* wlr_keyboard *) let wlr_keyboard_p = ptr Keyboard.t diff --git a/lib/renderer.ml b/lib/renderer.ml index 53a3f08..1aa9469 100644 --- a/lib/renderer.ml +++ b/lib/renderer.ml @@ -18,3 +18,6 @@ let clear (renderer : t) ((c1,c2,c3,c4) : float * float * float * float) = Bindings.wlr_renderer_clear renderer (CArray.start color_arr) let init_wl_display = Bindings.wlr_renderer_init_wl_display + +let render_texture_with_matrix renderer texture matrix alpha = + Bindings.wlr_render_texture_with_matrix renderer texture matrix alpha diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 13b503d..faca075 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -239,6 +239,7 @@ module Renderer : sig val end_ : t -> unit val clear : t -> float * float * float * float -> unit val init_wl_display : t -> Wl.Display.t -> bool + val render_texture_with_matrix : t -> Texture.t -> Matrix.t -> float -> bool end module Backend : sig From d8971b8031504e3727a02e7f25941bbdd66d9d68 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 22:20:51 -0700 Subject: [PATCH 096/109] ffi: Add wlr_output_render_software_cursors. wlr_output_render_software_cursors requires libpixman which has no ocaml bindings yet. However this is ok for now, since only tinywl.ml is using it. Some minimal attempts at adding bindings for pixman should be taken soon to make this ok. --- ffi/ffi.ml | 5 +++++ lib/output.ml | 3 +++ lib/wlroots.mli | 2 ++ 3 files changed, 10 insertions(+) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 6ec4cf6..786ecc3 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -140,6 +140,11 @@ struct let wlr_output_transform_invert = foreign "wlr_output_transform_invert" (wl_output_transform @-> returning wl_output_transform) + let wlr_output_render_software_cursors = foreign "wlr_output_render_software_cursors" + (* FIXME: The void pointer is a pixman_region32_t for which no bindings exist (yet). + This is only ok because so far, no one uses it. *) + (wlr_output_p @-> ptr void @-> returning void) + (* wlr_output_layout *) let wlr_output_layout_p = ptr Output_layout.t diff --git a/lib/output.ml b/lib/output.ml index 21f7495..f4c9d96 100644 --- a/lib/output.ml +++ b/lib/output.ml @@ -65,3 +65,6 @@ let effective_resolution (output: t) : int * int = type transform = Types.Wl_output_transform.transform let transform_invert = Bindings.wlr_output_transform_invert + +let render_software_cursors output = + Bindings.wlr_output_render_software_cursors output null diff --git a/lib/wlroots.mli b/lib/wlroots.mli index faca075..89b9594 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -107,6 +107,8 @@ module Output : sig val signal_destroy : t -> t Wl.Signal.t val transform_invert : transform -> transform + + val render_software_cursors : t -> unit end module Output_layout : sig From 41ea0e4e07db360966d0e6c73b7f2e26c9625812 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 15:44:06 -0700 Subject: [PATCH 097/109] tinywl: Finish output_frame. * Adds render_frame as subroutine of output_frame --- tinywl/tinywl.ml | 41 ++++++++++++++++++++++++++++++++++++++--- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 500d241..3a4274d 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -60,8 +60,43 @@ let default_xkb_rules : Xkbcommon.Rule_names.t = { options = None; } -let output_frame _st _ _ = - failwith "output_frame" +let render_surface st output (view : view) when_ surf sx sy = + match Surface.get_texture surf with + | None -> () + | Some texture -> + let (ox', oy') : float * float = Output_layout.output_coords st.output_layout output 0.0 0.0 in + let ox = Float.(add ox' (of_int (view.x + sx))) in + let oy = Float.(add oy' (of_int (view.y + sy))) in + let scale = Output.scale output in + let current = Surface.current surf in + let box: Box.t = { + x = Float.(to_int (mul ox scale)); + y = Float.(to_int (mul oy scale)); + width = truncate Float.(mul (of_int (Surface.State.width current)) scale); + height = truncate Float.(mul (of_int (Surface.State.height current)) scale); + } in + let transform = Output.transform_invert Surface.(State.transform (current surf)) in + let matrix = Matrix.project_box box transform ~rotation:0.0 (Output.transform_matrix output) in + discard (Renderer.render_texture_with_matrix st.renderer texture matrix 1.0); + Surface.send_frame_done surf when_ + +let output_frame st output _ _ = + let now = Mtime_clock.now () in + if not (Output.attach_render output) + then () + else + let (w, h) = Output.effective_resolution output in + Renderer.begin_ st.renderer ~width:w ~height:h; + Renderer.clear st.renderer (0.3, 0.3, 0.3, 1.0); + List.iter (fun view -> + if not view.mapped + then () + else Xdg_surface.for_each_surface view.surface + (render_surface st output view now) + ) (List.rev st.views); + Output.render_software_cursors output; + Renderer.end_ st.renderer; + discard (Output.commit output) let server_new_output st _ output = let output_ok = @@ -74,7 +109,7 @@ let server_new_output st _ output = in if output_ok then begin let o = { output; frame = Wl.Listener.create () } in - Wl.Signal.add (Output.signal_frame output) o.frame (output_frame st); + Wl.Signal.add (Output.signal_frame output) o.frame (output_frame st output); st.outputs <- o :: st.outputs; Output_layout.add_auto st.output_layout output; From c0a8c27eb4e140822ffde9c4cbf84c87d682e230 Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 26 May 2021 03:48:11 -0700 Subject: [PATCH 098/109] utils: Add bitwise_enum32. Edges are used in 32bit fashion. This could be changed since I do not know if they can be coerced safely to 64 bits. --- common/utils.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/common/utils.ml b/common/utils.ml index 73eb088..9452397 100644 --- a/common/utils.ml +++ b/common/utils.ml @@ -31,6 +31,23 @@ let bitwise_enum desc = in view ~read ~write uint64_t +let bitwise_enum32 desc = + let open Unsigned.UInt32 in + let open Infix in + let read i = + List.filter_map (fun (x, cst) -> + if (i land cst) <> zero then + Some x + else None + ) desc + in + let write items = + List.fold_left (fun i item -> + (List.assoc item desc) lor i + ) zero items + in + view ~read ~write uint32_t + module Ptr = struct let compare = ptr_compare let hash = ptr_hash From 57bcbf942c1f5136b2be63c0a56ba3029a0775c1 Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 26 May 2021 00:31:12 -0700 Subject: [PATCH 099/109] types: Swaps Edges.t from enum to bitwise_enum32 --- lib/edges.ml | 17 ++++++++++++++--- lib/wlroots.mli | 3 ++- tinywl/tinywl.ml | 18 ++++++++++-------- types/types.ml | 24 ++++++++---------------- 4 files changed, 34 insertions(+), 28 deletions(-) diff --git a/lib/edges.ml b/lib/edges.ml index edab017..2925ee6 100644 --- a/lib/edges.ml +++ b/lib/edges.ml @@ -1,7 +1,18 @@ -(* open Ctypes *) -(* open Wlroots_common.Utils *) +open Ctypes +open Wlroots_common.Utils module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) module Types = Wlroots_ffi_f.Ffi.Types -type t = Types.Edges.t = None | Top | Bottom | Left | Right +type edges = None | Top | Bottom | Left | Right +type t = edges list +include Poly + +let t : edges list typ = + bitwise_enum32 Types.Edges.([ + None, _WLR_EDGE_NONE; + Top, _WLR_EDGE_TOP; + Bottom, _WLR_EDGE_BOTTOM; + Right, _WLR_EDGE_RIGHT; + Left, _WLR_EDGE_LEFT; + ]) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 89b9594..463e097 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -165,7 +165,8 @@ module Pointer : sig end module Edges : sig - type t = None | Top | Bottom | Left | Right + type edges = None | Top | Bottom | Left | Right + include Comparable0 with type t = edges list end module Touch : sig diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 3a4274d..fe94efb 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -199,36 +199,38 @@ let process_cursor_resize st _time = let border_y = Float.sub (Cursor.y st.cursor) grab.y in let (new_top, new_bottom) = - match grab.resize_edges with - | Edges.Top -> + if List.exists ((==) Edges.Top) grab.resize_edges + then let new_top = border_y in let new_bottom = grab.geobox.y + grab.geobox.height in if new_top >= Float.of_int new_bottom then (new_bottom - 1, new_bottom) else (truncate new_top, new_bottom) - | Edges.Bottom -> + else if List.exists ((==) Edges.Bottom) grab.resize_edges + then let new_top = grab.geobox.y in let new_bottom = border_y in if new_bottom <= Float.of_int new_top then (new_top, new_top + 1) else (new_top, truncate new_bottom) - | _ -> (grab.geobox.y, grab.geobox.y + grab.geobox.height) + else (grab.geobox.y, grab.geobox.y + grab.geobox.height) in let (new_left, new_right) = - match grab.resize_edges with - | Edges.Left -> + if List.exists ((==) Edges.Left) grab.resize_edges + then let new_left = border_x in let new_right = grab.geobox.x + grab.geobox.width in if new_left >= Float.of_int new_right then (new_right - 1, new_right) else (truncate new_left, new_right) - | Edges.Right -> + else if List.exists ((==) Edges.Right) grab.resize_edges + then let new_left = grab.geobox.x in let new_right = border_x in if new_right <= Float.of_int new_left then (new_left, new_left + 1) else (new_left, truncate new_right) - | _ -> (grab.geobox.x, grab.geobox.x + grab.geobox.width) in + else (grab.geobox.x, grab.geobox.x + grab.geobox.width) in let geobox = Xdg_surface.get_geometry view.surface in view.x <- new_left - geobox.x; diff --git a/types/types.ml b/types/types.ml index 29540b0..7ac2954 100644 --- a/types/types.ml +++ b/types/types.ml @@ -292,22 +292,14 @@ module Make (S : Cstubs_structs.TYPE) = struct end module Edges = struct - type t = None | Top | Bottom | Left | Right - - let _WLR_EDGE_NONE = constant "WLR_EDGE_NONE" int64_t - let _WLR_EDGE_TOP = constant "WLR_EDGE_TOP" int64_t - let _WLR_EDGE_BOTTOM = constant "WLR_EDGE_BOTTOM" int64_t - let _WLR_EDGE_LEFT = constant "WLR_EDGE_LEFT" int64_t - let _WLR_EDGE_RIGHT = constant "WLR_EDGE_RIGHT" int64_t - - let t : t typ = - enum "wlr_edges" [ - None, _WLR_EDGE_NONE; - Top, _WLR_EDGE_TOP; - Bottom, _WLR_EDGE_BOTTOM; - Left, _WLR_EDGE_LEFT; - Right, _WLR_EDGE_RIGHT; - ] + type t = Unsigned.uint32 + let t : t typ = uint32_t + + let _WLR_EDGE_NONE = constant "WLR_EDGE_NONE" uint32_t + let _WLR_EDGE_TOP = constant "WLR_EDGE_TOP" uint32_t + let _WLR_EDGE_BOTTOM = constant "WLR_EDGE_BOTTOM" uint32_t + let _WLR_EDGE_LEFT = constant "WLR_EDGE_LEFT" uint32_t + let _WLR_EDGE_RIGHT = constant "WLR_EDGE_RIGHT" uint32_t end module Touch = struct From 55bcc658f68fdd76c076062d419ad1e814f657cf Mon Sep 17 00:00:00 2001 From: John Soo Date: Wed, 26 May 2021 03:52:58 -0700 Subject: [PATCH 100/109] types: Add xdg_toplevel_move_event and xdg_toplevel_resize_event. --- lib/wlroots.mli | 25 ++++++++++++++++++++----- lib/xdg_surface.ml | 6 ++---- lib/xdg_toplevel.ml | 28 ++++++++++++++++++++++++---- types/types.ml | 27 +++++++++++++++++++++++++-- 4 files changed, 71 insertions(+), 15 deletions(-) diff --git a/lib/wlroots.mli b/lib/wlroots.mli index 463e097..ec65979 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -273,16 +273,31 @@ module Compositor : sig val create : Wl.Display.t -> Renderer.t -> t end -module Xdg_toplevel: sig +module rec Xdg_toplevel: sig include Comparable0 module Events: sig - val request_move : t -> t Wl.Signal.t - val request_resize : t -> t Wl.Signal.t + module Move : sig + type t + val surface : t -> Xdg_surface.t + val seat : t -> Seat.t + val serial : t -> Unsigned.UInt32.t + end + + module Resize : sig + type t + val surface : t -> Xdg_surface.t + val seat : t -> Seat.t + val serial : t -> Unsigned.UInt32.t + val edges : t -> Edges.t + end + + val request_move : t -> Move.t Wl.Signal.t + val request_resize : t -> Resize.t Wl.Signal.t end end -module Xdg_surface : sig +and Xdg_surface : sig include Comparable0 type role = Wlroots_ffi_f.Ffi.Types.Xdg_surface_role.role @@ -309,7 +324,7 @@ module Xdg_surface : sig end end -module Xdg_shell : sig +and Xdg_shell : sig include Comparable0 val create : Wl.Display.t -> t diff --git a/lib/xdg_surface.ml b/lib/xdg_surface.ml index 5f94fc5..132eb35 100644 --- a/lib/xdg_surface.ml +++ b/lib/xdg_surface.ml @@ -13,10 +13,8 @@ include Ptr let role (surface : t) : role = surface |->> Types.Xdg_surface.role -let surface (surface : t) : Surface.t = - surface |-> Types.Xdg_surface.surface -let toplevel (surface : t) : Xdg_toplevel.t = - surface |-> Types.Xdg_surface.toplevel +let surface = getfield Types.Xdg_surface.surface +let toplevel = getfield Types.Xdg_surface.toplevel let from_surface (surface : Surface.t) : t option = (* This is not exactly a verbatim binding but it is safer *) diff --git a/lib/xdg_toplevel.ml b/lib/xdg_toplevel.ml index a091a25..bbedff3 100644 --- a/lib/xdg_toplevel.ml +++ b/lib/xdg_toplevel.ml @@ -10,13 +10,33 @@ let t = ptr Types.Xdg_toplevel.t include Ptr module Events = struct - let request_move (toplevel : t) : t Wl.Signal.t = { + module Move = struct + type t = Types.Xdg_toplevel_move_event.t ptr + let t = ptr Types.Xdg_toplevel_move_event.t + + let surface = getfield Types.Xdg_toplevel_move_event.surface + let seat = getfield Types.Xdg_toplevel_move_event.seat + let serial = getfield Types.Xdg_toplevel_move_event.serial + end + + module Resize = struct + type t = Types.Xdg_toplevel_resize_event.t ptr + let t = ptr Types.Xdg_toplevel_resize_event.t + + let surface = getfield Types.Xdg_toplevel_resize_event.surface + let seat = getfield Types.Xdg_toplevel_resize_event.seat + let serial = getfield Types.Xdg_toplevel_resize_event.serial + let edges ev = coerce uint32_t Edges.t + (getfield Types.Xdg_toplevel_resize_event.edges ev) + end + + let request_move (toplevel : t) : Move.t Wl.Signal.t = { c = toplevel |-> Types.Xdg_toplevel.events_request_move; - typ = t; + typ = Move.t; } - let request_resize (toplevel : t) : t Wl.Signal.t = { + let request_resize (toplevel : t) : Resize.t Wl.Signal.t = { c = toplevel |-> Types.Xdg_toplevel.events_request_resize; - typ = t; + typ = Resize.t; } end diff --git a/types/types.ml b/types/types.ml index 7ac2954..343c2f1 100644 --- a/types/types.ml +++ b/types/types.ml @@ -453,8 +453,8 @@ module Make (S : Cstubs_structs.TYPE) = struct let t : t typ = structure "wlr_xdg_surface" let role = field t "role" Xdg_surface_role.t - let surface = field t "surface" Surface.t - let toplevel = field t "toplevel" Xdg_toplevel.t + let surface = field t "surface" (ptr Surface.t) + let toplevel = field t "toplevel" (ptr Xdg_toplevel.t) let events_destroy = field t "events.destroy" Wl_signal.t let events_ping_timeout = field t "events.ping_timeout" Wl_signal.t @@ -534,6 +534,29 @@ module Make (S : Cstubs_structs.TYPE) = struct let () = seal t end + module Xdg_toplevel_move_event = struct + type t = [`xdg_toplevel_move_event] Ctypes.structure + let t : t typ = structure "wlr_xdg_toplevel_move_event" + + let surface = field t "surface" (ptr Xdg_surface.t) + let seat = field t "seat" (ptr Seat.t) + let serial = field t "serial" uint32_t + + let () = seal t + end + + module Xdg_toplevel_resize_event = struct + type t = [`xdg_toplevel_resize_event] Ctypes.structure + let t : t typ = structure "wlr_xdg_toplevel_resize_event" + + let surface = field t "surface" (ptr Xdg_surface.t) + let seat = field t "seat" (ptr Seat.t) + let serial = field t "serial" uint32_t + let edges = field t "edges" Edges.t + + let () = seal t + end + module Seat_pointer_request_set_cursor_event = struct type t = [`seat_pointer_request_set_cursor_event] Ctypes.structure let t : t typ = structure "wlr_seat_pointer_request_set_cursor_event" From 935fb944caf9fdc19f6e4d9b4aac1f5a0be27046 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 22:39:49 -0700 Subject: [PATCH 101/109] tinywl: Finish begin_interactive. * Moves option elimination outside of process_cursor* functions. * Changes grab to have an optional resize field, since resizing and moving are two disjoint states. * Changes Resize cursor_mode paramter to Edges.t --- tinywl/tinywl.ml | 199 ++++++++++++++++++++++++++++------------------- 1 file changed, 117 insertions(+), 82 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index fe94efb..e19a3ce 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -8,12 +8,16 @@ type view = { mutable y: int; } +type resize = { + geobox: Box.t; + edges: Edges.t; +} + type grab = { view: view; x: float; y: float; - geobox: Box.t; - resize_edges: Edges.t; + resize: resize option; } type keyboard = { @@ -30,7 +34,7 @@ type tinywl_output = { type cursor_mode = Passthrough | Move - | Resize of Unsigned.uint32 + | Resize of Edges.t let discard _ = () @@ -49,7 +53,7 @@ type tinywl_server = { new_output : Wl.Listener.t; - grab: grab option; + mutable grab: grab option; } let default_xkb_rules : Xkbcommon.Rule_names.t = { @@ -116,8 +120,39 @@ let server_new_output st _ output = Output.create_global output; end -let begin_interactive _st (_view: view) (_mode: cursor_mode) = - failwith "begin_interactive" +let begin_interactive st view mode = + let focused_surface = Seat.(Pointer_state.focused_surface (pointer_state st.seat)) in + if Xdg_surface.surface view.surface == focused_surface then ( + st.cursor_mode <- mode; + match mode with + | Passthrough -> () + | Move -> + st.grab <- Some { + view = view; + x = Float.(sub (Cursor.x st.cursor) (of_int view.x)); + y = Float.(sub (Cursor.y st.cursor) (of_int view.y)); + resize = None; + } + | Resize edges -> + let geobox = Xdg_surface.get_geometry view.surface in + let border_x = + view.x + geobox.x + ( + if List.exists ((==) Edges.Right) edges then geobox.width else 0 + ) + in + let border_y = + view.y + geobox.y + ( + if List.exists ((==) Edges.Bottom) edges then geobox.height else 0 + ) + in + st.grab <- Some { + view = view; + x = Float.(sub (Cursor.x st.cursor) (of_int border_x)); + y = Float.(sub (Cursor.y st.cursor) (of_int border_y)); + resize = Some { edges; geobox; }; + } + ) + let focus_view st view surf = let keyboard_state = Seat.keyboard_state st.seat in @@ -163,84 +198,82 @@ let server_new_xdg_surface st _listener (surf : Xdg_surface.t) = st.views <- view :: st.views; - (* We want to add the signal handlers for the surface events using Wl.Signal.add *) - Wl.Signal.add (Xdg_surface.Events.destroy surf) view_listener - (fun _ _ -> st.views <- List.filter (fun item -> not (item == view)) st.views;); - - (* Might need to make mapped true in this guy *) - Wl.Signal.add (Xdg_surface.Events.map surf) view_listener - (fun _ _ -> - view.mapped <- true; - focus_view st view surf); - Wl.Signal.add (Xdg_surface.Events.unmap surf) view_listener - (fun _ _ -> view.mapped <- false;); - - (* cotd *) - let toplevel = Xdg_surface.toplevel surf in - - Wl.Signal.add (Xdg_toplevel.Events.request_move toplevel) view_listener - (fun _ _ -> begin_interactive st view Move); - Wl.Signal.add (Xdg_toplevel.Events.request_resize toplevel) view_listener - (* FIXME: Need to actually get the edges from the event to pass with Resize *) - (fun _ _ -> begin_interactive st view (Resize (Unsigned.UInt32.of_int 0))); - () + Wl.Signal.( + Xdg_surface.Events.( + add (destroy surf) view_listener + (fun _ _ -> st.views <- List.filter (fun item -> item <> view) st.views;); + add (map surf) view_listener + (fun _ _ -> + view.mapped <- true; + focus_view st view surf); + add (unmap surf) view_listener + (fun _ _ -> view.mapped <- false;) + ); + + Xdg_toplevel.Events.( + (* cotd *) + let toplevel = Xdg_surface.toplevel surf in + + add (request_move toplevel) view_listener + (fun _ _ -> begin_interactive st view Move); + add (request_resize toplevel) view_listener + (fun _ ev -> begin_interactive st view (Resize (Resize.edges ev))) + ) + ) end -let process_cursor_move st _time = - Option.iter (fun grab -> - grab.view.x <- truncate (Float.sub (Cursor.x st.cursor) grab.x); - grab.view.y <- truncate (Float.sub (Cursor.y st.cursor) grab.y); - ) st.grab - -let process_cursor_resize st _time = - Option.iter (fun grab -> - let view = grab.view in - let border_x = Float.sub (Cursor.x st.cursor) grab.x in - let border_y = Float.sub (Cursor.y st.cursor) grab.y in - - let (new_top, new_bottom) = - if List.exists ((==) Edges.Top) grab.resize_edges - then - let new_top = border_y in - let new_bottom = grab.geobox.y + grab.geobox.height in - if new_top >= Float.of_int new_bottom - then (new_bottom - 1, new_bottom) - else (truncate new_top, new_bottom) - else if List.exists ((==) Edges.Bottom) grab.resize_edges - then - let new_top = grab.geobox.y in - let new_bottom = border_y in - if new_bottom <= Float.of_int new_top - then (new_top, new_top + 1) - else (new_top, truncate new_bottom) - else (grab.geobox.y, grab.geobox.y + grab.geobox.height) - in - let (new_left, new_right) = - if List.exists ((==) Edges.Left) grab.resize_edges - then - let new_left = border_x in - let new_right = grab.geobox.x + grab.geobox.width in - if new_left >= Float.of_int new_right - then (new_right - 1, new_right) - else (truncate new_left, new_right) - else if List.exists ((==) Edges.Right) grab.resize_edges - then - let new_left = grab.geobox.x in - let new_right = border_x in - if new_right <= Float.of_int new_left - then (new_left, new_left + 1) - else (new_left, truncate new_right) - else (grab.geobox.x, grab.geobox.x + grab.geobox.width) in +let process_cursor_move st _time grab = + grab.view.x <- Float.(to_int (sub (Cursor.x st.cursor) grab.x)); + grab.view.y <- Float.(to_int (sub (Cursor.y st.cursor) grab.y)) + +let process_cursor_resize st _time edges (grab, resize) = + let view = grab.view in + let border_x = Float.sub (Cursor.x st.cursor) grab.x in + let border_y = Float.sub (Cursor.y st.cursor) grab.y in + + let (new_top, new_bottom) = + if List.exists ((==) Edges.Top) edges + then + let new_top = border_y in + let new_bottom = resize.geobox.y + resize.geobox.height in + if new_top >= Float.of_int new_bottom + then (new_bottom - 1, new_bottom) + else (truncate new_top, new_bottom) + else if List.exists ((==) Edges.Bottom) edges + then + let new_top = resize.geobox.y in + let new_bottom = border_y in + if new_bottom <= Float.of_int new_top + then (new_top, new_top + 1) + else (new_top, truncate new_bottom) + else (resize.geobox.y, resize.geobox.y + resize.geobox.height) + in + let (new_left, new_right) = + if List.exists ((==) Edges.Left) edges + then + let new_left = border_x in + let new_right = resize.geobox.x + resize.geobox.width in + if new_left >= Float.of_int new_right + then (new_right - 1, new_right) + else (truncate new_left, new_right) + else if List.exists ((==) Edges.Right) edges + then + let new_left = resize.geobox.x in + let new_right = border_x in + if new_right <= Float.of_int new_left + then (new_left, new_left + 1) + else (new_left, truncate new_right) + else (resize.geobox.x, resize.geobox.x + resize.geobox.width) + in - let geobox = Xdg_surface.get_geometry view.surface in - view.x <- new_left - geobox.x; - view.y <- new_top - geobox.y; + let geobox = Xdg_surface.get_geometry view.surface in + view.x <- new_left - geobox.x; + view.y <- new_top - geobox.y; - let new_width = new_right - new_left in - let new_height = new_bottom - new_top in + let new_width = new_right - new_left in + let new_height = new_bottom - new_top in - discard (Xdg_surface.toplevel_set_size view.surface, new_width, new_height) - ) st.grab + ignore (Xdg_surface.toplevel_set_size view.surface, new_width, new_height) let view_at lx ly (view : view) = let view_sx = Float.sub lx (Float.of_int view.x) in @@ -255,9 +288,11 @@ let desktop_view_at cursor = let process_cursor_motion st time = begin match st.cursor_mode with | Move -> - process_cursor_move st time - | Resize _x -> - process_cursor_resize st time + Option.iter (process_cursor_move st time) st.grab + | Resize edges -> Option.( + let resizing = bind st.grab (fun g -> map (fun r -> (g, r)) g.resize) + in iter (process_cursor_resize st time edges) resizing + ) | Passthrough -> let view = desktop_view_at st.cursor st.views in match view with From 19f7318e2678b6401fada2f4785ab97ba33f41af Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 23:03:27 -0700 Subject: [PATCH 102/109] tinywl: Swap out discard for ignore. --- tinywl/tinywl.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index e19a3ce..26ea6db 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -36,8 +36,6 @@ type cursor_mode = Passthrough | Move | Resize of Edges.t -let discard _ = () - type tinywl_server = { display : Wl.Display.t; backend : Backend.t; @@ -81,7 +79,7 @@ let render_surface st output (view : view) when_ surf sx sy = } in let transform = Output.transform_invert Surface.(State.transform (current surf)) in let matrix = Matrix.project_box box transform ~rotation:0.0 (Output.transform_matrix output) in - discard (Renderer.render_texture_with_matrix st.renderer texture matrix 1.0); + ignore (Renderer.render_texture_with_matrix st.renderer texture matrix 1.0); Surface.send_frame_done surf when_ let output_frame st output _ _ = @@ -100,7 +98,7 @@ let output_frame st output _ _ = ) (List.rev st.views); Output.render_software_cursors output; Renderer.end_ st.renderer; - discard (Output.commit output) + ignore (Output.commit output) let server_new_output st _ output = let output_ok = @@ -164,11 +162,11 @@ let focus_view st view surf = else Xdg_surface.from_surface prev ) in - Option.iter (fun s -> discard (Xdg_surface.toplevel_set_activated s false)) + Option.iter (fun s -> ignore (Xdg_surface.toplevel_set_activated s false)) to_deactivate; let keyboard = Seat.Keyboard_state.keyboard keyboard_state in st.views <- view :: List.filter ((!=) view) st.views; - discard (Xdg_surface.toplevel_set_activated surf true); + ignore (Xdg_surface.toplevel_set_activated surf true); Seat.keyboard_notify_enter st.seat (Xdg_surface.surface surf) @@ -324,7 +322,7 @@ let server_cursor_motion_absolute st _ (evt: Event_pointer_motion_absolute.t) = let server_cursor_button st _ (evt: Event_pointer_button.t) = let button_state = Event_pointer_button.state evt in - discard (Seat.pointer_notify_button + ignore (Seat.pointer_notify_button st.seat (Event_pointer_button.time_msec evt) (Event_pointer_button.button evt) From a27d88412ecede4e2c6c8ce57bc05e69794050ed Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 23:03:42 -0700 Subject: [PATCH 103/109] tinywl: Use Module.(expr) to cleanup module noise. --- tinywl/tinywl.ml | 273 ++++++++++++++++++++++++----------------------- 1 file changed, 140 insertions(+), 133 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 26ea6db..384f64f 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -62,51 +62,54 @@ let default_xkb_rules : Xkbcommon.Rule_names.t = { options = None; } -let render_surface st output (view : view) when_ surf sx sy = - match Surface.get_texture surf with - | None -> () - | Some texture -> - let (ox', oy') : float * float = Output_layout.output_coords st.output_layout output 0.0 0.0 in - let ox = Float.(add ox' (of_int (view.x + sx))) in - let oy = Float.(add oy' (of_int (view.y + sy))) in - let scale = Output.scale output in - let current = Surface.current surf in - let box: Box.t = { - x = Float.(to_int (mul ox scale)); - y = Float.(to_int (mul oy scale)); - width = truncate Float.(mul (of_int (Surface.State.width current)) scale); - height = truncate Float.(mul (of_int (Surface.State.height current)) scale); - } in - let transform = Output.transform_invert Surface.(State.transform (current surf)) in - let matrix = Matrix.project_box box transform ~rotation:0.0 (Output.transform_matrix output) in - ignore (Renderer.render_texture_with_matrix st.renderer texture matrix 1.0); - Surface.send_frame_done surf when_ +let render_surface st output (view : view) when_ surf sx sy = Surface.( + match get_texture surf with + | None -> () + | Some texture -> + let (ox', oy') : float * float = Output_layout.output_coords st.output_layout output 0.0 0.0 in + let ox = Float.(add ox' (of_int (view.x + sx))) in + let oy = Float.(add oy' (of_int (view.y + sy))) in + let scale = Output.scale output in + let current_surf = current surf in + let box: Box.t = { + x = Float.(to_int (mul ox scale)); + y = Float.(to_int (mul oy scale)); + width = Float.(to_int (mul (of_int (State.width current_surf)) scale)); + height = Float.(to_int (mul (of_int (State.height current_surf)) scale)); + } in + let transform = Output.transform_invert (State.transform current_surf) in + let matrix = Matrix.project_box box transform ~rotation:0.0 (Output.transform_matrix output) in + ignore (Renderer.render_texture_with_matrix st.renderer texture matrix 1.0); + send_frame_done surf when_ + ) let output_frame st output _ _ = let now = Mtime_clock.now () in - if not (Output.attach_render output) - then () - else - let (w, h) = Output.effective_resolution output in - Renderer.begin_ st.renderer ~width:w ~height:h; - Renderer.clear st.renderer (0.3, 0.3, 0.3, 1.0); - List.iter (fun view -> - if not view.mapped - then () - else Xdg_surface.for_each_surface view.surface - (render_surface st output view now) - ) (List.rev st.views); - Output.render_software_cursors output; - Renderer.end_ st.renderer; - ignore (Output.commit output) + if Output.attach_render output + then + let (w, h) = Output.effective_resolution output in Renderer.( + begin_ st.renderer ~width:w ~height:h; + clear st.renderer (0.3, 0.3, 0.3, 1.0); + List.iter (fun view -> + if view.mapped + then Xdg_surface.for_each_surface view.surface + (render_surface st output view now) + ) (List.rev st.views); + Output.render_software_cursors output; + end_ st.renderer; + ignore (Output.commit output) + ) + let server_new_output st _ output = let output_ok = match Output.preferred_mode output with | Some mode -> - Output.set_mode output mode; - Output.enable output true; - Output.commit output + Output.( + set_mode output mode; + enable output true; + commit output + ) | None -> true in if output_ok then begin @@ -167,12 +170,14 @@ let focus_view st view surf = let keyboard = Seat.Keyboard_state.keyboard keyboard_state in st.views <- view :: List.filter ((!=) view) st.views; ignore (Xdg_surface.toplevel_set_activated surf true); - Seat.keyboard_notify_enter - st.seat - (Xdg_surface.surface surf) - (Keyboard.keycodes keyboard) - (Keyboard.num_keycodes keyboard) - (Keyboard.modifiers keyboard) + Keyboard.( + Seat.keyboard_notify_enter + st.seat + (Xdg_surface.surface surf) + (keycodes keyboard) + (num_keycodes keyboard) + (modifiers keyboard) + ) let keyboard_handle_modifiers st device _ keyboard = let _ = Seat.set_keyboard st.seat device in @@ -274,14 +279,14 @@ let process_cursor_resize st _time edges (grab, resize) = ignore (Xdg_surface.toplevel_set_size view.surface, new_width, new_height) let view_at lx ly (view : view) = - let view_sx = Float.sub lx (Float.of_int view.x) in - let view_sy = Float.sub ly (Float.of_int view.y) in + let view_sx = Float.(sub lx (of_int view.x)) in + let view_sy = Float.(sub ly (of_int view.y)) in Xdg_surface.surface_at view.surface view_sx view_sy let desktop_view_at cursor = List.find_map (fun view -> Option.map (fun (surf, x, y) -> (view, surf, x, y)) - (view_at (Cursor.x cursor) (Cursor.y cursor) view)) + Cursor.(view_at (x cursor) (y cursor) view)) let process_cursor_motion st time = begin match st.cursor_mode with @@ -298,35 +303,29 @@ let process_cursor_motion st time = Xcursor_manager.set_cursor_image st.cursor_mgr "left_ptr" st.cursor; Seat.pointer_clear_focus st.seat | Some (_view, surf, sub_x, sub_y) -> - let focus_changed = (Seat.Pointer_state.focused_surface (Seat.pointer_state st.seat)) != surf in + let focus_changed = Seat.(Pointer_state.focused_surface (pointer_state st.seat)) != surf in Seat.pointer_notify_enter st.seat surf sub_x sub_y; if not focus_changed then Seat.pointer_notify_motion st.seat time sub_x sub_y else () end -let server_cursor_motion st _ (evt: Event_pointer_motion.t) = - Cursor.move st.cursor - (Event_pointer_motion.device evt) - (Event_pointer_motion.delta_x evt) - (Event_pointer_motion.delta_y evt); - process_cursor_motion st (Event_pointer_motion.time_msec evt) +let server_cursor_motion st _ (evt: Event_pointer_motion.t) = Event_pointer_motion.( + Cursor.move st.cursor (device evt) (delta_x evt) (delta_y evt); + process_cursor_motion st (time_msec evt) + ) let server_cursor_motion_absolute st _ (evt: Event_pointer_motion_absolute.t) = - Cursor.warp_absolute - st.cursor - (Event_pointer_motion_absolute.device evt) - (Event_pointer_motion_absolute.x evt) - (Event_pointer_motion_absolute.y evt); - process_cursor_motion st (Event_pointer_motion_absolute.time_msec evt) + Event_pointer_motion_absolute.( + Cursor.warp_absolute st.cursor (device evt) (x evt) (y evt); + process_cursor_motion st (time_msec evt) + ) let server_cursor_button st _ (evt: Event_pointer_button.t) = let button_state = Event_pointer_button.state evt in - ignore (Seat.pointer_notify_button - st.seat - (Event_pointer_button.time_msec evt) - (Event_pointer_button.button evt) - button_state); + ignore Event_pointer_button.( + Seat.pointer_notify_button st.seat (time_msec evt) (button evt) button_state + ); if button_state == Pointer.Released then st.cursor_mode <- Passthrough else @@ -335,14 +334,15 @@ let server_cursor_button st _ (evt: Event_pointer_button.t) = Option.iter (focus_view st view) (Xdg_surface.from_surface surf)) found_view -let server_cursor_axis st _ (evt : Event_pointer_axis.t) = - Seat.pointer_notify_axis - st.seat - (Event_pointer_axis.time_msec evt) - (Event_pointer_axis.orientation evt) - (Event_pointer_axis.delta evt) - (Event_pointer_axis.delta_discrete evt) - (Event_pointer_axis.source evt) +let server_cursor_axis st _ (evt : Event_pointer_axis.t) = Event_pointer_axis.( + Seat.pointer_notify_axis + st.seat + (time_msec evt) + (orientation evt) + (delta evt) + (delta_discrete evt) + (source evt) + ) let server_cursor_frame st _ _ = Seat.pointer_notify_frame st.seat @@ -397,16 +397,18 @@ let server_new_keyboard st (device: Input_device.t) = match Input_device.typ device with | Input_device.Keyboard keyboard -> server_new_keyboard_set_settings keyboard; - let modifiers = Wl.Listener.create () in - let key = Wl.Listener.create () in - Wl.Signal.add (Keyboard.Events.modifiers keyboard) modifiers - (keyboard_handle_modifiers st device); - Wl.Signal.add (Keyboard.Events.key keyboard) key - (keyboard_handle_key st keyboard device); + let modifiers_l = Wl.Listener.create () in + let key_l = Wl.Listener.create () in + Wl.Signal.(Keyboard.Events.( + add (modifiers keyboard) modifiers_l + (keyboard_handle_modifiers st device); + add (key keyboard) key_l + (keyboard_handle_key st keyboard device); + )); let tinywl_keyboard = { device = keyboard; - modifiers = modifiers; - key = key; + modifiers = modifiers_l; + key = key_l; } in st.keyboards <- tinywl_keyboard :: st.keyboards; @@ -415,15 +417,14 @@ let server_new_keyboard st (device: Input_device.t) = let server_new_pointer st (pointer: Input_device.t) = Cursor.attach_input_device st.cursor pointer -let server_new_input st _ (device: Input_device.t) = - begin match Input_device.typ device with - | Input_device.Keyboard _ -> - server_new_keyboard st device - | Input_device.Pointer _ -> - server_new_pointer st device - | _ -> - () - end; +let server_new_input st _ (device: Input_device.t) = Input_device.( + match typ device with + | Keyboard _ -> + server_new_keyboard st device + | Pointer _ -> + server_new_pointer st device + | _ -> () + ); let caps = Wl.Seat_capability.Pointer :: @@ -434,12 +435,12 @@ let server_new_input st _ (device: Input_device.t) = Seat.set_capabilities st.seat caps let server_request_cursor st _ (ev: Seat.Pointer_request_set_cursor_event.t) = - let module E = Seat.Pointer_request_set_cursor_event in let focused_client = st.seat |> Seat.pointer_state |> Seat.Pointer_state.focused_client in - if Seat.Client.equal focused_client (E.seat_client ev) then ( - Cursor.set_surface st.cursor (E.surface ev) (E.hotspot_x ev) (E.hotspot_y ev) + Seat.Pointer_request_set_cursor_event.( + if Seat.Client.equal focused_client (seat_client ev) + then Cursor.set_surface st.cursor (surface ev) (hotspot_x ev) (hotspot_y ev) ) let () = @@ -473,50 +474,56 @@ let () = let seat = Seat.create display "seat0" in - let new_output = Wl.Listener.create () in - let new_xdg_surface = Wl.Listener.create () in - let cursor_motion = Wl.Listener.create () in - let cursor_motion_absolute = Wl.Listener.create () in - let cursor_button = Wl.Listener.create () in - let cursor_axis = Wl.Listener.create () in - let cursor_frame = Wl.Listener.create () in - let new_input = Wl.Listener.create () in - let request_cursor = Wl.Listener.create () in - let st = { display; backend; renderer; output_layout; new_output; seat; - cursor; cursor_mode = Passthrough; cursor_mgr; outputs = []; - views = []; keyboards = []; grab = None } in - - Wl.Signal.add (Backend.signal_new_output backend) new_output - (server_new_output st); - Wl.Signal.add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface - (server_new_xdg_surface st); - - Wl.Signal.add (Cursor.signal_motion cursor) cursor_motion - (server_cursor_motion st); - Wl.Signal.add (Cursor.signal_motion_absolute cursor) cursor_motion_absolute - (server_cursor_motion_absolute st); - Wl.Signal.add (Cursor.signal_button cursor) cursor_button - (server_cursor_button st); - Wl.Signal.add (Cursor.signal_axis cursor) cursor_axis - (server_cursor_axis st); - Wl.Signal.add (Cursor.signal_frame cursor) cursor_frame - (server_cursor_frame st); - - Wl.Signal.add (Backend.signal_new_input backend) new_input - (server_new_input st); - Wl.Signal.add (Seat.signal_request_set_cursor seat) request_cursor - (server_request_cursor st); + Wl.Listener.( + let new_output = create () in + let new_xdg_surface = create () in + let cursor_motion = create () in + let cursor_motion_absolute = create () in + let cursor_button = create () in + let cursor_axis = create () in + let cursor_frame = create () in + let new_input = create () in + let request_cursor = create () in + let st = { display; backend; renderer; output_layout; new_output; seat; + cursor; cursor_mode = Passthrough; cursor_mgr; outputs = []; + views = []; keyboards = []; grab = None } in + + Wl.Signal.( + add (Backend.signal_new_output backend) new_output + (server_new_output st); + add (Xdg_shell.signal_new_surface xdg_shell) new_xdg_surface + (server_new_xdg_surface st); + + Cursor.( + add (signal_motion cursor) cursor_motion + (server_cursor_motion st); + add (signal_motion_absolute cursor) cursor_motion_absolute + (server_cursor_motion_absolute st); + add (signal_button cursor) cursor_button + (server_cursor_button st); + add (signal_axis cursor) cursor_axis + (server_cursor_axis st); + add (signal_frame cursor) cursor_frame + (server_cursor_frame st) + ); + + add (Backend.signal_new_input backend) new_input + (server_new_input st); + add (Seat.signal_request_set_cursor seat) request_cursor + (server_request_cursor st) + ) + ); let socket = match Wl.Display.add_socket_auto display with | None -> Backend.destroy backend; exit 1 | Some socket -> socket in - if not (Backend.start backend) then ( - Backend.destroy backend; + Backend.(if not (start backend) then ( + destroy backend; Wl.Display.destroy display; exit 1 - ); + )); Unix.putenv "WAYLAND_DISPLAY" socket; begin match startup_cmd with @@ -526,9 +533,9 @@ let () = end; Printf.printf "Running wayland compositor on WAYLAND_DISPLAY=%s" socket; - Wl.Display.run display; - - Wl.Display.destroy_clients display; - Wl.Display.destroy display; - () + Wl.Display.( + run display; + destroy_clients display; + destroy display + ) From 586c96bf8eae6b13a748b57d28c9fde401293929 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 25 May 2021 23:47:10 -0700 Subject: [PATCH 104/109] tinywl: Use single branched i.t.e. where applicable. --- tinywl/tinywl.ml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/tinywl/tinywl.ml b/tinywl/tinywl.ml index 384f64f..8f9cfd6 100644 --- a/tinywl/tinywl.ml +++ b/tinywl/tinywl.ml @@ -305,9 +305,7 @@ let process_cursor_motion st time = | Some (_view, surf, sub_x, sub_y) -> let focus_changed = Seat.(Pointer_state.focused_surface (pointer_state st.seat)) != surf in Seat.pointer_notify_enter st.seat surf sub_x sub_y; - if not focus_changed - then Seat.pointer_notify_motion st.seat time sub_x sub_y - else () + if not focus_changed then Seat.pointer_notify_motion st.seat time sub_x sub_y end let server_cursor_motion st _ (evt: Event_pointer_motion.t) = Event_pointer_motion.( @@ -372,9 +370,7 @@ let keyboard_handle_key st keyboard device _ key_evt = then List.fold_left (fun _ sym -> handle_keybinding st sym) false syms else false in - if handled - then () - else + if not handled then let () = Seat.set_keyboard st.seat device in Seat.keyboard_notify_key st.seat key_evt From 37f84cd9887576a87cd19165fe8f58285e687127 Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 20 Jul 2021 08:37:48 -0700 Subject: [PATCH 105/109] ffi: Add pixman_region32_t. Note that pixman_region32_t is stubbed as a void pointer since no bindings to pixman exist yet. --- ffi/ffi.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 786ecc3..51399d7 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -31,6 +31,10 @@ struct allocate Time_unix.Timespec.t timespec) (ptr Time_unix.Timespec.t) + (* FIXME: The void pointer is a pixman_region32_t for which no bindings exist (yet). + This is only ok because so far, no one uses it. *) + let pixman_region32_t = ptr void + (* wl_list *) type wl_list_p = Wl_list.t ptr @@ -141,9 +145,7 @@ struct (wl_output_transform @-> returning wl_output_transform) let wlr_output_render_software_cursors = foreign "wlr_output_render_software_cursors" - (* FIXME: The void pointer is a pixman_region32_t for which no bindings exist (yet). - This is only ok because so far, no one uses it. *) - (wlr_output_p @-> ptr void @-> returning void) + (wlr_output_p @-> pixman_region32_t @-> returning void) (* wlr_output_layout *) From fd22f9c8986647e3fb240a719052a956b1234f2f Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 20 Jul 2021 08:40:02 -0700 Subject: [PATCH 106/109] ffi: Remove wl_output_transform. Just use Wl_output_transform.t, as wl_output_transform was just an alias. --- ffi/ffi.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/ffi/ffi.ml b/ffi/ffi.ml index 51399d7..be647b0 100644 --- a/ffi/ffi.ml +++ b/ffi/ffi.ml @@ -108,10 +108,6 @@ struct let wl_resource_p = ptr Wl_resource.t - (* wl_output_transform *) - - let wl_output_transform = Wl_output_transform.t - (* wlr_output_mode *) let wlr_output_mode_p = ptr Output_mode.t @@ -142,7 +138,7 @@ struct (wlr_output_p @-> ptr int @-> ptr int @-> returning void) let wlr_output_transform_invert = foreign "wlr_output_transform_invert" - (wl_output_transform @-> returning wl_output_transform) + (Wl_output_transform.t @-> returning Wl_output_transform.t) let wlr_output_render_software_cursors = foreign "wlr_output_render_software_cursors" (wlr_output_p @-> pixman_region32_t @-> returning void) From a8dee0bce8aa01f99559f7bcf18cb78f4512d1fa Mon Sep 17 00:00:00 2001 From: John Soo Date: Tue, 20 Jul 2021 09:17:55 -0700 Subject: [PATCH 107/109] lib: Move Keyboard_modifiers to submodule of Keyboard. --- lib/dune | 1 - lib/keyboard.ml | 11 +++++++++++ lib/keyboard_modifiers.ml | 14 -------------- lib/wlroots.ml | 1 - lib/wlroots.mli | 16 ++++++++-------- 5 files changed, 19 insertions(+), 24 deletions(-) delete mode 100644 lib/keyboard_modifiers.ml diff --git a/lib/dune b/lib/dune index 6637e7d..6f57984 100644 --- a/lib/dune +++ b/lib/dune @@ -32,7 +32,6 @@ tablet_tool tablet_pad input_device - keyboard_modifiers keycodes backend renderer diff --git a/lib/keyboard.ml b/lib/keyboard.ml index c5e9a7f..65188c7 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -45,3 +45,14 @@ module Events = struct typ = ptr Types.Keyboard.t; } end + +module Modifiers = struct + type t = Types.Keyboard_modifiers.t ptr + include Ptr + + let has_alt modifiers = + Signed.Int64.of_int 0 != + Signed.Int64.logand + (Unsigned.UInt32.to_int64 modifiers) + Types.Keyboard_modifier._WLR_MODIFIER_ALT +end diff --git a/lib/keyboard_modifiers.ml b/lib/keyboard_modifiers.ml deleted file mode 100644 index b3f4a9d..0000000 --- a/lib/keyboard_modifiers.ml +++ /dev/null @@ -1,14 +0,0 @@ -open Ctypes -open Wlroots_common.Utils - -module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) -module Types = Wlroots_ffi_f.Ffi.Types - -type t = Types.Keyboard_modifiers.t ptr -include Ptr - -let has_alt modifiers = - Signed.Int64.of_int 0 != - Signed.Int64.logand - (Unsigned.UInt32.to_int64 modifiers) - Types.Keyboard_modifier._WLR_MODIFIER_ALT diff --git a/lib/wlroots.ml b/lib/wlroots.ml index f376b21..8c80299 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -13,7 +13,6 @@ module Backend = Backend module Output = Output module Input_device = Input_device module Keyboard = Keyboard -module Keyboard_modifiers = Keyboard_modifiers module Keycodes = Keycodes module Pointer = Pointer module Event_pointer_motion = Event_pointer_motion diff --git a/lib/wlroots.mli b/lib/wlroots.mli index ec65979..a5dea7c 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -123,11 +123,6 @@ module Keycodes : sig include Comparable0 end -module Keyboard_modifiers : sig - include Comparable0 - val has_alt : Unsigned.uint32 -> bool -end - module Keyboard : sig include Comparable0 @@ -143,7 +138,7 @@ module Keyboard : sig end val xkb_state : t -> Xkbcommon.State.t - val modifiers : t -> Keyboard_modifiers.t + val modifiers : t -> Keyboard.Modifiers.t val keycodes : t -> Keycodes.t val num_keycodes : t -> Unsigned.size_t val set_keymap : t -> Xkbcommon.Keymap.t -> bool @@ -154,6 +149,11 @@ module Keyboard : sig val key : t -> Event_key.t Wl.Signal.t val modifiers : t -> t Wl.Signal.t end + + module Modifiers : sig + include Comparable0 + val has_alt : Unsigned.uint32 -> bool + end end module Pointer : sig @@ -397,9 +397,9 @@ module Seat : sig t -> Pointer_request_set_cursor_event.t Wl.Signal.t val set_capabilities : t -> Wl.Seat_capability.t -> unit val set_keyboard : t -> Input_device.t -> unit - val keyboard_notify_modifiers : t -> Keyboard_modifiers.t -> unit + val keyboard_notify_modifiers : t -> Keyboard.Modifiers.t -> unit val keyboard_notify_enter : - t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard_modifiers.t -> unit + t -> Surface.t -> Keycodes.t -> Unsigned.size_t -> Keyboard.Modifiers.t -> unit val keyboard_notify_key : t -> Keyboard.Event_key.t -> unit val pointer_notify_enter : From a0568b070521fa8a6ce80518917f8e5a0306a58b Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 1 Aug 2021 23:09:52 -0700 Subject: [PATCH 108/109] common: Add Bitwise functor for bitwise enums. --- common/bitwise.ml | 40 ++++++++++++++++++++++++++++++++++++++++ common/dune | 1 + 2 files changed, 41 insertions(+) create mode 100644 common/bitwise.ml diff --git a/common/bitwise.ml b/common/bitwise.ml new file mode 100644 index 0000000..5fe02be --- /dev/null +++ b/common/bitwise.ml @@ -0,0 +1,40 @@ +open Ctypes + +module type Size = sig + type t + val zero : t + val logor : t -> t -> t + val logand : t -> t -> t +end + +module type Elems = sig + type t + module Size : Size + val size : Size.t typ + val desc : (t * Size.t) list +end + +module type Enum = sig + type elem + type t + val t : t +end + +module Make (E : Elems) : Enum = struct + type elem = E.t + type t = E.t list typ + let t : t = + let read i = + List.filter_map (fun (x, cst) -> + if (E.Size.logand i cst) <> E.Size.zero then + Some x + else None + ) E.desc + in + let write items = + List.fold_left (fun i item -> + E.Size.logor (List.assoc item E.desc) i + ) E.Size.zero items + in + view ~read ~write E.size +end diff --git a/common/dune b/common/dune index e500ad6..1e9637c 100644 --- a/common/dune +++ b/common/dune @@ -1,6 +1,7 @@ (library (name wlroots_common) (public_name wlroots.common) + (modules utils bitwise sigs) (libraries ctypes)) ;; xdg-shell-protocol.h From a5a92a05cb21cd97f136d2ebb662f5cf8f97bac6 Mon Sep 17 00:00:00 2001 From: John Soo Date: Sun, 1 Aug 2021 23:16:12 -0700 Subject: [PATCH 109/109] [WIP] bitwise_enums: Use Bitwise.Enum modules instead of functions --- common/utils.ml | 35 ----------------------------------- lib/dune | 2 +- lib/edges.ml | 18 ------------------ lib/edges_elems.ml | 14 ++++++++++++++ lib/keyboard.ml | 30 ++++++++++++++++++++++++++++++ lib/seat.ml | 3 +-- lib/wl.ml | 21 +++++++++++++-------- lib/wlroots.ml | 7 ++++++- lib/wlroots.mli | 30 ++++++++++++++++-------------- types/types.ml | 43 ++++++++++++++++--------------------------- 10 files changed, 97 insertions(+), 106 deletions(-) delete mode 100644 lib/edges.ml create mode 100644 lib/edges_elems.ml diff --git a/common/utils.ml b/common/utils.ml index 9452397..ab6768f 100644 --- a/common/utils.ml +++ b/common/utils.ml @@ -13,41 +13,6 @@ let ptr_hash : 'a ptr -> int = fun p -> to_voidp p |> raw_address_of_ptr |> Hashtbl.hash let mk_equal compare x y = compare x y = 0 - -let bitwise_enum desc = - let open Unsigned.UInt64 in - let open Infix in - let read i = - List.filter_map (fun (x, cst) -> - if (i land cst) <> zero then - Some x - else None - ) desc - in - let write items = - List.fold_left (fun i item -> - (List.assoc item desc) lor i - ) zero items - in - view ~read ~write uint64_t - -let bitwise_enum32 desc = - let open Unsigned.UInt32 in - let open Infix in - let read i = - List.filter_map (fun (x, cst) -> - if (i land cst) <> zero then - Some x - else None - ) desc - in - let write items = - List.fold_left (fun i item -> - (List.assoc item desc) lor i - ) zero items - in - view ~read ~write uint32_t - module Ptr = struct let compare = ptr_compare let hash = ptr_hash diff --git a/lib/dune b/lib/dune index 6f57984..9a3841d 100644 --- a/lib/dune +++ b/lib/dune @@ -27,7 +27,7 @@ event_pointer_motion event_pointer_motion_absolute event_pointer_axis - edges + edges_elems touch tablet_tool tablet_pad diff --git a/lib/edges.ml b/lib/edges.ml deleted file mode 100644 index 2925ee6..0000000 --- a/lib/edges.ml +++ /dev/null @@ -1,18 +0,0 @@ -open Ctypes -open Wlroots_common.Utils - -module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) -module Types = Wlroots_ffi_f.Ffi.Types - -type edges = None | Top | Bottom | Left | Right -type t = edges list -include Poly - -let t : edges list typ = - bitwise_enum32 Types.Edges.([ - None, _WLR_EDGE_NONE; - Top, _WLR_EDGE_TOP; - Bottom, _WLR_EDGE_BOTTOM; - Right, _WLR_EDGE_RIGHT; - Left, _WLR_EDGE_LEFT; - ]) diff --git a/lib/edges_elems.ml b/lib/edges_elems.ml new file mode 100644 index 0000000..120a95a --- /dev/null +++ b/lib/edges_elems.ml @@ -0,0 +1,14 @@ +open Ctypes +module Types = Wlroots_ffi_f.Ffi.Types + +type t = None | Top | Bottom | Left | Right +module Size = Unsigned.UInt32 +let size = uint32_t +open Types.Edges +let desc = [ + None, _WLR_EDGE_NONE; + Top, _WLR_EDGE_TOP; + Bottom, _WLR_EDGE_BOTTOM; + Right, _WLR_EDGE_RIGHT; + Left, _WLR_EDGE_LEFT; +] diff --git a/lib/keyboard.ml b/lib/keyboard.ml index 65188c7..d117d28 100644 --- a/lib/keyboard.ml +++ b/lib/keyboard.ml @@ -1,5 +1,6 @@ open Ctypes open Wlroots_common.Utils +open Wlroots_common module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) module Types = Wlroots_ffi_f.Ffi.Types @@ -19,6 +20,35 @@ module Event_key = struct let state = getfield Types.Event_keyboard_key.state end +module Modifiers = struct + type t = Types.Keyboard_modifiers.t ptr + let t = ptr Types.Keyboard_modifiers.t + include Ptr +end + +module Modifier_elems : Bitwise.Elems = struct + open Types.Keyboard_modifier + type t = + Shift | Caps | Ctrl | Alt | Mod2 | Mod3 | Logo | Mod5 + module Size = Unsigned.UInt32 + let size = uint32_t + let desc = [ + Shift, _WLR_MODIFIER_SHIFT; + Caps, _WLR_MODIFIER_CAPS; + Ctrl, _WLR_MODIFIER_CTRL; + Alt, _WLR_MODIFIER_ALT; + Mod2, _WLR_MODIFIER_MOD2; + Mod3, _WLR_MODIFIER_MOD3; + Logo, _WLR_MODIFIER_LOGO; + Mod5, _WLR_MODIFIER_MOD5; + ] +end + +module Modifier = struct + include Bitwise.Make(Modifier_elems) + include Poly +end + let xkb_state = getfield Types.Keyboard.xkb_state let modifiers = getfield Types.Keyboard.modifiers diff --git a/lib/seat.ml b/lib/seat.ml index 3db17e9..6f0d634 100644 --- a/lib/seat.ml +++ b/lib/seat.ml @@ -63,9 +63,8 @@ let signal_request_set_cursor (seat: t) : _ Wl.Signal.t = { typ = Pointer_request_set_cursor_event.t } -let set_capabilities seat caps = +let set_capabilities = Bindings.wlr_seat_set_capabilities - seat (coerce Wl.Seat_capability.t uint64_t caps) let set_keyboard = Bindings.wlr_seat_set_keyboard diff --git a/lib/wl.ml b/lib/wl.ml index 1a8ff71..dfd2a99 100644 --- a/lib/wl.ml +++ b/lib/wl.ml @@ -1,4 +1,5 @@ open Ctypes +open Wlroots_common open Wlroots_common.Utils module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi) @@ -115,15 +116,19 @@ module Resource = struct include Ptr end -module Seat_capability = struct - type cap = Pointer | Keyboard | Touch - type t = cap list - include Poly - - let t : cap list typ = - bitwise_enum Types.Wl_seat_capability.([ +module Seat_capability_elems : Bitwise.Elems = struct + type t = Pointer | Keyboard | Touch + module Size = Signed.Int64 + let size = int64_t + open Types.Wl_seat_capability + let desc = [ Pointer, _WL_SEAT_CAPABILITY_POINTER; Keyboard, _WL_SEAT_CAPABILITY_KEYBOARD; Touch, _WL_SEAT_CAPABILITY_TOUCH; - ]) + ] +end + +module Seat_capability = struct + include Bitwise.Make(Seat_capability_elems) + include Poly end diff --git a/lib/wlroots.ml b/lib/wlroots.ml index 8c80299..01c8c27 100644 --- a/lib/wlroots.ml +++ b/lib/wlroots.ml @@ -1,4 +1,5 @@ include Event +open Wlroots_common module Output_layout = Output_layout module Seat = Seat @@ -19,7 +20,11 @@ module Event_pointer_motion = Event_pointer_motion module Event_pointer_motion_absolute = Event_pointer_motion_absolute module Event_pointer_button = Event_pointer_button module Event_pointer_axis = Event_pointer_axis -module Edges = Edges +module Edges_elems = Edges_elems +module Edges = struct + include Bitwise.Make(Edges_elems) + include Utils.Poly +end module Touch = Touch module Tablet_tool = Tablet_tool module Tablet_pad = Tablet_pad diff --git a/lib/wlroots.mli b/lib/wlroots.mli index a5dea7c..1befd63 100644 --- a/lib/wlroots.mli +++ b/lib/wlroots.mli @@ -1,4 +1,5 @@ open Wlroots_common.Sigs +open Wlroots_common module Wl : sig module Event_loop : sig @@ -37,8 +38,8 @@ module Wl : sig end module Seat_capability : sig - type cap = Pointer | Keyboard | Touch - include Comparable0 with type t = cap list + include Bitwise.Enum + include Comparable0 with type t := t end end @@ -164,9 +165,11 @@ module Pointer : sig type axis_orientation = Vertical | Horizontal end +module Edges_elems : Bitwise.Elems + module Edges : sig - type edges = None | Top | Bottom | Left | Right - include Comparable0 with type t = edges list + include Bitwise.Enum + include Comparable0 with type t := t end module Touch : sig @@ -331,7 +334,7 @@ and Xdg_shell : sig val signal_new_surface : t -> Xdg_surface.t Wl.Signal.t end -module Cursor : sig +and Cursor : sig include Comparable0 val x : t -> float @@ -351,15 +354,7 @@ module Cursor : sig val warp_absolute : t -> Input_device.t -> float -> float -> unit end -module Xcursor_manager : sig - include Comparable0 - - val create : string option -> int -> t - val load : t -> float -> int - val set_cursor_image : t -> string -> Cursor.t -> unit -end - -module Seat : sig +and Seat : sig include Comparable0 module Client : sig @@ -415,6 +410,13 @@ module Seat : sig val pointer_notify_frame : t -> unit end +module Xcursor_manager : sig + include Comparable0 + + val create : string option -> int -> t + val load : t -> float -> int + val set_cursor_image : t -> string -> Cursor.t -> unit +end module Log : sig type importance = diff --git a/types/types.ml b/types/types.ml index 343c2f1..07f92b5 100644 --- a/types/types.ml +++ b/types/types.ml @@ -69,11 +69,11 @@ module Make (S : Cstubs_structs.TYPE) = struct end module Wl_seat_capability = struct - type t = Unsigned.uint64 - let t : t typ = uint64_t - let _WL_SEAT_CAPABILITY_POINTER = constant "WL_SEAT_CAPABILITY_POINTER" uint64_t - let _WL_SEAT_CAPABILITY_KEYBOARD = constant "WL_SEAT_CAPABILITY_KEYBOARD" uint64_t - let _WL_SEAT_CAPABILITY_TOUCH = constant "WL_SEAT_CAPABILITY_TOUCH" uint64_t + type t = Signed.Int64.t + let t : t typ = int64_t + let _WL_SEAT_CAPABILITY_POINTER = constant "WL_SEAT_CAPABILITY_POINTER" t + let _WL_SEAT_CAPABILITY_KEYBOARD = constant "WL_SEAT_CAPABILITY_KEYBOARD" t + let _WL_SEAT_CAPABILITY_TOUCH = constant "WL_SEAT_CAPABILITY_TOUCH" t end module Renderer = struct @@ -191,28 +191,17 @@ module Make (S : Cstubs_structs.TYPE) = struct end module Keyboard_modifier = struct - type modifier = - Shift | Caps | Ctrl | Alt | Mod2 | Mod3 | Logo | Mod5 - - let _WLR_MODIFIER_SHIFT = constant "WLR_MODIFIER_SHIFT" int64_t - let _WLR_MODIFIER_CAPS = constant "WLR_MODIFIER_CAPS" int64_t - let _WLR_MODIFIER_CTRL = constant "WLR_MODIFIER_CTRL" int64_t - let _WLR_MODIFIER_ALT = constant "WLR_MODIFIER_ALT" int64_t - let _WLR_MODIFIER_MOD2 = constant "WLR_MODIFIER_MOD2" int64_t - let _WLR_MODIFIER_MOD3 = constant "WLR_MODIFIER_MOD3" int64_t - let _WLR_MODIFIER_LOGO = constant "WLR_MODIFIER_LOGO" int64_t - let _WLR_MODIFIER_MOD5 = constant "WLR_MODIFIER_MOD5" int64_t - - let modifier : modifier typ = - enum "wlr_keyboard_modifier" [ - Shift, _WLR_MODIFIER_SHIFT; - Ctrl, _WLR_MODIFIER_CTRL; - Alt, _WLR_MODIFIER_ALT; - Mod2, _WLR_MODIFIER_MOD2; - Mod3, _WLR_MODIFIER_MOD3; - Logo, _WLR_MODIFIER_LOGO; - Mod5, _WLR_MODIFIER_MOD5; - ] + type t = Unsigned.uint32 + let t : t typ = uint32_t + + let _WLR_MODIFIER_SHIFT = constant "WLR_MODIFIER_SHIFT" t + let _WLR_MODIFIER_CAPS = constant "WLR_MODIFIER_CAPS" t + let _WLR_MODIFIER_CTRL = constant "WLR_MODIFIER_CTRL" t + let _WLR_MODIFIER_ALT = constant "WLR_MODIFIER_ALT" t + let _WLR_MODIFIER_MOD2 = constant "WLR_MODIFIER_MOD2" t + let _WLR_MODIFIER_MOD3 = constant "WLR_MODIFIER_MOD3" t + let _WLR_MODIFIER_LOGO = constant "WLR_MODIFIER_LOGO" t + let _WLR_MODIFIER_MOD5 = constant "WLR_MODIFIER_MOD5" t end module Keyboard_modifiers = struct