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