diff --git a/flake.nix b/flake.nix index 9df979e..357cb16 100644 --- a/flake.nix +++ b/flake.nix @@ -26,7 +26,8 @@ ''; installPhase = '' mkdir -p $out - cp -r mruby/build/host/lib $out/ + cp -r mruby/build/host/lib $out + cp -r mruby/build/host/include $out ''; }; @@ -48,6 +49,7 @@ ]; buildPhase = '' export MRUBY_LIB=${mruby}/lib + export MRUBY_HEADERS=${mruby}/include dune build src/main.exe --release ''; installPhase = '' @@ -102,6 +104,7 @@ shellHook = '' export MRUBY_LIB=${mruby}/lib + export MRUBY_HEADERS=${mruby}/include ''; }; }; diff --git a/src/bindings/core.ml b/src/bindings/core.ml new file mode 100644 index 0000000..142ffaa --- /dev/null +++ b/src/bindings/core.ml @@ -0,0 +1,19 @@ +open Ctypes +open Foreign + +let register_exit (state : Kutu.State.wm_state) = + let exit (mrb : Mruby.Types.Mrb_state.t structure ptr) + (self : Mruby.Types.Mrb_value.t structure) = + state.running <- false; + self + in + Mruby.Bindings.mrb_define_method state.mrb + (Mruby.Types.Mrb_state.get_object_class state.mrb) + "exit" exit (Unsigned.UInt32.of_int 0) + +let register_callbacks state = + register_exit state; + Window_op.register_kill state; + Window_op.register_toggle_float state; + Keybinds.register_bind state; + Keybinds.register_unbind state diff --git a/src/bindings/keybinds.ml b/src/bindings/keybinds.ml new file mode 100644 index 0000000..c1e3604 --- /dev/null +++ b/src/bindings/keybinds.ml @@ -0,0 +1,86 @@ +open Ctypes +open Foreign + +let bind_key key modifiers = + let key = Int64.of_int key in + let modifiers = Int64.of_int modifiers in + Int64.logor (Int64.shift_left modifiers 32) (Int64.logand key 0xffffffffL) + +let set_block mrb hashtbl key modifiers block = + let key_combined = bind_key key modifiers in + (match Hashtbl.find_opt hashtbl key_combined with + | Some old_block -> Mruby.Bindings.mrb_gc_unregister mrb old_block + | None -> ()); + Mruby.Bindings.mrb_gc_register mrb block; + Hashtbl.replace hashtbl key_combined block + +let register_bind (state : Kutu.State.wm_state) = + let mrb_get_args = + foreign "mrb_get_args" + (ptr Mruby.Types.Mrb_state.typ + @-> string @-> ptr int64_t @-> ptr int64_t + @-> ptr Mruby.Types.Mrb_value.typ + @-> returning int) + in + let register_keybind (mrb : Mruby.Types.Mrb_state.t structure ptr) + (self : Mruby.Types.Mrb_value.t structure) = + let key = allocate int64_t 0L in + let modifiers = allocate int64_t 0L in + let block = make Mruby.Types.Mrb_value.typ in + ignore (mrb_get_args mrb "ii&" key modifiers (addr block)); + let key = Int64.to_int !@key in + let modifiers = Int64.to_int !@modifiers in + set_block mrb state.blocks key modifiers block; + Xcb.Window.keybind state.conn state.root key modifiers; + self + in + Mruby.Bindings.mrb_define_method state.mrb + (Mruby.Types.Mrb_state.get_object_class state.mrb) + "_bind" register_keybind + (Unsigned.UInt32.logor + (Mruby.Bindings.mrb_args_req 2) + Mruby.Bindings.mrb_args_block) + +let register_unbind (state : Kutu.State.wm_state) = + let mrb_get_args = + foreign "mrb_get_args" + (ptr Mruby.Types.Mrb_state.typ + @-> string @-> ptr int64_t @-> ptr int64_t @-> returning int) + in + let unregister_keybind (mrb : Mruby.Types.Mrb_state.t structure ptr) + (self : Mruby.Types.Mrb_value.t structure) = + let key = allocate int64_t 0L in + let modifiers = allocate int64_t 0L in + ignore (mrb_get_args mrb "ii" key modifiers); + let key = Int64.to_int !@key in + let modifiers = Int64.to_int !@modifiers in + let packed_key = bind_key key modifiers in + (match Hashtbl.find_opt state.blocks packed_key with + | Some block -> + Mruby.Bindings.mrb_gc_unregister mrb block; + Hashtbl.remove state.blocks packed_key + | None -> ()); + Xcb.Window.keyunbind state.conn state.root key modifiers; + self + in + Mruby.Bindings.mrb_define_method state.mrb + (Mruby.Types.Mrb_state.get_object_class state.mrb) + "_unbind" unregister_keybind + (Mruby.Bindings.mrb_args_req 2) + +let dispatch_keybind mrb hashtbl key modifier value = + match Hashtbl.find_opt hashtbl (bind_key key modifier) with + | None -> () + | Some block -> + let arg = Mruby.Bindings.mrb_int_value mrb value in + let argv = CArray.of_list Mruby.Types.Mrb_value.typ [ arg ] in + ignore + (Mruby.Bindings.mrb_funcall_argv mrb block + (Mruby.Bindings.call_sym mrb) + (Signed.Int64.of_int 1) (CArray.start argv)) + +let cleanup mrb hashtbl = + Hashtbl.iter + (fun _ block -> Mruby.Bindings.mrb_gc_unregister mrb block) + hashtbl; + Hashtbl.clear hashtbl diff --git a/src/bindings/window_op.ml b/src/bindings/window_op.ml new file mode 100644 index 0000000..94323bf --- /dev/null +++ b/src/bindings/window_op.ml @@ -0,0 +1,85 @@ +open Ctypes +open Foreign + +let register_kill (state : Kutu.State.wm_state) = + let mrb_get_args = + foreign "mrb_get_args" + (ptr Mruby.Types.Mrb_state.typ + @-> string @-> ptr int64_t @-> returning int) + in + let kill_window (mrb : Mruby.Types.Mrb_state.t structure ptr) + (self : Mruby.Types.Mrb_value.t structure) = + let win_id = allocate int64_t 0L in + ignore (mrb_get_args mrb "i" win_id); + let id = Unsigned.UInt32.of_int64 !@win_id in + if id != state.root then Xcb.Window.kill state.conn id; + self + in + Mruby.Bindings.mrb_define_method state.mrb + (Mruby.Types.Mrb_state.get_object_class state.mrb) + "kill" kill_window + (Mruby.Bindings.mrb_args_req 1) + +let register_toggle_float (state : Kutu.State.wm_state) = + let mrb_get_args = + foreign "mrb_get_args" + (ptr Mruby.Types.Mrb_state.typ + @-> string @-> ptr int64_t @-> returning int) + in + let toggle_float (mrb : Mruby.Types.Mrb_state.t structure ptr) + (self : Mruby.Types.Mrb_value.t structure) = + let win_id = allocate int64_t 0L in + ignore (mrb_get_args mrb "i" win_id); + let window = Unsigned.UInt32.of_int64 !@win_id in + let windows = + Kutu.Layout.calculate state.screen + state.workspaces.(state.current).ws_root + in + (match Kutu.Layout.find_fwindow window windows with + | Some { fw_rect; _ } -> + begin match + Kutu.Layout.find_fwindow window + state.workspaces.(state.current).ws_fwindows + with + | Some _ -> print_endline "Error: window already floating" + | None -> + let new_root, _ = + Kutu.Layout.remove window state.workspaces.(state.current).ws_root + in + state.workspaces.(state.current).ws_root <- new_root; + state.workspaces.(state.current).ws_fwindows <- + { fw_rect; fw_window = window } + :: state.workspaces.(state.current).ws_fwindows; + Xcb.Window.move_to_top state.conn window; + List.iter + (fun { Kutu.Layout.fw_window = window; fw_rect = rect } -> + Xcb.Window.reshape state.conn window rect) + (Kutu.Layout.calculate state.screen + state.workspaces.(state.current).ws_root) + end + | None -> + begin match + Kutu.Layout.find_fwindow window + state.workspaces.(state.current).ws_fwindows + with + | Some _ -> + state.workspaces.(state.current).ws_fwindows <- + Kutu.Layout.remove_fwindow window + state.workspaces.(state.current).ws_fwindows; + Xcb.Window.move_to_bottom state.conn window; + state.workspaces.(state.current).ws_root <- + Kutu.Layout.insert Kutu.Layout.Horizontal window + state.workspaces.(state.current).ws_root; + List.iter + (fun { Kutu.Layout.fw_window = window; fw_rect = rect } -> + Xcb.Window.reshape state.conn window rect) + (Kutu.Layout.calculate state.screen + state.workspaces.(state.current).ws_root) + | None -> print_endline "Error: window is neither tiled nor floating" + end); + self + in + Mruby.Bindings.mrb_define_method state.mrb + (Mruby.Types.Mrb_state.get_object_class state.mrb) + "toggle_float" toggle_float + (Mruby.Bindings.mrb_args_req 1) diff --git a/src/dune b/src/dune index 55cb1d5..d4b531b 100644 --- a/src/dune +++ b/src/dune @@ -3,6 +3,12 @@ (executable (name main) (libraries ctypes-foreign) + (foreign_stubs + (language c) + (names shims) + (flags + :standard + -I%{env:MRUBY_HEADERS=../libs/mruby/build/host/include})) (flags :standard -cclib -Wl,--export-dynamic -cclib -L%{env:MRUBY_LIB=../libs/mruby/build/host/lib} diff --git a/src/kutu/events.ml b/src/kutu/events.ml new file mode 100644 index 0000000..e69de29 diff --git a/src/kutu/layout.ml b/src/kutu/layout.ml index 58ea4b0..49fd30d 100644 --- a/src/kutu/layout.ml +++ b/src/kutu/layout.ml @@ -11,7 +11,17 @@ type layout = } type fwindow = { fw_rect : Decl.Types.rect; fw_window : Xcb.Types.Window.t } -type workspace = { mutable ws_root : layout; ws_fwindows : fwindow array } + +type workspace = { + mutable ws_root : layout; + mutable ws_fwindows : fwindow list; +} + +let find_fwindow window fwindows = + List.find_opt (fun fw -> fw.fw_window = window) fwindows + +let remove_fwindow window fwindows = + List.filter (fun fw -> fw.fw_window <> window) fwindows let flip_direction = function Horizontal -> Vertical | Vertical -> Horizontal @@ -20,7 +30,7 @@ let rec insert direction window = function | Leaf { layout_window = existing } -> Split { - layout_direction = Horizontal; + layout_direction = direction; layout_ratio = 0.5; layout_l = Leaf { layout_window = existing }; layout_r = Leaf { layout_window = window }; @@ -34,6 +44,22 @@ let rec insert direction window = function layout_r = insert (flip_direction layout_direction) window layout_r; } +let rec remove window = function + | Nothing -> (Nothing, false) + | Leaf { layout_window = existing } -> + if existing = window then (Nothing, true) + else (Leaf { layout_window = existing }, false) + | Split { layout_direction; layout_ratio; layout_l; layout_r } -> ( + let l', l_removed = remove window layout_l in + let r', r_removed = remove window layout_r in + let removed = l_removed || r_removed in + match (l', r') with + | Nothing, r -> (r, removed) + | l, Nothing -> (l, removed) + | l, r -> + ( Split { layout_direction; layout_ratio; layout_l = l; layout_r = r }, + removed )) + let split_rect (rect : Decl.Types.rect) direction ratio = match direction with | Horizontal -> diff --git a/src/kutu/state.ml b/src/kutu/state.ml new file mode 100644 index 0000000..e1b5968 --- /dev/null +++ b/src/kutu/state.ml @@ -0,0 +1,29 @@ +type wm_state = { + mutable running : bool; + conn : Xcb.Types.Connection.conn_ptr; + mrb : Mruby.Types.Mrb_state.mrb_ptr; + root : Xcb.Types.Window.t; + mutable focus : Xcb.Types.Window.t; + workspaces : Layout.workspace array; + mutable current : int; + screen : Decl.Types.rect; + blocks : (int64, Mruby.Types.Mrb_value.t Ctypes.structure) Hashtbl.t; +} + +let new_state = + let conn = Xcb.Connection.connect () in + let mrb = Mruby.Core.mrb_open () in + let root = Xcb.Utils.get_root conn in + let _ = Xcb.Window.setup conn root in + { + running = true; + conn; + mrb; + root; + focus = root; + workspaces = + [| { Layout.ws_root = Layout.Nothing; Layout.ws_fwindows = [] } |]; + current = 0; + screen = Xcb.Screen_iterator.screen_rect conn; + blocks = Hashtbl.create 16; + } diff --git a/src/main.ml b/src/main.ml index 657bc5a..b424289 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,43 +1,55 @@ -type wm_state = { - mutable running : bool; - conn : Xcb.Types.Connection.conn_ptr; - mrb : Mruby.Types.Mrb_state.mrb_ptr; - root : Xcb.Types.Window.t; - mutable focus : Xcb.Types.Window.t; - workspaces : Kutu.Layout.workspace array; - mutable current : int; - screen : Decl.Types.rect; -} - let () = - let state = - let conn = Xcb.Connection.connect () in - let mrb = Mruby.Core.mrb_open in - let root = Xcb.Utils.get_root conn in - let screen = Xcb.Window.setup conn root in - { - running = true; - conn; - mrb; - root; - focus = root; - workspaces = - [| - { - Kutu.Layout.ws_root = Kutu.Layout.Nothing; - Kutu.Layout.ws_fwindows = [||]; - }; - |]; - current = 0; - screen; - } - in + let state = Kutu.State.new_state in print_endline "Started Kutu WM"; - Xcb.Window.keybind state.conn state.root 0 24; - Xcb.Window.keybind state.conn state.root 0 25; - Xcb.Window.keybind state.conn state.root 0 26; + Bindings.Core.register_callbacks state; + Mruby.Core.mrb_load_string state.mrb + {| + MOD_MAP = { + none: 0, + alt: 8, + super: 64 + } + KEY_MAP = { + "q" => 24, + "w" => 25, + "e" => 26, + "r" => 27, + "f" => 41 + } + def bind(key, mod = :alt, &block) + key = KEY_MAP[key] + mod = MOD_MAP[mod] + raise "unknown key" unless key + raise "unknown modifier" unless mod + _bind key, mod, &block + end + def unbind(key, mod = :alt) + key = KEY_MAP[key] + mod = MOD_MAP[mod] + raise "unknown key" unless key + raise "unknown modifier" unless mod + _unbind key, mod + end + + bind ?q do |x| + kill x + end + bind ?w do |x| + system "kitty >/dev/null 2>&1 &" + end + bind ?e do |x| + exit + end + bind ?r do |x| + puts "hello there!" + end + bind ?f do |x| + toggle_float x + end + |}; + Mruby.Core.error_check state.mrb; if Xcb.Connection.flush state.conn <= 0 then exit 1; @@ -46,38 +58,26 @@ let () = | 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 -> - Mruby.Core.mrb_load_string state.mrb - {| - system "kitty &" - |} - | 24 -> Xcb.Window.kill state.conn state.focus - | _ -> ()) + | KeyPress -> + let req = Xcb.Types.Events.Key.from ev in + let key = Xcb.Types.Events.Key.detail req in + let modifier = Xcb.Types.Events.Key.state req in + Bindings.Keybinds.dispatch_keybind state.mrb state.blocks key + modifier 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; - (*Kutu.Layout.ws_root state.workspaces.(state.current)) <- - Kutu.Layout.insert Kutu.Layout.Horizontal window - (Kutu.Layout.ws_root state.workspaces.(state.current)*) Xcb.Window.map state.conn window; Xcb.Window.setup_window state.conn window; Xcb.Window.focus state.conn window; + Xcb.Window.move_to_bottom state.conn window; + state.focus <- window; + state.workspaces.(state.current).ws_root <- + Kutu.Layout.insert Kutu.Layout.Horizontal window + state.workspaces.(state.current).ws_root; List.iter - (fun { - Kutu.Layout.fw_window = window; - fw_rect = - { - rect_x = x; - rect_y = y; - rect_width = width; - rect_height = height; - }; - } -> Xcb.Window.reshape state.conn window x y width height) + (fun { Kutu.Layout.fw_window = window; fw_rect = rect } -> + Xcb.Window.reshape state.conn window rect) (Kutu.Layout.calculate state.screen state.workspaces.(state.current).ws_root) | Enter -> @@ -85,6 +85,21 @@ let () = let window = Xcb.Types.Events.Enter.window req in state.focus <- window; Xcb.Window.focus state.conn window + | Destroy -> + let req = Xcb.Types.Events.Destroy.from ev in + let window = Xcb.Types.Events.Destroy.window req in + let new_root, removed = + Kutu.Layout.remove window state.workspaces.(state.current).ws_root + (* TODO: Handle floating windows too. *) + in + state.workspaces.(state.current).ws_root <- new_root; + Xcb.Window.focus state.conn state.root; + state.focus <- state.root; + List.iter + (fun { Kutu.Layout.fw_window = window; fw_rect = rect } -> + Xcb.Window.reshape state.conn window rect) + (Kutu.Layout.calculate state.screen + state.workspaces.(state.current).ws_root) | _ -> ()); Xcb.Utils.free ev); Mruby.Core.error_check state.mrb; @@ -92,6 +107,7 @@ let () = Unix.sleepf 0.01 done; + Bindings.Keybinds.cleanup state.mrb state.blocks; Mruby.Core.mrb_close state.mrb; Xcb.Connection.disconnect state.conn; print_endline "Closing up Kutu WM" diff --git a/src/mruby/bindings.ml b/src/mruby/bindings.ml new file mode 100644 index 0000000..b0a9fb9 --- /dev/null +++ b/src/mruby/bindings.ml @@ -0,0 +1,41 @@ +open Ctypes +open Foreign + +let mrb_args_block = Unsigned.UInt32.of_int 1 + +let mrb_args_req n = + Unsigned.UInt32.shift_left (Unsigned.UInt32.of_int (n land 0x1f)) 18 + +let callback_typ = + Foreign.funptr + (ptr Types.Mrb_state.typ @-> Types.Mrb_value.typ + @-> returning Types.Mrb_value.typ) + +let mrb_define_method = + foreign "mrb_define_method" + (ptr Types.Mrb_state.typ @-> ptr Types.Mrb_class.typ @-> string + @-> callback_typ @-> uint32_t @-> returning void) + +let mrb_gc_register = + foreign "mrb_gc_register" + (ptr Types.Mrb_state.typ @-> Types.Mrb_value.typ @-> returning void) + +let mrb_gc_unregister = + foreign "mrb_gc_unregister" + (ptr Types.Mrb_state.typ @-> Types.Mrb_value.typ @-> returning void) + +let mrb_int_value = + foreign "kutu_mrb_int_value" + (ptr Types.Mrb_state.typ @-> uint32_t @-> returning Types.Mrb_value.typ) + +let mrb_intern_cstr = + foreign "mrb_intern_cstr" + (ptr Types.Mrb_state.typ @-> string @-> returning Types.Mrb_sym.typ) + +let call_sym mrb = mrb_intern_cstr mrb "call" + +let mrb_funcall_argv = + foreign "mrb_funcall_argv" + (ptr Types.Mrb_state.typ @-> Types.Mrb_value.typ @-> Types.Mrb_sym.typ + @-> int64_t @-> ptr Types.Mrb_value.typ + @-> returning Types.Mrb_value.typ) diff --git a/src/mruby/core.ml b/src/mruby/core.ml index 68fed45..4805eea 100644 --- a/src/mruby/core.ml +++ b/src/mruby/core.ml @@ -2,14 +2,12 @@ open Ctypes open Foreign let _mrb_open = foreign "mrb_open" (void @-> returning (ptr Types.Mrb_state.typ)) -let mrb_open = _mrb_open () +let mrb_open = _mrb_open let mrb_close = foreign "mrb_close" (ptr Types.Mrb_state.typ @-> returning void) let mrb_print_error = foreign "mrb_print_error" (ptr Types.Mrb_state.typ @-> returning void) -(* TODO: bind module definition and adding functions to the module thing here somehow. *) - let mrb_load_string = foreign "mrb_load_string" (ptr Types.Mrb_state.typ @-> string @-> returning void) diff --git a/src/mruby/types.ml b/src/mruby/types.ml index dd8bcf0..833b35d 100644 --- a/src/mruby/types.ml +++ b/src/mruby/types.ml @@ -1,6 +1,31 @@ open Ctypes open Foreign +module Mrb_value = struct + type t + + let typ : t structure typ = structure "mrb_value" + let value = field typ "w" uintptr_t + let () = seal typ +end + +module Mrb_sym = struct + type t + + let typ = uint32_t +end + +module Mrb_class = struct + type t + type class_ptr = t structure ptr + + let typ : t structure typ = structure "RClass" + + (* as it builds by default on x86_64 linux *) + let padding = field typ "padding" (array 40 char) + let () = seal typ +end + module Mrb_state = struct type t type mrb_ptr = t structure ptr @@ -11,9 +36,11 @@ module Mrb_state = struct let root_c = field typ "root_c" (ptr void) let globals = field typ "globals" (ptr void) let exc = field typ "exc" (ptr void) + let top_self = field typ "top_self" (ptr void) + let object_class = field typ "object_class" (ptr Mrb_class.typ) (* as it builds by default on x86_64 linux *) - let padding = field typ "padding" (array 24472 char) + let padding = field typ "padding" (array 24464 char) let () = seal typ let has_error mrb_ptr = @@ -21,4 +48,5 @@ module Mrb_state = struct not (is_null exc_val) let clear_error mrb_ptr = setf !@mrb_ptr exc null + let get_object_class mrb_ptr = getf !@mrb_ptr object_class end diff --git a/src/shims.c b/src/shims.c new file mode 100644 index 0000000..7a17151 --- /dev/null +++ b/src/shims.c @@ -0,0 +1,9 @@ +#include +#include +#include + +mrb_value +kutu_mrb_int_value(mrb_state *mrb, uint64_t value) +{ + return mrb_int_value(mrb, (mrb_int)value); +} diff --git a/src/xcb/event.ml b/src/xcb/event.ml index 5effe0e..aa5da15 100644 --- a/src/xcb/event.ml +++ b/src/xcb/event.ml @@ -35,31 +35,6 @@ let event_of_int = function | 25 -> ResizeRequest | _ -> Unknown -module Key = struct - open Ctypes - - type 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 - let rtype ptr = Types.Event.response_type ptr |> Unsigned.UInt8.to_int |> event_of_int diff --git a/src/xcb/screen_iterator.ml b/src/xcb/screen_iterator.ml index f673118..31d9fc1 100644 --- a/src/xcb/screen_iterator.ml +++ b/src/xcb/screen_iterator.ml @@ -9,8 +9,10 @@ let _xcb_get = foreign "xcb_setup_roots_iterator" (ptr Types.Setup.typ @-> returning Types.Screen_iterator.typ) -let screen conn = - let screen = get conn |> _xcb_get |> Types.Screen_iterator.screen in +let screen conn = get conn |> _xcb_get |> Types.Screen_iterator.screen + +let screen_rect conn = + let screen = screen conn in { Decl.Types.rect_x = 0; Decl.Types.rect_y = 0; diff --git a/src/xcb/types.ml b/src/xcb/types.ml index 233b0a2..37f1451 100644 --- a/src/xcb/types.ml +++ b/src/xcb/types.ml @@ -11,7 +11,7 @@ end module Window = struct type t = Unsigned.UInt32.t - let typ : t Ctypes.typ = Ctypes.uint32_t + let typ : t typ = uint32_t let of_int x = Unsigned.UInt32.of_int x end @@ -53,9 +53,32 @@ module Event = struct end module Events = struct - module Map_request = struct - open Ctypes + module Key = struct + type 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 = from_voidp typ (to_voidp ptr) + let detail ptr = getf !@ptr detail |> Unsigned.UInt8.to_int + let state ptr = getf !@ptr state |> Unsigned.UInt16.to_int + let window ptr = getf !@ptr event + end + + module Map_request = struct type t let typ : t structure typ = structure "xcb_map_request_event_t" @@ -65,13 +88,11 @@ module Events = struct 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 from ptr = from_voidp typ (to_voidp ptr) let window ptr = getf !@ptr window end module Enter = struct - open Ctypes - type t let typ : t structure typ = structure "xcb_enter_notify_event_t" @@ -90,9 +111,23 @@ module Events = struct let mode = field typ "mode" uint8_t let same_screen = field typ "same_screen_focus" uint8_t let () = seal typ - let from ptr = Ctypes.from_voidp typ (to_voidp ptr) + let from ptr = from_voidp typ (to_voidp ptr) let window ptr = getf !@ptr event end + + module Destroy = struct + type t + + let typ : t structure typ = structure "xcb_destroy_notify_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 event = field typ "event" uint32_t + let window = field typ "window" Window.typ + let () = seal typ + let from ptr = from_voidp typ (to_voidp ptr) + let window ptr = getf !@ptr window + end end module Client_message = struct @@ -112,7 +147,7 @@ end module Atom = struct type t = Unsigned.UInt32.t - let typ : t Ctypes.typ = Ctypes.uint32_t + let typ : t typ = uint32_t end module Reply = struct diff --git a/src/xcb/window.ml b/src/xcb/window.ml index 007181b..edbabf1 100644 --- a/src/xcb/window.ml +++ b/src/xcb/window.ml @@ -37,15 +37,15 @@ let _xcb_configure_window = (ptr Types.Connection.typ @-> Types.Window.typ @-> uint16_t @-> ptr uint32_t @-> returning Types.Cookie.Void.typ) -let reshape conn window x y width height = +let reshape conn window (rect : Decl.Types.rect) = let mask = (1 lsl 0) lor (1 lsl 1) lor (1 lsl 2) lor (1 lsl 3) in let values = CArray.of_list uint32_t [ - Unsigned.UInt32.of_int x; - Unsigned.UInt32.of_int y; - Unsigned.UInt32.of_int width; - Unsigned.UInt32.of_int height; + Unsigned.UInt32.of_int rect.rect_x; + Unsigned.UInt32.of_int rect.rect_y; + Unsigned.UInt32.of_int rect.rect_width; + Unsigned.UInt32.of_int rect.rect_height; ] in let cookie = @@ -55,13 +55,26 @@ let reshape conn window x y width height = in Error.check conn cookie +let set_stack_mode conn window mode = + let mask = 1 lsl 6 in + let values = CArray.of_list uint32_t [ Unsigned.UInt32.of_int mode ] in + let cookie = + _xcb_configure_window conn window + (Unsigned.UInt16.of_int mask) + (CArray.start values) + in + Error.check conn cookie + +let move_to_top conn window = set_stack_mode conn window 0 +let move_to_bottom conn window = set_stack_mode conn window 1 + 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 keybind conn window key modifier = let cookie = _xcb_grab_key conn (Unsigned.UInt8.of_int 0) window (Unsigned.UInt16.of_int modifier) @@ -70,6 +83,20 @@ let keybind conn window modifier key = in Error.check conn cookie +let _xcb_ungrab_key = + foreign "xcb_ungrab_key" + (ptr Types.Connection.typ @-> uint8_t @-> Types.Window.typ @-> uint16_t + @-> returning Types.Cookie.Void.typ) + +let keyunbind conn window key modifier = + let cookie = + _xcb_ungrab_key conn + (Unsigned.UInt8.of_int key) + window + (Unsigned.UInt16.of_int modifier) + in + Error.check conn cookie + let _xcb_map_window = foreign "xcb_map_window" (ptr Types.Connection.typ @-> Types.Window.typ