239 lines
7.0 KiB
OCaml
239 lines
7.0 KiB
OCaml
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_wm_n_hints =
|
|
foreign "kutu_wm_n_hints"
|
|
(ptr Types.Connection.typ @-> Types.Window.typ
|
|
@-> returning Types.Size_hints.typ)
|
|
|
|
let has_flag flags flag =
|
|
Unsigned.UInt32.logand flags (Unsigned.UInt32.of_int flag)
|
|
<> Unsigned.UInt32.zero
|
|
|
|
let p_size = 1 lsl 3
|
|
let p_min_size = 1 lsl 4
|
|
let p_max_size = 1 lsl 5
|
|
let p_resize_inc = 1 lsl 6
|
|
let p_aspect = 1 lsl 7
|
|
|
|
let make_window conn window =
|
|
let hints = _xcb_wm_n_hints conn window in
|
|
let flags = getf hints Types.Size_hints.flags in
|
|
let has_min = has_flag flags p_min_size in
|
|
let has_size = has_flag flags p_size in
|
|
let has_max = has_flag flags p_max_size in
|
|
let has_aspect = has_flag flags p_aspect in
|
|
let size =
|
|
if has_size then
|
|
Some
|
|
(getf hints Types.Size_hints.width, getf hints Types.Size_hints.height)
|
|
else None
|
|
in
|
|
let min =
|
|
if has_min then
|
|
Some
|
|
( getf hints Types.Size_hints.min_width,
|
|
getf hints Types.Size_hints.min_height )
|
|
else None
|
|
in
|
|
let max =
|
|
if has_max then
|
|
Some
|
|
( getf hints Types.Size_hints.max_width,
|
|
getf hints Types.Size_hints.max_height )
|
|
else None
|
|
in
|
|
let fixed_size =
|
|
match (size, min, max) with
|
|
| Some size, _, _ -> Some size
|
|
| _, Some min, _ -> Some min
|
|
| _, _, Some max -> Some max
|
|
| _ -> None
|
|
in
|
|
let fixed_aspect =
|
|
if has_aspect then
|
|
let min_num = getf hints Types.Size_hints.min_aspect_num in
|
|
let min_den = getf hints Types.Size_hints.min_aspect_den in
|
|
let max_num = getf hints Types.Size_hints.max_aspect_num in
|
|
let max_den = getf hints Types.Size_hints.max_aspect_den in
|
|
if min_den <> Int32.zero then
|
|
Some
|
|
( Int32.div (Int32.mul (Int32.of_int 100) min_num) min_den,
|
|
Int32.of_int 100 )
|
|
else if max_den <> Int32.zero then
|
|
Some
|
|
( Int32.div (Int32.mul (Int32.of_int 100) max_num) max_den,
|
|
Int32.of_int 100 )
|
|
else None
|
|
else None
|
|
in
|
|
match (fixed_size, fixed_aspect) with
|
|
| Some (x, y), _ -> Some (x, y)
|
|
| _, Some (x, y) -> Some (x, y)
|
|
| _ -> None
|
|
|
|
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
|