Setup basic xcb bindings and loop

src/main.ml

@@ -1,20 +1,22 @@
-open Ctypes
+let spawn cmd =
-open Foreign
+  match Unix.fork () with 0 -> Unix.execvp cmd.(0) cmd | _pid -> ()
-
-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)
 
 let () =
-  let mrb_instance = mrb_open () in
+  let conn = Xcb.connect () in
 
-  print_endline "Executing Ruby code from OCaml:";
+  print_endline "connected";
-  let _ = mrb_load_string mrb_instance "puts 'hello1234'.match?(/hello\\d+/)" in
 
-  mrb_close mrb_instance;
+  let _ = Xcb.window_attribute_setup conn in
-  print_endline "mruby instance closed successfully."
+
+  Xcb.flush conn;
+
+  spawn [| "kitty" |];
+
+  while true do
+    Xcb.flush conn;
+    Unix.sleepf 0.01
+  done;
+
+  Xcb.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.ml

@@ -0,0 +1,95 @@
+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"
+
+let xcb_connect =
+  foreign "xcb_connect" (string_opt @-> ptr int @-> returning (ptr connection))
+
+let xcb_disconnect = foreign "xcb_disconnect" (ptr connection @-> returning void)
+let xcb_flush = foreign "xcb_flush" (ptr connection @-> returning int)
+
+let connect () =
+  let screen = allocate int 0 in
+  xcb_connect None screen
+
+let disconnect conn = xcb_disconnect conn
+let flush conn = ignore (xcb_flush conn)
+
+let get_setup =
+  foreign "xcb_get_setup" (ptr connection @-> returning (ptr setup))
+
+let setup_roots_iterator =
+  foreign "xcb_setup_roots_iterator" (ptr setup @-> returning screen_iterator)
+
+let scr conn = getf (setup_roots_iterator (get_setup conn)) data
+let root_window conn : window = getf !@(scr conn) 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 connection @-> uint32_t @-> uint32_t @-> ptr uint32_t
+   @-> returning void_cookie)
+
+let xcb_request_check =
+  foreign "xcb_request_check"
+    (ptr connection @-> void_cookie @-> returning (ptr_opt 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"