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