Finish tinywl.

common/bitwise.ml

@@ -0,0 +1,40 @@
+open Ctypes
+
+module type Size = sig
+  type t
+  val zero : t
+  val logor : t -> t -> t
+  val logand : t -> t -> t
+end
+
+module type Elems = sig
+  type t
+  module Size : Size
+  val size : Size.t typ
+  val desc : (t * Size.t) list
+end
+
+module type Enum = sig
+  type elem
+  type t
+  val t : t
+end
+
+module Make (E : Elems) : Enum = struct
+  type elem = E.t
+  type t = E.t list typ
+  let t : t =
+    let read i =
+      List.filter_map (fun (x, cst) ->
+          if (E.Size.logand i cst) <> E.Size.zero then
+            Some x
+          else None
+        ) E.desc
+    in
+    let write items =
+      List.fold_left (fun i item ->
+          E.Size.logor (List.assoc item E.desc) i
+        ) E.Size.zero items
+    in
+    view ~read ~write E.size
+end

common/dune

@@ -1,6 +1,7 @@
 (library
  (name wlroots_common)
  (public_name wlroots.common)
+ (modules utils bitwise sigs)
  (libraries ctypes))
 
 ;; xdg-shell-protocol.h

common/utils.ml

@@ -13,24 +13,6 @@ let ptr_hash : 'a ptr -> int = fun p ->
   to_voidp p |> raw_address_of_ptr |> Hashtbl.hash
 
 let mk_equal compare x y = compare x y = 0
-
-let bitwise_enum desc =
-  let open Unsigned.UInt64 in
-  let open Infix in
-  let read i =
-    List.filter_map (fun (x, cst) ->
-      if (i land cst) <> zero then
-        Some x
-      else None
-    ) desc
-  in
-  let write items =
-    List.fold_left (fun i item ->
-      (List.assoc item desc) lor i
-    ) zero items
-  in
-  view ~read ~write uint64_t
-
 module Ptr = struct
   let compare = ptr_compare
   let hash = ptr_hash

ffi/ffi.ml

@@ -31,6 +31,10 @@ struct
         allocate Time_unix.Timespec.t timespec)
       (ptr Time_unix.Timespec.t)
 
+  (* FIXME: The void pointer is a pixman_region32_t for which no bindings exist (yet).
+     This is only ok because so far, no one uses it. *)
+  let pixman_region32_t = ptr void
+
   (* wl_list *)
 
   type wl_list_p = Wl_list.t ptr
@@ -130,6 +134,15 @@ struct
   let wlr_output_enable = foreign "wlr_output_enable"
       (wlr_output_p @-> bool @-> returning void)
 
+  let wlr_output_effective_resolution = foreign "wlr_output_effective_resolution"
+      (wlr_output_p @-> ptr int @-> ptr int @-> returning void)
+
+  let wlr_output_transform_invert = foreign "wlr_output_transform_invert"
+      (Wl_output_transform.t @-> returning Wl_output_transform.t)
+
+  let wlr_output_render_software_cursors = foreign "wlr_output_render_software_cursors"
+      (wlr_output_p @-> pixman_region32_t @-> returning void)
+
   (* wlr_output_layout *)
 
   let wlr_output_layout_p = ptr Output_layout.t
@@ -140,6 +153,9 @@ struct
   let wlr_output_layout_add_auto = foreign "wlr_output_layout_add_auto"
       (wlr_output_layout_p @-> wlr_output_p @-> returning void)
 
+  let wlr_output_layout_output_coords = foreign "wlr_output_layout_output_coords"
+      (wlr_output_layout_p @-> wlr_output_p @-> ptr double @-> ptr double @-> returning void)
+
   (* wlr_box *)
 
   let wlr_box_p = ptr Box.t
@@ -169,6 +185,9 @@ struct
   let wlr_surface_send_frame_done = foreign "wlr_surface_send_frame_done"
       (wlr_surface_p @-> time @-> returning void)
 
+  let wlr_surface_get_texture = foreign "wlr_surface_get_texture"
+      (wlr_surface_p @-> returning wlr_texture_p)
+
   (* wlr_renderer *)
 
   let wlr_renderer_p = ptr Renderer.t
