Improve configs and minor bugs.

- and a lot more stuff.

.gitmodules

@@ -6,11 +6,11 @@
   path = libs/mgems/mruby-marshal-c
   url = https://github.com/LanzaSchneider/mruby-marshal-c.git
   ignore = dirty
-[submodule "libs/mgems/mruby-process"]
-  path = libs/mgems/mruby-process
-  url = https://github.com/iij/mruby-process.git
-  ignore = dirty
 [submodule "libs/mgems/mruby-env"]
   path = libs/mgems/mruby-env
   url = https://github.com/iij/mruby-env.git
   ignore = dirty
+[submodule "libs/mgems/mruby-process"]
+  path = libs/mgems/mruby-process
+  url = https://github.com/katzer/mruby-process
+  ignore = dirty

config.rb

@@ -0,0 +1,174 @@
+system 'bash ~/main/ocaml/epq/scripts/startup.sh >/dev/null 2>&1 &'
+
+MAX_PROJECTS = 3
+
+SPECIAL = {
+  term1: { cmd: 'kitty' },
+  term2: { cmd: 'kitty' },
+  browser: { cmd: 'firefox' },
+  misc: { cmd: nil }
+}
+
+$current = 0
+
+$p_sub = Array.new(9, 0)
+
+def project_ws(n)
+  :"p#{n}_#{$p_sub[$current]}"
+end
+
+def go_project(n)
+  $current = n
+  jump_ws project_ws($current)
+end
+
+def in_project?(ws)
+  !SPECIAL.key?(ws)
+end
+
+def go_special(name, ws)
+  cfg = SPECIAL.fetch(name)
+
+  if ws == name
+    target = project_ws($current)
+    jump_ws target
+  else
+    jump_ws name
+    system("#{cfg[:cmd]} >/dev/null 2>&1 &") if cfg[:cmd] && ws_empty?(name)
+  end
+end
+
+bind 'q' do |x|
+  kill x
+end
+
+bind 'w' do
+  system 'kitty >/dev/null 2>&1 &'
+end
+
+bind 'e' do
+  system 'bash ~/main/ocaml/epq/scripts/power.sh >/dev/null 2>&1 &'
+end
+
+bind 'd' do
+  system 'bash ~/main/ocaml/epq/scripts/run.sh >/dev/null 2>&1 &'
+end
+
+bind 'v' do
+  system 'CM_LAUNCHER=rofi clipmenu >/dev/null 2>&1 &'
+end
+
+bind 'a' do
+  system 'bash', '-c', "
+    maim -c 0.3,0.5,1.0,0.8 -s | tee /tmp/screenshot_temp.png | xclip -selection clipboard -t image/png;
+    if [ -s '/tmp/screenshot_temp.png' ]; then
+      mv /tmp/screenshot_temp.png ~/screenshots/$(date +%Y-%m-%d_%H:%M:%S).png;
+    fi
+  "
+end
+
+bind 123, :none do
+  system 'bash', '-c', %q(
+    pactl set-sink-volume @DEFAULT_SINK@ +5%;
+    vol=$(pactl get-sink-volume @DEFAULT_SINK@ | grep -o '[0-9]\+%' | head -n1);
+    dunstify "Volume Adjusted" "" -h int:value:$vol -r 997
+  )
+end
+
+bind 122, :none do
+  system 'bash', '-c', %q(
+    pactl set-sink-volume @DEFAULT_SINK@ -5%;
+    vol=$(pactl get-sink-volume @DEFAULT_SINK@ | grep -o '[0-9]\+%' | head -n1);
+    dunstify "Volume Adjusted" "" -h int:value:$vol -r 997
+  )
+end
+
+bind 121, :none do
+  system 'bash', '-c', %q(
+    pactl set-sink-mute @DEFAULT_SINK@ toggle;
+    vol=$(pactl get-sink-volume @DEFAULT_SINK@ | grep -o '[0-9]\+%' | head -n1);
+    dunstify "Volume Adjusted" "" -h int:value:$vol -r 997
+  )
+end
+
+bind 232, :none do
+  system 'bash', '-c', %q(
+    brightnessctl set 5%-;
+    pct=$(brightnessctl -m | cut -d, -f4 | tr -d ' %');
+    dunstify "Brightness" "" -h int:value:$pct -r 998
+  )
+end
+
+bind 233, :none do
+  system 'bash', '-c', %q(
+    brightnessctl set 5%+;
+    pct=$(brightnessctl -m | cut -d, -f4 | tr -d ' %');
+    dunstify "Brightness" "" -h int:value:$pct -r 998
+  )
+end
+
+bind 'x' do
+  system 'kitty -e fish -c "editor" >/dev/null 2>&1 &'
+end
+
+bind 'c' do
+  system 'kitty -e fish -c "y" >/dev/null 2>&1 &'
+end
+
+bind 's' do |x|
+  toggle_float x
+end
+
+bind 'f' do
+  system 'kitty -e fish -c "btop" >/dev/null 2>&1 &'
+end
+
+bind '[' do |_, ws|
+  go_special :term1, ws
+end
+
+bind ']' do |_, ws|
+  go_special :term2, ws
+end
+
+bind 79, :none do |_, ws|
+  go_special :browser, ws
+end
+
+bind 89 do |_, ws|
+  go_special :misc, ws
+end
+
+bind 118, :none do
+  system 'bash', '-c',
+         'dbus-send --print-reply --dest=org.mpris.MediaPlayer2.spotify /org/mpris/MediaPlayer2 org.mpris.MediaPlayer2.Player.PlayPause >/dev/null 2>&1 &'
+end
+
+(0..MAX_PROJECTS - 1).each do |n|
+  bind (n + 1).to_s do
+    go_project(n)
+  end
+end
+
+bind 86, :none do |_, ws|
+  next unless in_project?(ws)
+
+  n = (($current - 1 + MAX_PROJECTS) % MAX_PROJECTS)
+  go_project(n)
+end
+
+bind 82, :none do |_, ws|
+  next unless in_project?(ws)
+
+  n = (($current + 1) % MAX_PROJECTS)
+  go_project(n)
+end
+
+bind 80, :none do |_, ws|
+  next unless in_project?(ws)
+
+  $p_sub[$current] = $p_sub[$current] == 1 ? 0 : 1
+  go_project($current)
+end
+
+go_project(0)

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 = ''
@@ -60,7 +62,7 @@
         set -e
           if [ -z "$DISPLAY" ]; then
             exec ${pkgs.xinit}/bin/startx \
-              ${kutu}/bin/kutu \
+              ${kutu}/bin/kutu "$@" \
               -- \
               ${pkgs.xorg-server}/bin/X
           else
