From 45ef92f27eca9c63f5a39b6d0f3f98c6bbb8447c Mon Sep 17 00:00:00 2001 From: Syed Daanish Date: Sun, 26 Jul 2026 14:45:58 +0100 Subject: [PATCH] Setup proper WM lifecycle and xcb bindings --- src/main.ml | 43 ++++- src/xcb/connection.ml | 13 +- src/xcb/cookie.ml | 21 ++- src/xcb/error.ml | 13 +- src/xcb/event.ml | 323 +++++++---------------------------- src/xcb/reply.ml | 16 ++ src/xcb/screen.ml | 25 --- src/xcb/screen_iterator.ml | 22 +-- src/xcb/types.ml | 340 +++++++++++++++++++++++++++++++++++++ src/xcb/utils.ml | 15 +- src/xcb/window.ml | 76 ++++++++- 11 files changed, 559 insertions(+), 348 deletions(-) create mode 100644 src/xcb/reply.ml delete mode 100644 src/xcb/screen.ml create mode 100644 src/xcb/types.ml diff --git a/src/main.ml b/src/main.ml index c13c181..acc8e34 100644 --- a/src/main.ml +++ b/src/main.ml @@ -8,22 +8,51 @@ let spawn cmd = Unix.execvp cmd.(0) cmd | _pid -> () +type wm_state = { + mutable running : bool; + conn : Xcb.Types.Connection.conn_ptr; + root : Xcb.Types.Window.t; + mutable focus : Xcb.Types.Window.t; +} + let () = let conn = Xcb.Connection.connect () in print_endline "Connected to X"; - Xcb.Utils.setup conn; + let root = Xcb.Utils.get_root conn in + + let state = { running = true; conn; root; focus = root } in + + Xcb.Window.setup conn root; + Xcb.Window.keybind conn root 0 24; + Xcb.Window.keybind conn root 0 25; + Xcb.Window.keybind conn root 0 26; if Xcb.Connection.flush conn <= 0 then exit 1; - spawn [| "kitty" |]; - - while true do - if Xcb.Connection.flush conn <= 0 then exit 1; + while state.running do + (match Xcb.Event.next conn with + | None -> () + | Some ev -> + (match Xcb.Event.rtype ev with + | KeyPress -> ( + let key = Xcb.Event.Key.detail (Xcb.Event.Key.from ev) in + match key with + | 26 -> state.running <- false + | 25 -> spawn [| "kitty" |] + | 24 -> Xcb.Window.kill state.conn state.focus + | _ -> ()) + | MapRequest -> + let req = Xcb.Types.Events.Map_request.from ev in + let window = Xcb.Types.Events.Map_request.window req in + state.focus <- window; + Xcb.Window.map state.conn window + | _ -> ()); + Xcb.Utils.free ev); + if Xcb.Connection.flush state.conn <= 0 then exit 1; Unix.sleepf 0.01 done; - Xcb.Connection.disconnect conn; - + Xcb.Connection.disconnect state.conn; print_endline "done" diff --git a/src/xcb/connection.ml b/src/xcb/connection.ml index 43974b5..1ef94bd 100644 --- a/src/xcb/connection.ml +++ b/src/xcb/connection.ml @@ -1,15 +1,14 @@ 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)) + foreign "xcb_connect" + (string_opt @-> ptr int @-> returning (ptr Types.Connection.typ)) -let disconnect = foreign "xcb_disconnect" (ptr typ @-> returning void) -let flush = foreign "xcb_flush" (ptr typ @-> returning int) +let disconnect = + foreign "xcb_disconnect" (ptr Types.Connection.typ @-> returning void) + +let flush = foreign "xcb_flush" (ptr Types.Connection.typ @-> returning int) let connect () = let screen = allocate int 0 in diff --git a/src/xcb/cookie.ml b/src/xcb/cookie.ml index 8330ee8..fe83c6c 100644 --- a/src/xcb/cookie.ml +++ b/src/xcb/cookie.ml @@ -1,15 +1,18 @@ open Ctypes open Foreign -module Void = struct - type t +module Atom = struct + let _xcb_intern_atom = + foreign "xcb_intern_atom" + (ptr Types.Connection.typ @-> uint8_t @-> uint16_t @-> string + @-> returning Types.Cookie.Atom.typ) - let typ : t structure typ = structure "xcb_void_cookie_t" - let sequence = field typ "sequence" uint32_t - let () = seal typ + let intern conn only_if_exists name = + _xcb_intern_atom conn + (Unsigned.UInt8.of_int (if only_if_exists then 1 else 0)) + (Unsigned.UInt16.of_int (String.length name)) + name - let _xcb_change_window_attributes_checked = - foreign "xcb_change_window_attributes_checked" - (ptr Connection.typ @-> uint32_t @-> uint32_t @-> ptr uint32_t - @-> returning typ) + let wm_protocols conn = intern conn true "WM_PROTOCOLS" + let wm_delete_window conn = intern conn false "WM_DELETE_WINDOW" end diff --git a/src/xcb/error.ml b/src/xcb/error.ml index 46913e9..4eb5578 100644 --- a/src/xcb/error.ml +++ b/src/xcb/error.ml @@ -1,18 +1,15 @@ 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)) + (ptr Types.Connection.typ @-> Types.Cookie.Void.typ + @-> returning (ptr_opt Types.Error.typ)) let has_error = - foreign "xcb_connection_has_error" (ptr Connection.typ @-> returning int) + foreign "xcb_connection_has_error" (ptr Types.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" + | None -> () + | Some _ -> prerr_endline "failiure" diff --git a/src/xcb/event.ml b/src/xcb/event.ml index 3dc9c68..5effe0e 100644 --- a/src/xcb/event.ml +++ b/src/xcb/event.ml @@ -1,271 +1,72 @@ open Ctypes open Foreign -type generic_event +type event = + | Enter + | Leave + | KeyPress + | KeyRelease + | MousePress + | MouseMove + | MouseRelease + | Create + | Destroy + | Unmap + | Map + | MapRequest + | ConfigureRequest + | ResizeRequest + | Unknown -let generic_event : generic_event structure typ = - structure "xcb_generic_event_t" +let event_of_int = function + | 7 -> Enter + | 8 -> Leave + | 2 -> KeyPress + | 3 -> KeyRelease + | 4 -> MousePress + | 6 -> MouseMove + | 5 -> MouseRelease + | 16 -> Create + | 17 -> Destroy + | 18 -> Unmap + | 19 -> Map + | 20 -> MapRequest + | 23 -> ConfigureRequest + | 25 -> ResizeRequest + | _ -> Unknown -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 +module Key = struct + open Ctypes -(* TODO: convert all these: -/* Opcode for xcb_create_notify. */ -#define XCB_CREATE_NOTIFY 16 + type t -/** - * @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; + let typ : t structure typ = structure "xcb_key_event_t" + let response_type = field typ "response_type" uint8_t + let detail = field typ "detail" uint8_t + let sequence = field typ "sequence" uint16_t + let time = field typ "time" uint32_t + let root = field typ "root" uint32_t + let event = field typ "event" uint32_t + let child = field typ "child" uint32_t + let root_x = field typ "root_x" int16_t + let root_y = field typ "root_y" int16_t + let event_x = field typ "event_x" int16_t + let event_y = field typ "event_y" int16_t + let state = field typ "state" uint16_t + let same_screen = field typ "same_screen" uint8_t + let pad0 = field typ "pad0" uint8_t + let () = seal typ + let from ptr = Ctypes.from_voidp typ (to_voidp ptr) + let detail ptr = getf !@ptr detail |> Unsigned.UInt8.to_int +end -/** Opcode for xcb_destroy_notify. */ -#define XCB_DESTROY_NOTIFY 17 +let rtype ptr = + Types.Event.response_type ptr |> Unsigned.UInt8.to_int |> event_of_int -/** - * @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; +let _next = + foreign "xcb_poll_for_event" + (ptr Types.Connection.typ @-> returning (ptr Types.Event.typ)) -/** 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;*) +let next conn = + let ptr = _next conn in + if ptr = from_voidp Types.Event.typ null then None else Some ptr diff --git a/src/xcb/reply.ml b/src/xcb/reply.ml new file mode 100644 index 0000000..7038a65 --- /dev/null +++ b/src/xcb/reply.ml @@ -0,0 +1,16 @@ +open Ctypes +open Foreign + +let _xcb_intern_atom_reply = + foreign "xcb_intern_atom_reply" + (ptr Types.Connection.typ @-> Types.Cookie.Atom.typ @-> ptr_opt void + @-> returning (ptr Types.Reply.typ)) + +let get conn cookie = + let reply = _xcb_intern_atom_reply conn cookie None in + if is_null reply then None + else begin + let atom = Types.Reply.get_atom reply in + Utils.free (to_voidp reply); + Some atom + end diff --git a/src/xcb/screen.ml b/src/xcb/screen.ml deleted file mode 100644 index 09ef125..0000000 --- a/src/xcb/screen.ml +++ /dev/null @@ -1,25 +0,0 @@ -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 index 41df3ac..7767abf 100644 --- a/src/xcb/screen_iterator.ml +++ b/src/xcb/screen_iterator.ml @@ -1,22 +1,12 @@ 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 get = + foreign "xcb_get_setup" + (ptr Types.Connection.typ @-> returning (ptr Types.Setup.typ)) let _xcb_get = - foreign "xcb_setup_roots_iterator" (ptr Setup.typ @-> returning typ) + foreign "xcb_setup_roots_iterator" + (ptr Types.Setup.typ @-> returning Types.Screen_iterator.typ) -let screen conn = !@(getf (_xcb_get (Setup.get conn)) data) +let screen conn = get conn |> _xcb_get |> Types.Screen_iterator.screen diff --git a/src/xcb/types.ml b/src/xcb/types.ml new file mode 100644 index 0000000..7bb3c72 --- /dev/null +++ b/src/xcb/types.ml @@ -0,0 +1,340 @@ +open Ctypes +open Foreign + +module Connection = struct + type t + type conn_ptr = t structure ptr + + let typ : t structure typ = structure "xcb_connection_t" +end + +module Window = struct + type t = Unsigned.UInt32.t + + let typ : t Ctypes.typ = Ctypes.uint32_t + let of_int x = Unsigned.UInt32.of_int x +end + +module Cookie = struct + 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 + end + + module Atom = struct + type t + + let typ : t structure typ = structure "xcb_intern_atom_cookie_t" + let sequence = field typ "sequence" uint32_t + let () = seal typ + end +end + +module Error = struct + type t + + let typ : t structure typ = structure "xcb_generic_error_t" +end + +module Event = struct + type t + + let typ : t structure typ = structure "xcb_generic_event_t" + let response_type = field typ "response_type" uint8_t + let pad0 = field typ "pad0" uint8_t + let sequence = field typ "sequence" uint16_t + let pad = field typ "pad" (array 7 uint32_t) + let full_sequence = field typ "full_sequence" uint32_t + let () = seal typ + let response_type ptr = getf !@ptr response_type +end + +module Events = struct + module Map_request = struct + open Ctypes + + type t + + let typ : t structure typ = structure "xcb_map_request_event_t" + let response_type = field typ "response_type" uint8_t + let pad0 = field typ "pad0" uint8_t + let sequence = field typ "sequence" uint16_t + let parent = field typ "parent" uint32_t + let window = field typ "window" Window.typ + let () = seal typ + let from ptr = Ctypes.from_voidp typ (to_voidp ptr) + let window ptr = getf !@ptr window + end +end + +module Client_message = struct + type t + + let typ : t structure typ = structure "xcb_client_message_event_t" + let response_type = field typ "response_type" uint8_t + let format = field typ "format" uint8_t + let sequence = field typ "sequence" uint16_t + let window = field typ "window" Window.typ + let type_ = field typ "type" uint32_t + let data = field typ "data" (array 5 uint32_t) + let () = seal typ + let ptr ev = to_voidp (addr ev) |> from_voidp char +end + +module Atom = struct + type t = Unsigned.UInt32.t + + let typ : t Ctypes.typ = Ctypes.uint32_t +end + +module Reply = struct + type t + + let typ : t structure typ = structure "xcb_intern_atom_reply_t" + let response_type = field typ "response_type" uint8_t + let pad0 = field typ "pad0" uint8_t + let sequence = field typ "sequence" uint16_t + let length = field typ "length" uint32_t + let atom = field typ "atom" Atom.typ + let () = seal typ + let get_atom ptr = getf !@ptr atom +end + +module Screen = struct + 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 +end + +module Setup = struct + type t + + let typ : t structure typ = structure "xcb_setup_t" +end + +module Screen_iterator = struct + 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 screen ptr = !@(getf ptr data) +end + +(* TODO: convert all these: +/* Opcode for xcb_create_notify. */ +/** + * @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; + +/** + * @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; + +/** + * @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; +/** + * @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; + + + +/** + * @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; + + +typedef xcb_enter_notify_event_t xcb_leave_notify_event_t; + + + + +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; + + +/** + * @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; + + +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; + + +/** + * @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; + + +/** + * @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; + + +/** + * @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/utils.ml b/src/xcb/utils.ml index e1a2332..798424c 100644 --- a/src/xcb/utils.ml +++ b/src/xcb/utils.ml @@ -1,15 +1,6 @@ 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 +let get_root conn = Screen_iterator.screen conn |> Types.Screen.root +let _free = foreign "free" (ptr void @-> returning void) +let free x = _free (to_voidp x) diff --git a/src/xcb/window.ml b/src/xcb/window.ml index bd0de77..e6f31f5 100644 --- a/src/xcb/window.ml +++ b/src/xcb/window.ml @@ -1,7 +1,77 @@ open Ctypes open Foreign -type t = Unsigned.UInt32.t +let _xcb_change_window_attributes_checked = + foreign "xcb_change_window_attributes_checked" + (ptr Types.Connection.typ @-> Types.Window.typ @-> uint32_t @-> ptr uint32_t + @-> returning Types.Cookie.Void.typ) -let typ : t Ctypes.typ = Ctypes.uint32_t -let of_int x = Unsigned.UInt32.of_int x +let values = + CArray.of_list uint32_t + [ Unsigned.UInt32.of_int (1048576 lor 524288 lor 131072 lor 4194304) ] + +let setup conn root = + let cookie = + _xcb_change_window_attributes_checked conn root + (Unsigned.UInt32.of_int 2048) + (CArray.start values) + in + Error.check conn cookie + +let _xcb_grab_key = + foreign "xcb_grab_key" + (ptr Types.Connection.typ @-> uint8_t @-> Types.Window.typ @-> uint16_t + @-> uint8_t @-> uint8_t @-> uint8_t + @-> returning Types.Cookie.Void.typ) + +let keybind conn window modifier key = + let cookie = + _xcb_grab_key conn (Unsigned.UInt8.of_int 0) window + (Unsigned.UInt16.of_int modifier) + (Unsigned.UInt8.of_int key) + (Unsigned.UInt8.of_int 1) (Unsigned.UInt8.of_int 1) + in + Error.check conn cookie + +let _xcb_map_window = + foreign "xcb_map_window" + (ptr Types.Connection.typ @-> Types.Window.typ + @-> returning Types.Cookie.Void.typ) + +let map conn window = + let cookie = _xcb_map_window conn window in + Error.check conn cookie + +let _xcb_kill_client = + foreign "xcb_kill_client" + (ptr Types.Connection.typ @-> Types.Window.typ + @-> returning Types.Cookie.Void.typ) + +let force_kill conn window = ignore (_xcb_kill_client conn window) + +let _xcb_send_event = + foreign "xcb_send_event" + (ptr Types.Connection.typ @-> uint8_t @-> Types.Window.typ @-> uint32_t + @-> ptr char + @-> returning Types.Cookie.Void.typ) + +let kill conn window = + let protocols_cookie = Cookie.Atom.wm_protocols conn in + let delete_cookie = Cookie.Atom.wm_delete_window conn in + match (Reply.get conn protocols_cookie, Reply.get conn delete_cookie) with + | Some protocols, Some delete_window -> + let ev = make Types.Client_message.typ in + setf ev Types.Client_message.response_type (Unsigned.UInt8.of_int 33); + setf ev Types.Client_message.window window; + setf ev Types.Client_message.type_ protocols; + setf ev Types.Client_message.format (Unsigned.UInt8.of_int 32); + let data = getf ev Types.Client_message.data in + CArray.set data 0 delete_window; + CArray.set data 1 (Unsigned.UInt32.of_int 0); + let cookie = + _xcb_send_event conn (Unsigned.UInt8.of_int 0) window + (Unsigned.UInt32.of_int 0) + (Types.Client_message.ptr ev) + in + Error.check conn cookie + | _ -> force_kill conn window