@@ -185,13 +204,24 @@ struct
   let wlr_renderer_init_wl_display = foreign "wlr_renderer_init_wl_display"
       (wlr_renderer_p @-> wl_display_p @-> returning bool)
 
+  let wlr_render_texture_with_matrix = foreign "wlr_render_texture_with_matrix"
+      (wlr_renderer_p @-> wlr_texture_p @-> ptr double @-> double @-> returning bool)
+
   (* wlr_keyboard *)
 
   let wlr_keyboard_p = ptr Keyboard.t
 
   let wlr_keyboard_set_keymap = foreign "wlr_keyboard_set_keymap"
       (wlr_keyboard_p @-> Xkbcommon.Keymap.t @-> returning bool)
 
+  let wlr_keyboard_modifiers_p = ptr Keyboard_modifiers.t
+
+  let wlr_keyboard_set_repeat_info = foreign "wlr_keyboard_set_repeat_info"
+      (wlr_keyboard_p @-> int32_t @-> int32_t @-> returning void)
+
+  let wlr_keyboard_get_modifiers = foreign "wlr_keyboard_get_modifiers"
+      (wlr_keyboard_p @-> returning uint32_t)
+
   (* wlr_backend *)
 
   let wlr_backend_p = ptr Backend.t
@@ -229,6 +259,33 @@ struct
   let wlr_xdg_shell_create = foreign "wlr_xdg_shell_create"
       (wl_display_p @-> returning wlr_xdg_shell_p)
 
+  (* wlr_xdg_surface *)
+
+  let wlr_xdg_surface_p = ptr Xdg_surface.t
+
+  let wlr_surface_is_xdg_surface = foreign "wlr_surface_is_xdg_surface"
+      (wlr_surface_p @-> returning bool)
+
+  let wlr_xdg_surface_from_wlr_surface = foreign "wlr_xdg_surface_from_wlr_surface"
+      (wlr_surface_p @-> returning wlr_xdg_surface_p)
+
+  let wlr_xdg_surface_get_geometry = foreign "wlr_xdg_surface_get_geometry"
+      (wlr_xdg_surface_p @-> wlr_box_p @-> returning void)
+
+  let wlr_xdg_surface_surface_at = foreign "wlr_xdg_surface_surface_at"
+      (wlr_xdg_surface_p @-> double @-> double @-> ptr double @-> ptr double @-> returning wlr_surface_p)
+
+  let wlr_xdg_surface_for_each_surface = foreign "wlr_xdg_surface_for_each_surface"
+      (wlr_xdg_surface_p @-> Surface.wlr_surface_iterator_func_t @-> ptr void @-> returning void)
+
+  (* wlr_xdg_toplevel *)
+
+  let wlr_xdg_toplevel_set_activated = foreign "wlr_xdg_toplevel_set_activated"
+      (wlr_xdg_surface_p @-> bool @-> returning uint32_t)
+
+  let wlr_xdg_toplevel_set_size = foreign "wlr_xdg_toplevel_set_size"
+      (wlr_xdg_surface_p @-> int @-> int @-> returning uint32_t)
+
   (* wlr_input_device *)
 
   let wlr_input_device_p = ptr Input_device.t
@@ -252,6 +309,13 @@ struct
     foreign "wlr_cursor_set_surface"
       (wlr_cursor_p @-> wlr_surface_p @-> int @-> int @-> returning void)
 
+  let wlr_cursor_move =
+    foreign "wlr_cursor_move"
+      (wlr_cursor_p @-> wlr_input_device_p @-> double @-> double @-> returning void)
+
+  let wlr_cursor_warp_absolute = foreign "wlr_cursor_warp_absolute"
+      (wlr_cursor_p @-> wlr_input_device_p @-> double @-> double @-> returning void)
+
   (* wlr_xcursor_manager *)
 
   let wlr_xcursor_manager_p = ptr Xcursor_manager.t
