syedm/kutu
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Setup proper bindings for mruby.

Browse Source 
- and a lot more stuff.
This commit is contained in:
syedm
2026-09-09 23:39:05 +01:00
parent 93d71d820a
commit ac72396a0f
17 changed files with 494 additions and 109 deletions
Download Patch File Download Diff File Expand all files Collapse all files
flake.nix
+4 -1
View File
@@ -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
'';
};
};
src/bindings/core.ml
+19
View File
@@ -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
src/bindings/keybinds.ml
+86
View File
@@ -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
src/bindings/window_op.ml
+85
View File
@@ -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)
src/dune
+6
View File
@@ -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}
src/kutu/events.ml
View File
src/kutu/layout.ml
+28 -2
View File
@@ -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 ->
src/kutu/state.ml
+29
View File
@@ -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;
}
src/main.ml
+77 -61
View File
@@ -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"
src/mruby/bindings.ml
+41
View File
@@ -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)
src/mruby/core.ml
+1 -3
View File
@@ -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)
src/mruby/types.ml
+29 -1
View File
@@ -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
src/shims.c
+9
View File
@@ -0,0 +1,9 @@
#include <stdint.h>
#include <mruby.h>
#include <mruby/value.h>
mrb_value
kutu_mrb_int_value(mrb_state *mrb, uint64_t value)
{
return mrb_int_value(mrb, (mrb_int)value);
}
src/xcb/event.ml
-25
View File
@@ -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
src/xcb/screen_iterator.ml
+4 -2
View File
@@ -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;
src/xcb/types.ml
+43 -8
View File
@@ -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
src/xcb/window.ml
+33 -6
View File
@@ -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