154 lines
4.7 KiB
OCaml
154 lines
4.7 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 values_window =
|
|
CArray.of_list uint32_t [ Unsigned.UInt32.of_int window_event_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_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
|