Arrange xcb bindings properly

flake.nix

@@ -11,24 +11,19 @@
       mruby = pkgs.stdenv.mkDerivation {
         pname = "mruby";
         version = "0.0.1";
-
         src = pkgs.lib.cleanSourceWith {
           src = ./libs;
           name = "mruby-src";
         };
-
         patches = [ ./libs/changes.patch ];
-
         nativeBuildInputs = with pkgs; [
           ruby
           gnumake
           gcc
         ];
-
         buildPhase = ''
           (cd mruby && rake)
         '';
-
         installPhase = ''
           mkdir -p $out
           cp -r mruby/build/host/lib $out/
@@ -38,15 +33,12 @@
       kutu = pkgs.stdenv.mkDerivation {
         pname = "kutu";
         version = "0.1.0";
-
         src = ./.;
-
         nativeBuildInputs = with pkgs; [
           dune_3
           ocaml
           ocamlPackages.findlib
         ];
-
         buildInputs = with pkgs; [
           libxcb
           xcbutilwm
@@ -54,30 +46,18 @@
           ocamlPackages.ctypes-foreign
           mruby
         ];
-
         buildPhase = ''
           export MRUBY_LIB=${mruby}/lib
           dune build src/main.exe --release
         '';
-
         installPhase = ''
           mkdir -p $out/bin
           cp _build/default/src/main.exe $out/bin/kutu
         '';
       };
 
-    in
+      kutu-run = pkgs.writeShellScriptBin "kutu-run" ''
-    {
+        set -e
-      packages.${system} = {
-        default = kutu;
-        kutu = kutu;
-        mruby = mruby;
-      };
-
-      apps.${system}.default = {
-        type = "app";
-        program = "${pkgs.writeShellScript "kutu-run" ''
-          set -e
           if [ -z "$DISPLAY" ]; then
             exec ${pkgs.xinit}/bin/startx \
               ${kutu}/bin/kutu \
@@ -97,7 +77,18 @@
             DISPLAY=$DISPLAY_NUM ${kutu}/bin/kutu
             echo "Returned: $?"
           fi
-        ''}";
+      '';
+    in
+    {
+      packages.${system} = {
+        default = kutu;
+        kutu = kutu;
+        mruby = mruby;
+      };
+
+      apps.${system}.default = {
+        type = "app";
+        program = "${kutu-run}/bin/kutu-run";
       };
 
       devShells.${system}.default = pkgs.mkShell {

src/dune

@@ -1,3 +1,5 @@
+(include_subdirs qualified)
+
 (executable
  (name main)
  (libraries ctypes-foreign)

src/main.ml

@@ -1,20 +1,29 @@
-open Ctypes
+let spawn cmd =
-open Foreign
+  match Unix.fork () with
-
+  | 0 ->
-type mrb = unit ptr
+      let devnull = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o666 in
-
+      Unix.dup2 devnull Unix.stdout;
-let mrb : mrb typ = ptr void
+      Unix.dup2 devnull Unix.stderr;
-let mrb_open = foreign "mrb_open" (void @-> returning mrb)
+      Unix.close devnull;
-let mrb_close = foreign "mrb_close" (mrb @-> returning void)
+      Unix.execvp cmd.(0) cmd
-
+  | _pid -> ()
-let mrb_load_string =
-  foreign "mrb_load_string" (mrb @-> string @-> returning void)
 
 let () =
-  let mrb_instance = mrb_open () in
+  let conn = Xcb.Connection.connect () in
 
-  print_endline "Executing Ruby code from OCaml:";
+  print_endline "Connected to X";
-  let _ = mrb_load_string mrb_instance "puts 'hello1234'.match?(/hello\\d+/)" in
 
-  mrb_close mrb_instance;
+  Xcb.Utils.setup conn;
-  print_endline "mruby instance closed successfully."
+
+  if Xcb.Connection.flush conn <= 0 then exit 1;
+
+  spawn [| "kitty" |];
+
+  while true do
+    if Xcb.Connection.flush conn <= 0 then exit 1;
+    Unix.sleepf 0.01
+  done;
+
+  Xcb.Connection.disconnect conn;
+
+  print_endline "done"

src/mruby.ml

@@ -0,0 +1,11 @@
+open Ctypes
+open Foreign
+
+type mrb = unit ptr
+
+let mrb : mrb typ = ptr void
+let mrb_open = foreign "mrb_open" (void @-> returning mrb)
+let mrb_close = foreign "mrb_close" (mrb @-> returning void)
+
+let mrb_load_string =
+  foreign "mrb_load_string" (mrb @-> string @-> returning void)

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

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

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"

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;*)

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

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)

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

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