@@ -74,7 +76,7 @@
             cleanup() { kill "$XEPHYR_PID" 2>/dev/null || true; }
             trap cleanup EXIT INT TERM
             sleep 1
-            DISPLAY=$DISPLAY_NUM ${kutu}/bin/kutu
+            DISPLAY=$DISPLAY_NUM ${kutu}/bin/kutu "$@"
             echo "Returned: $?"
           fi
       '';
@@ -98,13 +100,13 @@
           ocamlPackages.utop
           ocamlPackages.ocaml-lsp
           ocamlPackages.ocamlformat
+          clang-tools
+          solargraph
         ];
 
         shellHook = ''
-          export CC=clang
-          export CXX=clang++
-          export LD=clang
           export MRUBY_LIB=${mruby}/lib
+          export MRUBY_HEADERS=${mruby}/include
         '';
       };
     };

libs/changes.patch

@@ -31,3 +31,23 @@
    # C compiler settings
    # conf.cc do |cc|
    #   cc.command = ENV['CC'] || 'gcc'
+@@ -79,5 +79,5 @@
+   # Turn on `enable_debug` for better debugging
+   # conf.enable_debug
+-  conf.enable_bintest
+-  conf.enable_test
++  # conf.enable_bintest
++  # conf.enable_test
+ end
+--- ./mgems/mruby-process/mrbgem.rake
++++ ./mgems/mruby-process/mrbgem.rake
+@@ -54,4 +54,9 @@
+   else
+     spec.objs.delete objfile("#{build_dir}/src/win32")
+   end
++
++  spec.objs.delete objfile("#{build_dir}/src/internal")
++  spec.objs.delete objfile("#{build_dir}/src/dln")
++  spec.objs.delete objfile("#{build_dir}/src/signal")
++  spec.objs.delete objfile("#{build_dir}/src/status")
+ end

scripts/power.sh

@@ -0,0 +1,43 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+opts="  Lock
+󰒲  Suspend
+  Shutdown
+󰜉 Reboot
+  Hibernate
+  Stop KutuWM"
+
+sel=$(printf "%s\n" "$opts" | dmenu -i -p "Select Power Option:" \
+  -nf '#e0af68' -nb '#1f2335' -sb '#f7768e' -sf '#1a1b26' -fn 'AgaveNerdFont-16')
+
+[ -z "$sel" ] && exit 0
+
+case "$sel" in
+*Shutdown*)
+  confirm=$(printf "No\nYes" | dmenu -i -p "Are you sure you want to shutdown? :" \
+    -nf '#e0af68' -nb '#1f2335' -sb '#f7768e' -sf '#1a1b26' -fn 'AgaveNerdFont-16')
+  [ "$confirm" = "Yes" ] && exec shutdown -h now
+  ;;
+*Reboot*)
+  confirm=$(printf "No\nYes" | dmenu -i -p "Are you sure you want to reboot? :" \
+    -nf '#e0af68' -nb '#1f2335' -sb '#f7768e' -sf '#1a1b26' -fn 'HurmitNerdFont-16')
+  [ "$confirm" = "Yes" ] && exec reboot
+  ;;
+*Hibernate*)
+  confirm=$(printf "No\nYes" | dmenu -i -p "Are you sure you want to hibernate? :" \
+    -nf '#e0af68' -nb '#1f2335' -sb '#f7768e' -sf '#1a1b26' -fn 'AgaveNerdFont-16')
+  [ "$confirm" = "Yes" ] && exec systemctl --system hibernate
+  ;;
+*Stop\ KutuWM*)
+  #exec kutu-run.rb stop TODO.
+  pkill X
+  ;;
+*Suspend*)
+  exec systemctl --system suspend
+  ;;
+*Lock*)
+  ~/dotfiles/scripts/lock.sh &
+  ;;
+esac

scripts/run.sh

@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+
+declare -A aliases=(
+  [editor]="kitty -e fish -c editor"
+  [yazi]="kitty -e fish -c yazi"
+  [btop]="kitty -e fish -c btop"
+)
+
+choice=$(
+  {
+    printf '%s\n' "${!aliases[@]}"
+    compgen -c
+  } |
+    grep -v -E '^(\..*|if|fi|case|esac|for|done|while|until|select|function|return|continue|break|time|exec|source|alias|builtin|read|export|unset|local|set|declare|typeset|:|\.|\[|coproc|l|ll|ls|then|else|elif|do|in|\{|\}|!|\[\[|\]\]|_.*|compgen)$' |
+    sort -u |
+    dmenu -i -p "Enter command  " \
+      -nf '#4abaaf' -nb '#1f2335' -sb '#7aa2f7' -sf '#102030' -fn 'AgaveNerdFont-16'
+)
+
+[ -z "$choice" ] && exit 0
+
+if [[ -v "aliases[$choice]" ]]; then
+  eval "${aliases[$choice]}" >/dev/null 2>&1 &
+else
+  "$choice" >/dev/null 2>&1 &
+fi
+
+disown

scripts/startup.sh

@@ -0,0 +1,8 @@
+#!/usr/bin/env bash
+
+xset s off
+xset -dpms
+
+xsetroot -cursor_name left_ptr
+
+setxkbmap us

src/bindings/core.ml

@@ -0,0 +1,22 @@
+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;
+  Ws_op.register_jump state;
+  Ws_op.register_ws_count state;
+  Ws_op.register_ws_empty state;
+  Keybinds.register_bind state;
+  Keybinds.register_unbind state

src/bindings/keybinds.ml

