diff --git a/src/main.ml b/src/main.ml index c7fd089..6802323 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,20 +1,22 @@ -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) +let spawn cmd = + match Unix.fork () with 0 -> Unix.execvp cmd.(0) cmd | _pid -> () let () = - let mrb_instance = mrb_open () in + let conn = Xcb.connect () in - print_endline "Executing Ruby code from OCaml:"; - let _ = mrb_load_string mrb_instance "puts 'hello1234'.match?(/hello\\d+/)" in + print_endline "connected"; - mrb_close mrb_instance; - print_endline "mruby instance closed successfully." + let _ = Xcb.window_attribute_setup conn in + + Xcb.flush conn; + + spawn [| "kitty" |]; + + while true do + Xcb.flush conn; + Unix.sleepf 0.01 + done; + + Xcb.disconnect conn; + + print_endline "done" diff --git a/src/mruby.ml b/src/mruby.ml new file mode 100644 index 0000000..61f7213 --- /dev/null +++ b/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) diff --git a/src/xcb.ml b/src/xcb.ml new file mode 100644 index 0000000..aaf18cc --- /dev/null +++ b/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"