[WIP] bitwise_enums: Use Bitwise.Enum modules instead of functions

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

lib/dune

@@ -27,7 +27,7 @@
            event_pointer_motion
            event_pointer_motion_absolute
            event_pointer_axis
-           edges
+           edges_elems
            touch
            tablet_tool
            tablet_pad

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;
+]

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

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

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

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

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 =

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