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