Setup proper bindings for mruby.

- and a lot more stuff.

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
         '';
       };
     };

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

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

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)

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}

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 ->

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;
+  }

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 state = Kutu.State.new_state in
-    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
 
   print_endline "Started Kutu WM";
 
-  Xcb.Window.keybind state.conn state.root 0 24;
+  Bindings.Core.register_callbacks state;
-  Xcb.Window.keybind state.conn state.root 0 25;
+  Mruby.Core.mrb_load_string state.mrb
-  Xcb.Window.keybind state.conn state.root 0 26;
+    {|
+    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 -> (
+        | KeyPress ->
-            let key = Xcb.Event.Key.detail (Xcb.Event.Key.from ev) in
+            let req = Xcb.Types.Events.Key.from ev in
-            match key with
+            let key = Xcb.Types.Events.Key.detail req in
-            | 26 -> state.running <- false
+            let modifier = Xcb.Types.Events.Key.state req in
-            | 25 ->
+            Bindings.Keybinds.dispatch_keybind state.mrb state.blocks key
-                Mruby.Core.mrb_load_string state.mrb
+              modifier state.focus
-                  {|
-                  system "kitty &"
-                  |}
-            | 24 -> Xcb.Window.kill state.conn 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 {
+              (fun { Kutu.Layout.fw_window = window; fw_rect = rect } ->
-                     Kutu.Layout.fw_window = window;
+                Xcb.Window.reshape state.conn window rect)
-                     fw_rect =
-                       {
-                         rect_x = x;
-                         rect_y = y;
-                         rect_width = width;
-                         rect_height = height;
-                       };
-                   } -> Xcb.Window.reshape state.conn window x y width height)
               (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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 conn = get conn |> _xcb_get |> Types.Screen_iterator.screen
-  let screen = get conn |> _xcb_get |> Types.Screen_iterator.screen in
+
+let screen_rect conn =
+  let screen = screen conn in
   {
     Decl.Types.rect_x = 0;
     Decl.Types.rect_y = 0;

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
+  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 = 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

@@ -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 rect.rect_x;
-        Unsigned.UInt32.of_int y;
+        Unsigned.UInt32.of_int rect.rect_y;
-        Unsigned.UInt32.of_int width;
+        Unsigned.UInt32.of_int rect.rect_width;
-        Unsigned.UInt32.of_int height;
+        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