@@ -0,0 +1,90 @@
+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 value1 value2 =
+  match Hashtbl.find_opt hashtbl (bind_key key modifier) with
+  | None -> ()
+  | Some block ->
+      let arg1 = Mruby.Bindings.mrb_int_value mrb value1 in
+      let arg2 =
+        Mruby.Bindings.mrb_intern_cstr mrb value2
+        |> Mruby.Bindings.mrb_symbol_value
+      in
+      let argv = CArray.of_list Mruby.Types.Mrb_value.typ [ arg1; arg2 ] in
+      ignore
+        (Mruby.Bindings.mrb_funcall_argv mrb block
+           (Mruby.Bindings.call_sym mrb)
+           (Signed.Int64.of_int 2) (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,75 @@
+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
+    begin match Hashtbl.find_opt state.workspaces state.current with
+    | Some ws -> (
+        let windows = Kutu.Layout.calculate state.screen ws.ws_root in
+        match Kutu.Layout.find_fwindow window windows with
+        | Some { fw_rect; _ } ->
+            begin match Kutu.Layout.find_fwindow window ws.ws_fwindows with
+            | Some _ -> print_endline "Error: window already floating"
+            | None ->
+                let new_root, _ = Kutu.Layout.remove window ws.ws_root in
+                ws.ws_root <- new_root;
+                ws.ws_fwindows <-
+                  { fw_rect; fw_window = window } :: ws.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 ws.ws_root)
+            end
+        | None ->
+            begin match Kutu.Layout.find_fwindow window ws.ws_fwindows with
+            | Some _ ->
+                ws.ws_fwindows <-
+                  Kutu.Layout.remove_fwindow window ws.ws_fwindows;
+                Xcb.Window.move_to_bottom state.conn window;
+                ws.ws_root <-
+                  Some
+                    (Kutu.Layout.insert Kutu.Layout.Horizontal window ws.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 ws.ws_root)
+            | None ->
+                print_endline "Error: window is neither tiled nor floating"
+            end)
+    | None -> ()
+    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/bindings/ws_op.ml

@@ -0,0 +1,88 @@
+open Ctypes
+open Foreign
+
+let register_jump (state : Kutu.State.wm_state) =
+  let mrb_get_args =
+    foreign "mrb_get_args"
+      (ptr Mruby.Types.Mrb_state.typ
+      @-> string
+      @-> ptr Mruby.Types.Mrb_sym.typ
+      @-> returning int)
+  in
+  let jump_ws (mrb : Mruby.Types.Mrb_state.t structure ptr)
+      (self : Mruby.Types.Mrb_value.t structure) =
+    let name = allocate Mruby.Types.Mrb_sym.typ (Unsigned.UInt32.of_int 0) in
+    ignore (mrb_get_args mrb "n" name);
+    let name = Mruby.Bindings.mrb_sym_name mrb !@name in
+    let new_ws =
+      match Hashtbl.find_opt state.workspaces name with
+      | Some ws -> ws
+      | None ->
+          let ws = { Kutu.Layout.ws_root = None; ws_fwindows = [] } in
+          Hashtbl.add state.workspaces name ws;
+          ws
+    in
+    if state.current <> name then (
+      begin match Hashtbl.find_opt state.workspaces state.current with
+      | Some old_ws ->
+          List.iter
+            (fun { Kutu.Layout.fw_window = window; fw_rect } ->
+              Xcb.Window.unmap state.conn window)
+            (Kutu.Layout.calculate state.screen old_ws.ws_root);
+          List.iter
+            (fun { Kutu.Layout.fw_window = window; fw_rect } ->
+              Xcb.Window.unmap state.conn window)
+            old_ws.ws_fwindows
+      | None -> ()
+      end;
+      state.current <- name;
+      List.iter
+        (fun { Kutu.Layout.fw_window = window; fw_rect = rect } ->
+          Xcb.Window.map state.conn window;
+          Xcb.Window.reshape state.conn window rect)
+        (Kutu.Layout.calculate state.screen new_ws.ws_root);
+      List.iter
+        (fun { Kutu.Layout.fw_window = window; fw_rect } ->
+          Xcb.Window.map state.conn window)
+        new_ws.ws_fwindows);
+    self
+  in
+  Mruby.Bindings.mrb_define_method state.mrb
+    (Mruby.Types.Mrb_state.get_object_class state.mrb)
+    "jump_ws" jump_ws
+    (Mruby.Bindings.mrb_args_req 1)
+
+let register_ws_count (state : Kutu.State.wm_state) =
+  let ws_count (mrb : Mruby.Types.Mrb_state.t structure ptr)
+      (_ : Mruby.Types.Mrb_value.t structure) =
+    Mruby.Bindings.mrb_int_value mrb
+      (Hashtbl.length state.workspaces |> Unsigned.UInt32.of_int)
+  in
+  Mruby.Bindings.mrb_define_method state.mrb
+    (Mruby.Types.Mrb_state.get_object_class state.mrb)
+    "ws_count" ws_count (Unsigned.UInt32.of_int 0)
+
+let register_ws_empty (state : Kutu.State.wm_state) =
+  let mrb_get_args =
+    foreign "mrb_get_args"
+      (ptr Mruby.Types.Mrb_state.typ
+      @-> string
+      @-> ptr Mruby.Types.Mrb_sym.typ
+      @-> returning int)
+  in
+  let ws_empty (mrb : Mruby.Types.Mrb_state.t structure ptr)
+      (self : Mruby.Types.Mrb_value.t structure) =
+    let name = allocate Mruby.Types.Mrb_sym.typ (Unsigned.UInt32.of_int 0) in
+    ignore (mrb_get_args mrb "n" name);
+    let name = Mruby.Bindings.mrb_sym_name mrb !@name in
+    match Hashtbl.find_opt state.workspaces name with
+    | Some ws ->
+        let is_empty = ws.ws_root = None && List.is_empty ws.ws_fwindows in
+        Mruby.Bindings.mrb_bool_value
+          (Unsigned.UInt32.of_int (if is_empty then 1 else 0))
+    | None -> Mruby.Bindings.mrb_bool_value (Unsigned.UInt32.of_int 1)
+  in
+  Mruby.Bindings.mrb_define_method state.mrb
+    (Mruby.Types.Mrb_state.get_object_class state.mrb)
+    "ws_empty?" ws_empty
+    (Mruby.Bindings.mrb_args_req 1)

src/decl/types.ml

@@ -0,0 +1 @@
+type rect = { rect_x : int; rect_y : int; rect_width : int; rect_height : int }

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

@@ -0,0 +1,132 @@
+type direction = Horizontal | Vertical
+
+type layout =
+  | Leaf of { layout_window : Xcb.Types.Window.t }
+  | Split of {
+      layout_direction : direction;
+      layout_ratio : float;
+      layout_l : layout;
+      layout_r : layout;
+    }
+
+type fwindow = { fw_rect : Decl.Types.rect; fw_window : Xcb.Types.Window.t }
+
+type workspace = {
+  mutable ws_root : layout option;
+  mutable ws_fwindows : fwindow list;
+}
+
+let empty_workspace () = { ws_root = None; ws_fwindows = [] }
+let is_empty_workspace ws = ws.ws_root = None && ws.ws_fwindows = []
+
+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
+
+let rec insert direction window = function
+  | None -> Leaf { layout_window = window }
+  | Some l -> (
+      match l with
+      | Leaf { layout_window = existing } ->
+          Split
+            {
+              layout_direction = direction;
+              layout_ratio = 0.5;
+              layout_l = Leaf { layout_window = existing };
+              layout_r = Leaf { layout_window = window };
+            }
+      | Split { layout_direction; layout_ratio; layout_l; layout_r } ->
+          Split
+            {
+              layout_direction;
+              layout_ratio;
+              layout_l;
+              layout_r =
+                insert (flip_direction layout_direction) window (Some layout_r);
+            })
+
+let rec remove window = function
+  | None -> (None, false)
+  | Some l -> (
+      match l with
+      | Leaf { layout_window = existing } ->
+          if existing = window then (None, true)
+          else (Some (Leaf { layout_window = existing }), false)
+      | Split { layout_direction; layout_ratio; layout_l; layout_r } -> (
+          let l', l_removed = remove window (Some layout_l) in
+          let r', r_removed = remove window (Some layout_r) in
+          let removed = l_removed || r_removed in
+          match (l', r') with
+          | None, r -> (r, removed)
+          | l, None -> (l, removed)
+          | Some l, Some r ->
+              ( Some
+                  (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 ->
+      let left_width = int_of_float (float rect.rect_width *. ratio) in
+      let right_width = rect.rect_width - left_width in
+      let left =
+        {
+          Decl.Types.rect_x = rect.rect_x;
+          Decl.Types.rect_y = rect.rect_y;
+          Decl.Types.rect_width = left_width;
+          Decl.Types.rect_height = rect.rect_height;
+        }
+      in
+      let right =
+        {
+          Decl.Types.rect_x = rect.rect_x + left_width;
+          Decl.Types.rect_y = rect.rect_y;
+          Decl.Types.rect_width = right_width;
+          Decl.Types.rect_height = rect.rect_height;
+        }
+      in
+      (left, right)
+  | Vertical ->
+      let top_height = int_of_float (float rect.rect_height *. ratio) in
+      let bottom_height = rect.rect_height - top_height in
+      let top =
+        {
+          Decl.Types.rect_x = rect.rect_x;
+          Decl.Types.rect_y = rect.rect_y;
+          Decl.Types.rect_width = rect.rect_width;
+          Decl.Types.rect_height = top_height;
+        }
+      in
+      let bottom =
+        {
+          Decl.Types.rect_x = rect.rect_x;
+          Decl.Types.rect_y = rect.rect_y + top_height;
+          Decl.Types.rect_width = rect.rect_width;
+          Decl.Types.rect_height = bottom_height;
+        }
+      in
+      (top, bottom)
+
+let rec calculate rect = function
+  | None -> []
+  | Some l -> (
+      match l with
+      | Leaf { layout_window } ->
+          [ { fw_rect = rect; fw_window = layout_window } ]
+      | Split { layout_direction; layout_ratio; layout_l; layout_r } ->
+          let left_rect, right_rect =
+            split_rect rect layout_direction layout_ratio
+          in
+          let left_windows = calculate left_rect (Some layout_l) in
+          let right_windows = calculate right_rect (Some layout_r) in
+          left_windows @ right_windows)

src/kutu/state.ml

@@ -0,0 +1,30 @@
+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;
+  mutable current : string;
+  workspaces : (string, Layout.workspace) Hashtbl.t;
+  window_workspace : (Xcb.Types.Window.t, string) Hashtbl.t;
+  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;
+    current = "default";
+    workspaces = Hashtbl.create 16;
+    window_workspace = Hashtbl.create 16;
+    screen = Xcb.Screen_iterator.screen_rect conn;
+    blocks = Hashtbl.create 16;
+  }

src/main.ml

@@ -1,29 +1,106 @@
-let spawn cmd =
-  match Unix.fork () with
-  | 0 ->
-      let devnull = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o666 in
-      Unix.dup2 devnull Unix.stdout;
-      Unix.dup2 devnull Unix.stderr;
-      Unix.close devnull;
-      Unix.execvp cmd.(0) cmd
-  | _pid -> ()
-
 let () =
-  let conn = Xcb.Functions.connect () in
+  let startup_script =
+    if Array.length Sys.argv = 2 then Some Sys.argv.(1)
+    else
+      let default =
+        Filename.concat (Sys.getenv "HOME") ".config/kutu/config.rb"
+      in
+      if Sys.file_exists default then Some default else None
+  in
 
-  print_endline "connected";
+  let state = Kutu.State.new_state in
 
-  Xcb.Functions.window_attribute_setup conn;
+  print_endline "Started Kutu WM";
 
-  if Xcb.Functions.flush conn <= 0 then exit 1;
+  Bindings.Core.register_callbacks state;
 
-  spawn [| "kitty" |];
+  (match startup_script with
+  | Some s ->
+      print_string s;
+      print_endline " : Have something";
+      Mruby.Core.mrb_load_string state.mrb (Mruby.Initial.initial_code s)
+  | None ->
+      print_endline "Nothing";
+      Mruby.Core.mrb_load_string state.mrb (Mruby.Initial.initial_code ""));
+  Mruby.Core.error_check state.mrb;
 
-  while true do
-    if Xcb.Functions.flush conn <= 0 then exit 1;
+  if Xcb.Connection.flush state.conn <= 0 then exit 1;
+
+  while state.running do
+    (match Xcb.Event.next state.conn with
+    | None -> ()
+    | Some ev ->
+        (match Xcb.Event.rtype ev with
+        | 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 state.current
+        | MapRequest ->
+            let req = Xcb.Types.Events.Map_request.from ev in
+            let window = Xcb.Types.Events.Map_request.window req in
+            Xcb.Window.map state.conn window;
+            Xcb.Window.focus state.conn window;
+            Xcb.Window.move_to_bottom state.conn window;
+            state.focus <- window;
+            let ws =
+              match Hashtbl.find_opt state.workspaces state.current with
+              | Some ws -> ws
+              | None ->
+                  let ws = { Kutu.Layout.ws_root = None; ws_fwindows = [] } in
+                  Hashtbl.add state.workspaces state.current ws;
+                  ws
+            in
+            ws.ws_root <-
+              Some (Kutu.Layout.insert Kutu.Layout.Horizontal window ws.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 ws.ws_root);
+            Hashtbl.replace state.window_workspace window state.current
+        | Create ->
+            let req = Xcb.Types.Events.Create.from ev in
+            let window = Xcb.Types.Events.Create.window req in
+            let override_ridirect =
+              Xcb.Types.Events.Create.override_redirect req
+            in
+            if override_ridirect == Unsigned.UInt8.of_int 0 then
+              Xcb.Window.setup_window state.conn window
+        | Enter ->
+            let req = Xcb.Types.Events.Enter.from ev in
+            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
+            begin match Hashtbl.find_opt state.window_workspace window with
+            | None -> ()
+            | Some ws_name ->
+                let ws = Hashtbl.find state.workspaces ws_name in
+                let new_root, tiled_removed =
+                  Kutu.Layout.remove window ws.ws_root
+                in
+                if tiled_removed then ws.ws_root <- new_root
+                else
+                  ws.ws_fwindows <-
+                    Kutu.Layout.remove_fwindow window ws.ws_fwindows;
+                Hashtbl.remove state.window_workspace window;
+                if ws_name = state.current then
+                  List.iter
+                    (fun { Kutu.Layout.fw_window = window; fw_rect = rect } ->
+                      Xcb.Window.reshape state.conn window rect)
+                    (Kutu.Layout.calculate state.screen ws.ws_root)
+            end
+        | _ -> ());
+        Xcb.Utils.free ev);
+    Mruby.Core.error_check state.mrb;
+    if Xcb.Connection.flush state.conn <= 0 then exit 1;
     Unix.sleepf 0.01
   done;
 
-  Xcb.Functions.disconnect conn;
-
-  print_endline "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.ml

@@ -1,11 +0,0 @@
-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/mruby/bindings.ml

@@ -0,0 +1,53 @@
+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_bool_value =
+  foreign "kutu_mrb_bool_value"
+    (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_symbol_value =
+  foreign "kutu_mrb_symbol_value"
+    (Types.Mrb_sym.typ @-> returning Types.Mrb_value.typ)
+
+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)
+
+let mrb_sym_name =
+  foreign "mrb_sym_name"
+    (ptr Types.Mrb_state.typ @-> Types.Mrb_sym.typ @-> returning string)

src/mruby/core.ml

@@ -0,0 +1,19 @@
+open Ctypes
+open Foreign
+
+let _mrb_open = foreign "mrb_open" (void @-> returning (ptr Types.Mrb_state.typ))
+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)
+
+let mrb_load_string =
+  foreign "mrb_load_string"
+    (ptr Types.Mrb_state.typ @-> string @-> returning void)
+
+let error_check mrb_ptr =
+  if Types.Mrb_state.has_error mrb_ptr then begin
+    mrb_print_error mrb_ptr;
+    Types.Mrb_state.clear_error mrb_ptr
+  end

src/mruby/initial.ml

@@ -0,0 +1,105 @@
+let initial_code =
+  Printf.sprintf
+    {|#ruby
+MOD_MAP = {
+  none: 0,
+  alt: 8,
+  super: 64
+}
+KEY_MAP = {
+  "tab" => 23,
+  "q" => 24,
+  "w" => 25,
+  "e" => 26,
+  "r" => 27,
+  "f" => 41,
+  "s" => 39,
+  "a" => 38,
+  "d" => 40,
+  "n" => 57,
+  "b" => 56,
+  "m" => 58,
+  "v" => 55,
+  "x" => 53,
+  "c" => 54,
+  "]" => 35,
+  "[" => 34,
+  "1" => 10,
+  "2" => 11,
+  "3" => 12,
+  "4" => 13,
+  "5" => 14,
+  "6" => 15,
+  "7" => 16,
+  "8" => 17,
+  "9" => 18,
+  "0" => 19
+}
+
+CONFIG_FILE = "%s"
+
+DEFAULT = <<'CODE'
+bind ?q do |x|
+  kill x
+end
+
+bind ?w do
+  system "kitty >/dev/null 2>&1 &"
+end
+
+bind ?e do
+  exit
+end
+CODE
+
+BINDINGS = []
+SYSTEM_BINDINGS = []
+
+def bind(key, mod = :super, system: false, &block)
+  key_ = key.is_a?(String) ? KEY_MAP[key] : key
+  mod_ = MOD_MAP[mod]
+
+  raise "unknown key #{key}" unless key_
+  raise "unknown modifier #{mod}" unless mod_
+
+  _bind key_, mod_, &block
+
+  (system ? SYSTEM_BINDINGS : BINDINGS) << [key_, mod_]
+end
+
+def unbind(key, mod = :super)
+  key_ = key.is_a?(String) ? KEY_MAP[key] : key
+  mod_ = MOD_MAP[mod]
+
+  raise "unknown key #{key}" unless key_
+  raise "unknown modifier #{mod}" unless mod_
+
+  _unbind key_, mod_
+  BINDINGS.delete([key_, mod_])
+end
+
+def unbind_all
+  BINDINGS.each do |key_, mod_|
+    _unbind key_, mod_
+  end
+
+  BINDINGS.clear
+end
+
+bind ?r, system: true do
+  unbind_all
+  if CONFIG_FILE != ""
+    code = File.read(CONFIG_FILE)
+    eval code
+  else
+    eval DEFAULT
+  end
+end
+
+if CONFIG_FILE != ""
+  code = File.read(CONFIG_FILE)
+  eval code
+else
+  eval DEFAULT
+end
+|}

src/mruby/types.ml

@@ -0,0 +1,52 @@
+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
+
+  let typ : t structure typ = structure "mrb_state"
+  let jmp = field typ "jmp" (ptr void)
+  let c = field typ "c" (ptr void)
+  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 24464 char)
+  let () = seal typ
+
+  let has_error mrb_ptr =
+    let exc_val = getf !@mrb_ptr exc in
+    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,24 @@
+#include <mruby.h>
+#include <mruby/boxing_word.h>
+#include <mruby/compile.h>
+#include <mruby/value.h>
+#include <stdint.h>
+#include <stdio.h>
+
+mrb_value kutu_mrb_int_value(mrb_state *mrb, uint32_t value) {
+  return mrb_int_value(mrb, (mrb_int)value);
+}
+
+mrb_value kutu_mrb_symbol_value(mrb_sym i) { return mrb_symbol_value(i); }
+
+mrb_value kutu_mrb_bool_value(uint32_t b) { return mrb_bool_value(b); }
+
+void kutu_mrb_load_file(mrb_state *mrb, const char *filename) {
+  FILE *file = fopen(filename, "rb");
+  if (file == NULL) {
+    mrb_raisef(mrb, E_RUNTIME_ERROR, "could not open file: %s", filename);
+    return;
+  }
+  mrb_load_file(mrb, file);
+  fclose(file);
+}

src/xcb/connection.ml

@@ -0,0 +1,15 @@
+open Ctypes
+open Foreign
+
+let _xcb_connect =
+  foreign "xcb_connect"
+    (string_opt @-> ptr int @-> returning (ptr Types.Connection.typ))
+
+let disconnect =
+  foreign "xcb_disconnect" (ptr Types.Connection.typ @-> returning void)
+
+let flush = foreign "xcb_flush" (ptr Types.Connection.typ @-> returning int)
+
+let connect () =
+  let screen = allocate int 0 in
+  _xcb_connect None screen

src/xcb/cookie.ml

@@ -0,0 +1,18 @@
+open Ctypes
+open Foreign
+
+module Atom = struct
+  let _xcb_intern_atom =
+    foreign "xcb_intern_atom"
+      (ptr Types.Connection.typ @-> uint8_t @-> uint16_t @-> string
+      @-> returning Types.Cookie.Atom.typ)
+
+  let intern conn only_if_exists name =
+    _xcb_intern_atom conn
+      (Unsigned.UInt8.of_int (if only_if_exists then 1 else 0))
+      (Unsigned.UInt16.of_int (String.length name))
+      name
+
+  let wm_protocols conn = intern conn true "WM_PROTOCOLS"
+  let wm_delete_window conn = intern conn false "WM_DELETE_WINDOW"
+end

src/xcb/error.ml

@@ -0,0 +1,15 @@
+open Ctypes
+open Foreign
+
+let _xcb_request_check =
+  foreign "xcb_request_check"
+    (ptr Types.Connection.typ @-> Types.Cookie.Void.typ
+    @-> returning (ptr_opt Types.Error.typ))
+
+let has_error =
+  foreign "xcb_connection_has_error" (ptr Types.Connection.typ @-> returning int)
+
+let check conn cookie =
+  match _xcb_request_check conn cookie with
+  | None -> ()
+  | Some _ -> prerr_endline "failiure"

src/xcb/event.ml

@@ -0,0 +1,47 @@
+open Ctypes
+open Foreign
+
+type event =
+  | Enter
+  | Leave
+  | KeyPress
+  | KeyRelease
+  | MousePress
+  | MouseMove
+  | MouseRelease
+  | Create
+  | Destroy
+  | Unmap
+  | Map
+  | MapRequest
+  | ConfigureRequest
+  | ResizeRequest
+  | Unknown
+
+let event_of_int = function
+  | 7 -> Enter
+  | 8 -> Leave
+  | 2 -> KeyPress
+  | 3 -> KeyRelease
+  | 4 -> MousePress
+  | 6 -> MouseMove
+  | 5 -> MouseRelease
+  | 16 -> Create
+  | 17 -> Destroy
+  | 18 -> Unmap
+  | 19 -> Map
+  | 20 -> MapRequest
+  | 23 -> ConfigureRequest
+  | 25 -> ResizeRequest
+  | _ -> Unknown
+
+let rtype ptr =
+  Types.Event.response_type ptr |> Unsigned.UInt8.to_int |> event_of_int
+
+let _next =
+  foreign "xcb_poll_for_event"
+    (ptr Types.Connection.typ @-> returning (ptr Types.Event.typ))
+
+let next conn =
+  let ptr = _next conn in
+  if ptr = from_voidp Types.Event.typ null then None else Some ptr

src/xcb/functions.ml

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

src/xcb/reply.ml

@@ -0,0 +1,16 @@
+open Ctypes
+open Foreign
+
+let _xcb_intern_atom_reply =
+  foreign "xcb_intern_atom_reply"
+    (ptr Types.Connection.typ @-> Types.Cookie.Atom.typ @-> ptr_opt void
+    @-> returning (ptr Types.Reply.typ))
+
+let get conn cookie =
+  let reply = _xcb_intern_atom_reply conn cookie None in
+  if is_null reply then None
+  else begin
+    let atom = Types.Reply.get_atom reply in
+    Utils.free (to_voidp reply);
+    Some atom
+  end

src/xcb/screen_iterator.ml

@@ -0,0 +1,21 @@
+open Ctypes
+open Foreign
+
+let get =
+  foreign "xcb_get_setup"
+    (ptr Types.Connection.typ @-> returning (ptr Types.Setup.typ))
+
+let _xcb_get =
+  foreign "xcb_setup_roots_iterator"
+    (ptr Types.Setup.typ @-> returning Types.Screen_iterator.typ)
+
+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;
+    Decl.Types.rect_height = Types.Screen.height screen;
+    Decl.Types.rect_width = Types.Screen.width screen;
+  }

src/xcb/types.ml

@@ -1,45 +1,395 @@
 open Ctypes
 open Foreign
 
-type connection
-type screen
-type screen_iterator
-type setup
-type window = Unsigned.UInt32.t
-type void_cookie
-type generic_error
+module Connection = struct
+  type t
+  type conn_ptr = t structure ptr
 
-let generic_error : generic_error structure typ =
-  structure "xcb_generic_error_t"
+  let typ : t structure typ = structure "xcb_connection_t"
+end
 
-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
+module Window = struct
+  type t = Unsigned.UInt32.t
 
-let screen_iterator : screen_iterator structure typ =
-  structure "xcb_screen_iterator_t"
+  let typ : t typ = uint32_t
+  let of_int x = Unsigned.UInt32.of_int x
+end
 
-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"
+module Cookie = struct
+  module Void = struct
+    type t
+
+    let typ : t structure typ = structure "xcb_void_cookie_t"
+    let sequence = field typ "sequence" uint32_t
+    let () = seal typ
+  end
+
+  module Atom = struct
+    type t
+
+    let typ : t structure typ = structure "xcb_intern_atom_cookie_t"
+    let sequence = field typ "sequence" uint32_t
+    let () = seal typ
+  end
+end
+
+module Error = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_generic_error_t"
+end
+
+module Event = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_generic_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 pad = field typ "pad" (array 7 uint32_t)
+  let full_sequence = field typ "full_sequence" uint32_t
+  let () = seal typ
+  let response_type ptr = getf !@ptr response_type
+end
+
+module Events = struct
+  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"
+    let response_type = field typ "response_type" uint8_t
+    let pad0 = field typ "pad0" uint8_t
+    let sequence = field typ "sequence" uint16_t
+    let parent = field typ "parent" 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
+
+  module Enter = struct
+    type t
+
+    let typ : t structure typ = structure "xcb_enter_notify_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" Window.typ
+    let event = field typ "event" Window.typ
+    let child = field typ "child" Window.typ
+    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 mode = field typ "mode" uint8_t
+    let same_screen = field typ "same_screen_focus" uint8_t
+    let () = seal typ
+    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
+
+  module Create = struct
+    type t
+
+    let typ : t structure typ = structure "xcb_create_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 parent = field typ "parent" uint32_t
+    let window = field typ "window" Window.typ
+    let x = field typ "x" int16_t
+    let y = field typ "y" int16_t
+    let width = field typ "width" int16_t
+    let height = field typ "height" int16_t
+    let border_width = field typ "border_width" uint16_t
+    let override_redirect = field typ "override_redirect" uint8_t
+    let pad1 = field typ "pad1" uint8_t
+    let () = seal typ
+    let from ptr = from_voidp typ (to_voidp ptr)
+    let window ptr = getf !@ptr window
+    let override_redirect ptr = getf !@ptr override_redirect
+  end
+end
+
+module Client_message = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_client_message_event_t"
+  let response_type = field typ "response_type" uint8_t
+  let format = field typ "format" uint8_t
+  let sequence = field typ "sequence" uint16_t
+  let window = field typ "window" Window.typ
+  let type_ = field typ "type" uint32_t
+  let data = field typ "data" (array 5 uint32_t)
+  let () = seal typ
+  let ptr ev = to_voidp (addr ev) |> from_voidp char
+end
+
+module Atom = struct
+  type t = Unsigned.UInt32.t
+
+  let typ : t typ = uint32_t
+end
+
+module Reply = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_intern_atom_reply_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 length = field typ "length" uint32_t
+  let atom = field typ "atom" Atom.typ
+  let () = seal typ
+  let get_atom ptr = getf !@ptr atom
+end
+
+module Screen = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_screen_t"
+  let root = field typ "root" Window.typ
+  let default_colormap = field typ "default_colormap" uint32_t
+  let white_pixel = field typ "white_pixel" uint32_t
+  let black_pixel = field typ "black_pixel" uint32_t
+  let current_input_masks = field typ "current_input_masks" uint32_t
+  let width_in_pixels = field typ "width_in_pixels" uint16_t
+  let height_in_pixels = field typ "height_in_pixels" uint16_t
+  let width_in_millimeters = field typ "width_in_millimeters" uint16_t
+  let height_in_millimeters = field typ "height_in_millimeters" uint16_t
+  let min_installed_maps = field typ "min_installed_maps" uint16_t
+  let max_installed_maps = field typ "max_installed_maps" uint16_t
+  let root_visual = field typ "root_visual" uint32_t
+  let backing_stores = field typ "backing_stores" uint8_t
+  let save_unders = field typ "save_unders" uint8_t
+  let root_depth = field typ "root_depth" uint8_t
+  let allowed_depths_len = field typ "allowed_depths_len" uint8_t
+  let () = seal typ
+  let root ptr = getf ptr root
+  let width ptr = Unsigned.UInt16.to_int (getf ptr width_in_pixels)
+  let height ptr = Unsigned.UInt16.to_int (getf ptr height_in_pixels)
+end
+
+module Setup = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_setup_t"
+end
+
+module Screen_iterator = struct
+  type t
+
+  let typ : t structure typ = structure "xcb_screen_iterator_t"
+  let data = field typ "data" (ptr Screen.typ)
+  let rem = field typ "rem" int
+  let index = field typ "index" int
+  let () = seal typ
+  let screen ptr = !@(getf ptr data)
+end
+
+(* TODO: convert all these:
+/* Opcode for xcb_create_notify. */
+/**
+ * @brief xcb_create_notify_event_t
+ **/
+
+/**
+ * @brief xcb_destroy_notify_event_t
+ **/
+typedef struct xcb_destroy_notify_event_t {
+    uint8_t      response_type;
+    uint8_t      pad0;
+    uint16_t     sequence;
+    xcb_window_t event;
+    xcb_window_t window;
+} xcb_destroy_notify_event_t;
+
+/**
+ * @brief xcb_unmap_notify_event_t
+ **/
+typedef struct xcb_unmap_notify_event_t {
+    uint8_t      response_type;
+    uint8_t      pad0;
+    uint16_t     sequence;
+    xcb_window_t event;
+    xcb_window_t window;
+    uint8_t      from_configure;
+    uint8_t      pad1[3];
+} xcb_unmap_notify_event_t;
+/**
+ * @brief xcb_map_notify_event_t
+ **/
+typedef struct xcb_map_notify_event_t {
+    uint8_t      response_type;
+    uint8_t      pad0;
+    uint16_t     sequence;
+    xcb_window_t event;
+    xcb_window_t window;
+    uint8_t      override_redirect;
+    uint8_t      pad1[3];
+} xcb_map_notify_event_t;
+
+
+
+/**
+ * @brief xcb_enter_notify_event_t
+ **/
+
+
+
+typedef xcb_enter_notify_event_t xcb_leave_notify_event_t;
+
+
+
+
+typedef xcb_key_press_event_t xcb_key_release_event_t;
+
+typedef enum xcb_button_mask_t {
+    XCB_BUTTON_MASK_1 = 256,
+    XCB_BUTTON_MASK_2 = 512,
+    XCB_BUTTON_MASK_3 = 1024,
+    XCB_BUTTON_MASK_4 = 2048,
+    XCB_BUTTON_MASK_5 = 4096,
+    XCB_BUTTON_MASK_ANY = 32768
+} xcb_button_mask_t;
+
+
+/**
+ * @brief xcb_button_press_event_t
+ **/
+typedef struct xcb_button_press_event_t {
+    uint8_t         response_type;
+    xcb_button_t    detail;
+    uint16_t        sequence;
+    xcb_timestamp_t time;
+    xcb_window_t    root;
+    xcb_window_t    event;
+    xcb_window_t    child;
+    int16_t         root_x;
+    int16_t         root_y;
+    int16_t         event_x;
+    int16_t         event_y;
+    uint16_t        state;
+    uint8_t         same_screen;
+    uint8_t         pad0;
+} xcb_button_press_event_t;
+
+
+typedef xcb_button_press_event_t xcb_button_release_event_t;
+
+typedef enum xcb_motion_t {
+    XCB_MOTION_NORMAL = 0,
+    XCB_MOTION_HINT = 1
+} xcb_motion_t;
+
+
+/**
+ * @brief xcb_motion_notify_event_t
+ **/
+typedef struct xcb_motion_notify_event_t {
+    uint8_t         response_type;
+    uint8_t         detail;
+    uint16_t        sequence;
+    xcb_timestamp_t time;
+    xcb_window_t    root;
+    xcb_window_t    event;
+    xcb_window_t    child;
+    int16_t         root_x;
+    int16_t         root_y;
+    int16_t         event_x;
+    int16_t         event_y;
+    uint16_t        state;
+    uint8_t         same_screen;
+    uint8_t         pad0;
+} xcb_motion_notify_event_t;
+
+typedef enum xcb_notify_detail_t {
+    XCB_NOTIFY_DETAIL_ANCESTOR = 0,
+    XCB_NOTIFY_DETAIL_VIRTUAL = 1,
+    XCB_NOTIFY_DETAIL_INFERIOR = 2,
+    XCB_NOTIFY_DETAIL_NONLINEAR = 3,
+    XCB_NOTIFY_DETAIL_NONLINEAR_VIRTUAL = 4,
+    XCB_NOTIFY_DETAIL_POINTER = 5,
+    XCB_NOTIFY_DETAIL_POINTER_ROOT = 6,
+    XCB_NOTIFY_DETAIL_NONE = 7
+} xcb_notify_detail_t;
+
+typedef enum xcb_notify_mode_t {
+    XCB_NOTIFY_MODE_NORMAL = 0,
+    XCB_NOTIFY_MODE_GRAB = 1,
+    XCB_NOTIFY_MODE_UNGRAB = 2,
+    XCB_NOTIFY_MODE_WHILE_GRABBED = 3
+} xcb_notify_mode_t;
+
+
+/**
+ * @brief xcb_configure_request_event_t
+ **/
+typedef struct xcb_configure_request_event_t {
+    uint8_t      response_type;
+    uint8_t      stack_mode;
+    uint16_t     sequence;
+    xcb_window_t parent;
+    xcb_window_t window;
+    xcb_window_t sibling;
+    int16_t      x;
+    int16_t      y;
+    uint16_t     width;
+    uint16_t     height;
+    uint16_t     border_width;
+    uint16_t     value_mask;
+} xcb_configure_request_event_t;
+
+
+/**
+ * @brief xcb_resize_request_event_t
+ **/
+typedef struct xcb_resize_request_event_t {
+    uint8_t      response_type;
+    uint8_t      pad0;
+    uint16_t     sequence;
+    xcb_window_t window;
+    uint16_t     width;
+    uint16_t     height;
+} xcb_resize_request_event_t;*)

src/xcb/utils.ml

@@ -0,0 +1,6 @@
+open Ctypes
+open Foreign
+
+let get_root conn = Screen_iterator.screen conn |> Types.Screen.root
+let _free = foreign "free" (ptr void @-> returning void)
+let free x = _free (to_voidp x)

src/xcb/window.ml

@@ -0,0 +1,167 @@
+open Ctypes
+open Foreign
+
+let _xcb_change_window_attributes_checked =
+  foreign "xcb_change_window_attributes_checked"
+    (ptr Types.Connection.typ @-> Types.Window.typ @-> uint32_t @-> ptr uint32_t
+    @-> returning Types.Cookie.Void.typ)
+
+let event_mask =
+  (1 lsl 4) lor (1 lsl 17) lor (1 lsl 19) lor (1 lsl 20) lor (1 lsl 22)
+
+let values = CArray.of_list uint32_t [ Unsigned.UInt32.of_int event_mask ]
+
+let setup conn root =
+  let cookie =
+    _xcb_change_window_attributes_checked conn root
+      (Unsigned.UInt32.of_int 2048)
+      (CArray.start values)
+  in
+  Error.check conn cookie
+
+let window_event_mask = 1 lsl 4
+let substructure_mask = 1 lsl 19
+
+let values_window =
+  CArray.of_list uint32_t
+    [
+      Unsigned.UInt32.of_int window_event_mask;
+      Unsigned.UInt32.of_int substructure_mask;
+    ]
+
+let setup_window conn window =
+  let cookie =
+    _xcb_change_window_attributes_checked conn window
+      (Unsigned.UInt32.of_int 2048)
+      (CArray.start values_window)
+  in
+  Error.check conn cookie
+
+let _xcb_configure_window =
+  foreign "xcb_configure_window"
+    (ptr Types.Connection.typ @-> Types.Window.typ @-> uint16_t @-> ptr uint32_t
+    @-> returning Types.Cookie.Void.typ)
+
+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 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 =
+    _xcb_configure_window conn window
+      (Unsigned.UInt16.of_int mask)
+      (CArray.start values)
+  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 key modifier =
+  let cookie =
+    _xcb_grab_key conn (Unsigned.UInt8.of_int 0) window
+      (Unsigned.UInt16.of_int modifier)
+      (Unsigned.UInt8.of_int key)
+      (Unsigned.UInt8.of_int 1) (Unsigned.UInt8.of_int 1)
+  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
+    @-> returning Types.Cookie.Void.typ)
+
+let map conn window =
+  let cookie = _xcb_map_window conn window in
+  Error.check conn cookie
+
+let _xcb_unmap_window =
+  foreign "xcb_unmap_window"
+    (ptr Types.Connection.typ @-> Types.Window.typ
+    @-> returning Types.Cookie.Void.typ)
+
+let unmap conn window =
+  let cookie = _xcb_unmap_window conn window in
+  Error.check conn cookie
+
+let _xcb_set_input_focus =
+  foreign "xcb_set_input_focus"
+    (ptr Types.Connection.typ @-> uint8_t @-> Types.Window.typ @-> uint32_t
+    @-> returning Types.Cookie.Void.typ)
+
+let focus conn window =
+  let cookie =
+    _xcb_set_input_focus conn (Unsigned.UInt8.of_int 0) window
+      (Unsigned.UInt32.of_int 0)
+  in
+  Error.check conn cookie
+
+let _xcb_kill_client =
+  foreign "xcb_kill_client"
+    (ptr Types.Connection.typ @-> Types.Window.typ
+    @-> returning Types.Cookie.Void.typ)
+
+let force_kill conn window = ignore (_xcb_kill_client conn window)
+
+let _xcb_send_event =
+  foreign "xcb_send_event"
+    (ptr Types.Connection.typ @-> uint8_t @-> Types.Window.typ @-> uint32_t
+   @-> ptr char
+    @-> returning Types.Cookie.Void.typ)
+
+let kill conn window =
+  let protocols_cookie = Cookie.Atom.wm_protocols conn in
+  let delete_cookie = Cookie.Atom.wm_delete_window conn in
+  match (Reply.get conn protocols_cookie, Reply.get conn delete_cookie) with
+  | Some protocols, Some delete_window ->
+      let ev = make Types.Client_message.typ in
+      setf ev Types.Client_message.response_type (Unsigned.UInt8.of_int 33);
+      setf ev Types.Client_message.window window;
+      setf ev Types.Client_message.type_ protocols;
+      setf ev Types.Client_message.format (Unsigned.UInt8.of_int 32);
+      let data = getf ev Types.Client_message.data in
+      CArray.set data 0 delete_window;
+      CArray.set data 1 (Unsigned.UInt32.of_int 0);
+      let cookie =
+        _xcb_send_event conn (Unsigned.UInt8.of_int 0) window
+          (Unsigned.UInt32.of_int 0)
+          (Types.Client_message.ptr ev)
+      in
+      Error.check conn cookie
+  | _ -> force_kill conn window

writeup.md

@@ -0,0 +1,6 @@
+# Kutu WM
+
+An X11 window manager written in ocaml.
+
+
+