@@ -262,6 +326,9 @@ struct
   let wlr_xcursor_manager_load = foreign "wlr_xcursor_manager_load"
       (wlr_xcursor_manager_p @-> float @-> returning int)
 
+  let wlr_xcursor_manager_set_cursor_image = foreign "wlr_xcursor_manager_set_cursor_image"
+      (wlr_xcursor_manager_p @-> string @-> wlr_cursor_p @-> returning void)
+
   (* wlr_seat *)
 
   let wlr_seat_p = ptr Seat.t
@@ -272,6 +339,47 @@ struct
   let wlr_seat_set_capabilities = foreign "wlr_seat_set_capabilities"
       (wlr_seat_p @-> Wl_seat_capability.t @-> returning void)
 
+  let wlr_seat_set_keyboard = foreign "wlr_seat_set_keyboard"
+      (wlr_seat_p @-> wlr_input_device_p @-> returning void)
+
+  let wlr_seat_keyboard_notify_modifiers = foreign "wlr_seat_keyboard_notify_modifiers"
+      (wlr_seat_p @-> wlr_keyboard_modifiers_p @-> returning void)
+
+  let wlr_seat_keyboard_notify_enter = foreign "wlr_seat_keyboard_notify_enter"
+      (wlr_seat_p
+       @-> wlr_surface_p
+       @-> Keycodes.t
+       @-> size_t
+       @-> wlr_keyboard_modifiers_p
+       @-> returning void)
+
+  let wlr_seat_keyboard_notify_key = foreign "wlr_seat_keyboard_notify_key"
+      (wlr_seat_p @-> uint32_t @-> uint32_t @-> uint32_t @-> returning void)
+
+  let wlr_seat_pointer_notify_enter = foreign "wlr_seat_pointer_notify_enter"
+      (wlr_seat_p @-> wlr_surface_p @-> double @-> double @-> returning void)
+
+  let wlr_seat_pointer_clear_focus = foreign "wlr_seat_pointer_clear_focus"
+      (wlr_seat_p @-> returning void)
+
+  let wlr_seat_pointer_notify_motion = foreign "wlr_seat_pointer_notify_motion"
+      (wlr_seat_p @-> uint32_t @-> double @-> double @-> returning void)
+
+  let wlr_seat_pointer_notify_button = foreign "wlr_seat_pointer_notify_button"
+      (wlr_seat_p @-> uint32_t @-> uint32_t @-> Button_state.t @-> returning uint32_t)
+
+  let wlr_seat_pointer_notify_axis = foreign "wlr_seat_pointer_notify_axis"
+      (wlr_seat_p
+       @-> uint32_t
+       @-> Axis_orientation.t
+       @-> double
+       @-> int32_t
+       @-> Axis_source.t
+       @-> returning void)
+
+  let wlr_seat_pointer_notify_frame = foreign "wlr_seat_pointer_notify_frame"
+      (wlr_seat_p @-> returning void)
+
   (* wlr_log *)
 
   (* TODO *)

lib/cursor.ml

@@ -7,33 +7,40 @@ module Types = Wlroots_ffi_f.Ffi.Types
 type t = Types.Cursor.t ptr
 include Ptr
 
+let x = getfield Types.Cursor.x
+let y = getfield Types.Cursor.y
+
+
 let create = Bindings.wlr_cursor_create
 let attach_output_layout = Bindings.wlr_cursor_attach_output_layout
 let attach_input_device = Bindings.wlr_cursor_attach_input_device
 let set_surface = Bindings.wlr_cursor_set_surface
+let move = Bindings.wlr_cursor_move
 
