From 837d457b10bad21cbad1c53d6fd9528f7d086814 Mon Sep 17 00:00:00 2001 From: Syed Daanish Date: Sun, 26 Jul 2026 09:48:54 +0100 Subject: [PATCH] Arrange xcb bindings properly --- src/main.ml | 12 +- src/xcb/connection.ml | 16 +++ src/xcb/cookie.ml | 15 ++ src/xcb/error.ml | 18 +++ src/xcb/event.ml | 271 +++++++++++++++++++++++++++++++++++++ src/xcb/functions.ml | 53 -------- src/xcb/screen.ml | 25 ++++ src/xcb/screen_iterator.ml | 22 +++ src/xcb/types.ml | 45 ------ src/xcb/utils.ml | 15 ++ src/xcb/window.ml | 7 + 11 files changed, 395 insertions(+), 104 deletions(-) create mode 100644 src/xcb/connection.ml create mode 100644 src/xcb/cookie.ml create mode 100644 src/xcb/error.ml create mode 100644 src/xcb/event.ml delete mode 100644 src/xcb/functions.ml create mode 100644 src/xcb/screen.ml create mode 100644 src/xcb/screen_iterator.ml delete mode 100644 src/xcb/types.ml create mode 100644 src/xcb/utils.ml create mode 100644 src/xcb/window.ml diff --git a/src/main.ml b/src/main.ml index aedadaf..c13c181 100644 --- a/src/main.ml +++ b/src/main.ml @@ -9,21 +9,21 @@ let spawn cmd = | _pid -> () let () = - let conn = Xcb.Functions.connect () in + let conn = Xcb.Connection.connect () in - print_endline "connected"; + print_endline "Connected to X"; - Xcb.Functions.window_attribute_setup conn; + Xcb.Utils.setup conn; - if Xcb.Functions.flush conn <= 0 then exit 1; + if Xcb.Connection.flush conn <= 0 then exit 1; spawn [| "kitty" |]; while true do - if Xcb.Functions.flush conn <= 0 then exit 1; + if Xcb.Connection.flush conn <= 0 then exit 1; Unix.sleepf 0.01 done; - Xcb.Functions.disconnect conn; + Xcb.Connection.disconnect conn; print_endline "done" diff --git a/src/xcb/connection.ml b/src/xcb/connection.ml new file mode 100644 index 0000000..43974b5 --- /dev/null +++ b/src/xcb/connection.ml @@ -0,0 +1,16 @@ +open Ctypes +open Foreign + +type t + +let typ : t structure typ = structure "xcb_connection_t" + +let _xcb_connect = + foreign "xcb_connect" (string_opt @-> ptr int @-> returning (ptr typ)) + +let disconnect = foreign "xcb_disconnect" (ptr typ @-> returning void) +let flush = foreign "xcb_flush" (ptr typ @-> returning int) + +let connect () = + let screen = allocate int 0 in + _xcb_connect None screen diff --git a/src/xcb/cookie.ml b/src/xcb/cookie.ml new file mode 100644 index 0000000..8330ee8 --- /dev/null +++ b/src/xcb/cookie.ml @@ -0,0 +1,15 @@ +open Ctypes +open Foreign + +module Void = struct + type t + + let typ : t structure typ = structure "xcb_void_cookie_t" + let sequence = field typ "sequence" uint32_t + let () = seal typ + + let _xcb_change_window_attributes_checked = + foreign "xcb_change_window_attributes_checked" + (ptr Connection.typ @-> uint32_t @-> uint32_t @-> ptr uint32_t + @-> returning typ) +end diff --git a/src/xcb/error.ml b/src/xcb/error.ml new file mode 100644 index 0000000..46913e9 --- /dev/null +++ b/src/xcb/error.ml @@ -0,0 +1,18 @@ +open Ctypes +open Foreign + +type t + +let typ : t structure typ = structure "xcb_generic_error_t" + +let _xcb_request_check = + foreign "xcb_request_check" + (ptr Connection.typ @-> Cookie.Void.typ @-> returning (ptr_opt typ)) + +let has_error = + foreign "xcb_connection_has_error" (ptr Connection.typ @-> returning int) + +let check conn cookie = + match _xcb_request_check conn cookie with + | None -> print_endline "WM ownership acquired" + | Some _ -> print_endline "another WM already owns the display" diff --git a/src/xcb/event.ml b/src/xcb/event.ml new file mode 100644 index 0000000..3dc9c68 --- /dev/null +++ b/src/xcb/event.ml @@ -0,0 +1,271 @@ +open Ctypes +open Foreign + +type generic_event + +let generic_event : generic_event structure typ = + structure "xcb_generic_event_t" + +let response_type = field generic_event "response_type" uint8_t +let pad0 = field generic_event "pad0" uint8_t +let sequence = field generic_event "sequence" uint16_t +let pad = field generic_event "pad" (array 7 uint32_t) +let full_sequence = field generic_event "full_sequence" uint32_t +let () = seal generic_event + +(* TODO: convert all these: +/* Opcode for xcb_create_notify. */ +#define XCB_CREATE_NOTIFY 16 + +/** + * @brief xcb_create_notify_event_t + **/ +typedef struct xcb_create_notify_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t parent; + xcb_window_t window; + int16_t x; + int16_t y; + uint16_t width; + uint16_t height; + uint16_t border_width; + uint8_t override_redirect; + uint8_t pad1; +} xcb_create_notify_event_t; + +/** Opcode for xcb_destroy_notify. */ +#define XCB_DESTROY_NOTIFY 17 + +/** + * @brief xcb_destroy_notify_event_t + **/ +typedef struct xcb_destroy_notify_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t event; + xcb_window_t window; +} xcb_destroy_notify_event_t; + +/** Opcode for xcb_unmap_notify. */ +#define XCB_UNMAP_NOTIFY 18 + +/** + * @brief xcb_unmap_notify_event_t + **/ +typedef struct xcb_unmap_notify_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t event; + xcb_window_t window; + uint8_t from_configure; + uint8_t pad1[3]; +} xcb_unmap_notify_event_t; + +/** Opcode for xcb_map_notify. */ +#define XCB_MAP_NOTIFY 19 + +/** + * @brief xcb_map_notify_event_t + **/ +typedef struct xcb_map_notify_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t event; + xcb_window_t window; + uint8_t override_redirect; + uint8_t pad1[3]; +} xcb_map_notify_event_t; + +/** Opcode for xcb_map_request. */ +#define XCB_MAP_REQUEST 20 + +/** + * @brief xcb_map_request_event_t + **/ +typedef struct xcb_map_request_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t parent; + xcb_window_t window; +} xcb_map_request_event_t; + +/** Opcode for xcb_enter_notify. */ +#define XCB_ENTER_NOTIFY 7 + +/** + * @brief xcb_enter_notify_event_t + **/ +typedef struct xcb_enter_notify_event_t { + uint8_t response_type; + uint8_t detail; + uint16_t sequence; + xcb_timestamp_t time; + xcb_window_t root; + xcb_window_t event; + xcb_window_t child; + int16_t root_x; + int16_t root_y; + int16_t event_x; + int16_t event_y; + uint16_t state; + uint8_t mode; + uint8_t same_screen_focus; +} xcb_enter_notify_event_t; + +/** Opcode for xcb_leave_notify. */ +#define XCB_LEAVE_NOTIFY 8 + +typedef xcb_enter_notify_event_t xcb_leave_notify_event_t; + +/** Opcode for xcb_key_press. */ +#define XCB_KEY_PRESS 2 + +/** + * @brief xcb_key_press_event_t + **/ +typedef struct xcb_key_press_event_t { + uint8_t response_type; + xcb_keycode_t detail; + uint16_t sequence; + xcb_timestamp_t time; + xcb_window_t root; + xcb_window_t event; + xcb_window_t child; + int16_t root_x; + int16_t root_y; + int16_t event_x; + int16_t event_y; + uint16_t state; + uint8_t same_screen; + uint8_t pad0; +} xcb_key_press_event_t; + +/** Opcode for xcb_key_release. */ +#define XCB_KEY_RELEASE 3 + +typedef xcb_key_press_event_t xcb_key_release_event_t; + +typedef enum xcb_button_mask_t { + XCB_BUTTON_MASK_1 = 256, + XCB_BUTTON_MASK_2 = 512, + XCB_BUTTON_MASK_3 = 1024, + XCB_BUTTON_MASK_4 = 2048, + XCB_BUTTON_MASK_5 = 4096, + XCB_BUTTON_MASK_ANY = 32768 +} xcb_button_mask_t; + +/** Opcode for xcb_button_press. */ +#define XCB_BUTTON_PRESS 4 + +/** + * @brief xcb_button_press_event_t + **/ +typedef struct xcb_button_press_event_t { + uint8_t response_type; + xcb_button_t detail; + uint16_t sequence; + xcb_timestamp_t time; + xcb_window_t root; + xcb_window_t event; + xcb_window_t child; + int16_t root_x; + int16_t root_y; + int16_t event_x; + int16_t event_y; + uint16_t state; + uint8_t same_screen; + uint8_t pad0; +} xcb_button_press_event_t; + +/** Opcode for xcb_button_release. */ +#define XCB_BUTTON_RELEASE 5 + +typedef xcb_button_press_event_t xcb_button_release_event_t; + +typedef enum xcb_motion_t { + XCB_MOTION_NORMAL = 0, + XCB_MOTION_HINT = 1 +} xcb_motion_t; + +/** Opcode for xcb_motion_notify. */ +#define XCB_MOTION_NOTIFY 6 + +/** + * @brief xcb_motion_notify_event_t + **/ +typedef struct xcb_motion_notify_event_t { + uint8_t response_type; + uint8_t detail; + uint16_t sequence; + xcb_timestamp_t time; + xcb_window_t root; + xcb_window_t event; + xcb_window_t child; + int16_t root_x; + int16_t root_y; + int16_t event_x; + int16_t event_y; + uint16_t state; + uint8_t same_screen; + uint8_t pad0; +} xcb_motion_notify_event_t; + +typedef enum xcb_notify_detail_t { + XCB_NOTIFY_DETAIL_ANCESTOR = 0, + XCB_NOTIFY_DETAIL_VIRTUAL = 1, + XCB_NOTIFY_DETAIL_INFERIOR = 2, + XCB_NOTIFY_DETAIL_NONLINEAR = 3, + XCB_NOTIFY_DETAIL_NONLINEAR_VIRTUAL = 4, + XCB_NOTIFY_DETAIL_POINTER = 5, + XCB_NOTIFY_DETAIL_POINTER_ROOT = 6, + XCB_NOTIFY_DETAIL_NONE = 7 +} xcb_notify_detail_t; + +typedef enum xcb_notify_mode_t { + XCB_NOTIFY_MODE_NORMAL = 0, + XCB_NOTIFY_MODE_GRAB = 1, + XCB_NOTIFY_MODE_UNGRAB = 2, + XCB_NOTIFY_MODE_WHILE_GRABBED = 3 +} xcb_notify_mode_t; + +/** Opcode for xcb_configure_request. */ +#define XCB_CONFIGURE_REQUEST 23 + +/** + * @brief xcb_configure_request_event_t + **/ +typedef struct xcb_configure_request_event_t { + uint8_t response_type; + uint8_t stack_mode; + uint16_t sequence; + xcb_window_t parent; + xcb_window_t window; + xcb_window_t sibling; + int16_t x; + int16_t y; + uint16_t width; + uint16_t height; + uint16_t border_width; + uint16_t value_mask; +} xcb_configure_request_event_t; + +/** Opcode for xcb_resize_request. */ +#define XCB_RESIZE_REQUEST 25 + +/** + * @brief xcb_resize_request_event_t + **/ +typedef struct xcb_resize_request_event_t { + uint8_t response_type; + uint8_t pad0; + uint16_t sequence; + xcb_window_t window; + uint16_t width; + uint16_t height; +} xcb_resize_request_event_t;*) diff --git a/src/xcb/functions.ml b/src/xcb/functions.ml deleted file mode 100644 index 91ad4ed..0000000 --- a/src/xcb/functions.ml +++ /dev/null @@ -1,53 +0,0 @@ -open Ctypes -open Foreign - -let xcb_connect = - foreign "xcb_connect" - (string_opt @-> ptr int @-> returning (ptr Types.connection)) - -let disconnect = - foreign "xcb_disconnect" (ptr Types.connection @-> returning void) - -let flush = foreign "xcb_flush" (ptr Types.connection @-> returning int) - -let connect () = - let screen = allocate int 0 in - xcb_connect None screen - -let get_setup = - foreign "xcb_get_setup" (ptr Types.connection @-> returning (ptr Types.setup)) - -let setup_roots_iterator = - foreign "xcb_setup_roots_iterator" - (ptr Types.setup @-> returning Types.screen_iterator) - -let scr conn = getf (setup_roots_iterator (get_setup conn)) Types.data -let root_window conn : Types.window = getf !@(scr conn) Types.root - -let values = - CArray.of_list uint32_t - [ Unsigned.UInt32.of_int (1048576 lor 524288 lor 131072 lor 4194304) ] - -let xcb_change_window_attributes_checked = - foreign "xcb_change_window_attributes_checked" - (ptr Types.connection @-> uint32_t @-> uint32_t @-> ptr uint32_t - @-> returning Types.void_cookie) - -let xcb_request_check = - foreign "xcb_request_check" - (ptr Types.connection @-> Types.void_cookie - @-> returning (ptr_opt Types.generic_error)) - -let window_attribute_setup conn = - let cookie = - xcb_change_window_attributes_checked conn (root_window conn) - (Unsigned.UInt32.of_int 2048) - (CArray.start values) - in - - match xcb_request_check conn cookie with - | None -> print_endline "WM ownership acquired" - | Some _ -> print_endline "another WM already owns the display" - -let connection_has_error = - foreign "xcb_connection_has_error" (ptr Types.connection @-> returning int) diff --git a/src/xcb/screen.ml b/src/xcb/screen.ml new file mode 100644 index 0000000..09ef125 --- /dev/null +++ b/src/xcb/screen.ml @@ -0,0 +1,25 @@ +open Ctypes +open Foreign +open Ctypes + +type t + +let typ : t structure typ = structure "xcb_screen_t" +let root = field typ "root" Window.typ +let default_colormap = field typ "default_colormap" uint32_t +let white_pixel = field typ "white_pixel" uint32_t +let black_pixel = field typ "black_pixel" uint32_t +let current_input_masks = field typ "current_input_masks" uint32_t +let width_in_pixels = field typ "width_in_pixels" uint16_t +let height_in_pixels = field typ "height_in_pixels" uint16_t +let width_in_millimeters = field typ "width_in_millimeters" uint16_t +let height_in_millimeters = field typ "height_in_millimeters" uint16_t +let min_installed_maps = field typ "min_installed_maps" uint16_t +let max_installed_maps = field typ "max_installed_maps" uint16_t +let root_visual = field typ "root_visual" uint32_t +let backing_stores = field typ "backing_stores" uint8_t +let save_unders = field typ "save_unders" uint8_t +let root_depth = field typ "root_depth" uint8_t +let allowed_depths_len = field typ "allowed_depths_len" uint8_t +let () = seal typ +let root ptr = getf ptr root diff --git a/src/xcb/screen_iterator.ml b/src/xcb/screen_iterator.ml new file mode 100644 index 0000000..41df3ac --- /dev/null +++ b/src/xcb/screen_iterator.ml @@ -0,0 +1,22 @@ +open Ctypes +open Foreign + +module Setup = struct + type t + + let typ : t structure typ = structure "xcb_setup_t" + let get = foreign "xcb_get_setup" (ptr Connection.typ @-> returning (ptr typ)) +end + +type t + +let typ : t structure typ = structure "xcb_screen_iterator_t" +let data = field typ "data" (ptr Screen.typ) +let rem = field typ "rem" int +let index = field typ "index" int +let () = seal typ + +let _xcb_get = + foreign "xcb_setup_roots_iterator" (ptr Setup.typ @-> returning typ) + +let screen conn = !@(getf (_xcb_get (Setup.get conn)) data) diff --git a/src/xcb/types.ml b/src/xcb/types.ml deleted file mode 100644 index 3b211f3..0000000 --- a/src/xcb/types.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Ctypes -open Foreign - -type connection -type screen -type screen_iterator -type setup -type window = Unsigned.UInt32.t -type void_cookie -type generic_error - -let generic_error : generic_error structure typ = - structure "xcb_generic_error_t" - -let void_cookie : void_cookie structure typ = structure "xcb_void_cookie_t" -let sequence = field void_cookie "sequence" uint32_t -let () = seal void_cookie -let screen : screen structure typ = structure "xcb_screen_t" -let root = field screen "root" uint32_t -let default_colormap = field screen "default_colormap" uint32_t -let white_pixel = field screen "white_pixel" uint32_t -let black_pixel = field screen "black_pixel" uint32_t -let current_input_masks = field screen "current_input_masks" uint32_t -let width_in_pixels = field screen "width_in_pixels" uint16_t -let height_in_pixels = field screen "height_in_pixels" uint16_t -let width_in_millimeters = field screen "width_in_millimeters" uint16_t -let height_in_millimeters = field screen "height_in_millimeters" uint16_t -let min_installed_maps = field screen "min_installed_maps" uint16_t -let max_installed_maps = field screen "max_installed_maps" uint16_t -let root_visual = field screen "root_visual" uint32_t -let backing_stores = field screen "backing_stores" uint8_t -let save_unders = field screen "save_unders" uint8_t -let root_depth = field screen "root_depth" uint8_t -let allowed_depths_len = field screen "allowed_depths_len" uint8_t -let () = seal screen - -let screen_iterator : screen_iterator structure typ = - structure "xcb_screen_iterator_t" - -let data = field screen_iterator "data" (ptr screen) -let rem = field screen_iterator "rem" int -let index = field screen_iterator "index" int -let () = seal screen_iterator -let setup : setup structure typ = structure "xcb_setup_t" -let connection : connection structure typ = structure "xcb_connection_t" diff --git a/src/xcb/utils.ml b/src/xcb/utils.ml new file mode 100644 index 0000000..e1a2332 --- /dev/null +++ b/src/xcb/utils.ml @@ -0,0 +1,15 @@ +open Ctypes +open Foreign + +let values = + CArray.of_list uint32_t + [ Unsigned.UInt32.of_int (1048576 lor 524288 lor 131072 lor 4194304) ] + +let setup conn = + let scr = Screen_iterator.screen conn in + let cookie = + Cookie.Void._xcb_change_window_attributes_checked conn (Screen.root scr) + (Unsigned.UInt32.of_int 2048) + (CArray.start values) + in + Error.check conn cookie diff --git a/src/xcb/window.ml b/src/xcb/window.ml new file mode 100644 index 0000000..bd0de77 --- /dev/null +++ b/src/xcb/window.ml @@ -0,0 +1,7 @@ +open Ctypes +open Foreign + +type t = Unsigned.UInt32.t + +let typ : t Ctypes.typ = Ctypes.uint32_t +let of_int x = Unsigned.UInt32.of_int x