-let signal_motion (cursor: t) : Pointer.Event_motion.t Wl.Signal.t = {
+let signal_motion (cursor: t) : Event_pointer_motion.t Wl.Signal.t = {
   c = cursor |-> Types.Cursor.events_motion;
-  typ = Pointer.Event_motion.t;
+  typ = Event_pointer_motion.t;
 }
 
 let signal_motion_absolute (cursor: t) :
-  Pointer.Event_motion_absolute.t Wl.Signal.t = {
+  Event_pointer_motion_absolute.t Wl.Signal.t = {
   c = cursor |-> Types.Cursor.events_motion_absolute;
-  typ = Pointer.Event_motion_absolute.t;
+  typ = Event_pointer_motion_absolute.t;
 }
 
-let signal_button (cursor: t) : Pointer.Event_button.t Wl.Signal.t = {
+let signal_button (cursor: t) : Event_pointer_button.t Wl.Signal.t = {
   c = cursor |-> Types.Cursor.events_button;
-  typ = Pointer.Event_button.t;
+  typ = Event_pointer_button.t;
 }
 
-let signal_axis (cursor: t) : Pointer.Event_axis.t Wl.Signal.t = {
+let signal_axis (cursor: t) : Event_pointer_axis.t Wl.Signal.t = {
   c = cursor |-> Types.Cursor.events_axis;
-  typ = Pointer.Event_axis.t;
+  typ = Event_pointer_axis.t;
 }
 
 let signal_frame (cursor: t) : unit Wl.Signal.t = {
   c = cursor |-> Types.Cursor.events_frame;
   typ = void;
 }
+
+let warp_absolute = Bindings.wlr_cursor_warp_absolute

lib/dune

@@ -14,10 +14,36 @@
   (public_name wlroots)
   (modules wlroots
            generated_ffi
-           wl log texture surface box matrix output
-           keyboard pointer touch tablet_tool tablet_pad input_device
-           backend renderer data_device compositor xdg_shell cursor
-           xcursor_manager seat output_layout)
+           wl
+           log
+           texture
+           surface
+           box
+           matrix
+           output
+           keyboard
+           pointer
+           event_pointer_button
+           event_pointer_motion
+           event_pointer_motion_absolute
+           event_pointer_axis
+           edges_elems
+           touch
+           tablet_tool
+           tablet_pad
+           input_device
+           keycodes
+           backend
+           renderer
+           data_device
+           compositor
+           xdg_shell
+           xdg_surface
+           xdg_toplevel
+           cursor
+           xcursor_manager
+           seat
+           output_layout)
   (c_names generated_ffi_stubs)
   (c_flags (:standard -Werror -pedantic -Wall -Wunused -DWLR_USE_UNSTABLE -O0) -w
            (:include ../config/wlroots-ccopt.sexp)

lib/edges_elems.ml

@@ -0,0 +1,14 @@
+open Ctypes
+module Types = Wlroots_ffi_f.Ffi.Types
+
+type t = None | Top | Bottom | Left | Right
+module Size = Unsigned.UInt32
+let size = uint32_t
+open Types.Edges
+let desc = [
+    None, _WLR_EDGE_NONE;
+    Top, _WLR_EDGE_TOP;
+    Bottom, _WLR_EDGE_BOTTOM;
+    Right, _WLR_EDGE_RIGHT;
+    Left, _WLR_EDGE_LEFT;
+]

lib/event_pointer_axis.ml

@@ -0,0 +1,15 @@
+open Ctypes
+open Wlroots_common.Utils
+
+module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi)
+module Types = Wlroots_ffi_f.Ffi.Types
+
+type t = Types.Event_pointer_axis.t ptr
+let t = ptr Types.Event_pointer_axis.t
+include Ptr
+
+let time_msec = getfield Types.Event_pointer_axis.time_msec
+let orientation = getfield Types.Event_pointer_axis.orientation
+let delta = getfield Types.Event_pointer_axis.delta
+let delta_discrete = getfield Types.Event_pointer_axis.delta_discrete
+let source = getfield Types.Event_pointer_axis.source

lib/event_pointer_button.ml

@@ -0,0 +1,13 @@
+open Ctypes
+open Wlroots_common.Utils
+
+module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi)
+module Types = Wlroots_ffi_f.Ffi.Types
+
+type t = Types.Event_pointer_button.t ptr
+let t = ptr Types.Event_pointer_button.t
+include Ptr
+
+let time_msec = getfield Types.Event_pointer_button.time_msec
+let button = getfield Types.Event_pointer_button.button
+let state = getfield Types.Event_pointer_button.state