Bind more functions & start porting tinywl

Author: Armael

common/dune

@@ -2,3 +2,20 @@
  (name wlroots_common)
  (public_name wlroots.common)
  (libraries ctypes))
+
+;; xdg-shell-protocol.h
+(rule
+ (targets "xdg-shell-protocol.h")
+ (deps ../config/wayland-scanner-bin ../config/wayland-protocols-dir)
+ (action (bash "$(< ../config/wayland-scanner-bin) server-header \
+  $(< ../config/wayland-protocols-dir)/stable/xdg-shell/xdg-shell.xml \
+  %{targets}")))
+
+;; xdg-shell-protocol.c
+;;; this doesn't seem to be useful for now?
+(rule
+ (targets "xdg-shell-protocol.c")
+ (deps ../config/wayland-scanner-bin ../config/wayland-protocols-dir)
+ (action (bash "$(< ../config/wayland-scanner-bin) private-code \
+  $(< ../config/wayland-protocols-dir)/stable/xdg-shell/xdg-shell.xml \
+  %{targets}")))

config/discover.ml

@@ -49,3 +49,19 @@ let () =
       package = "wlroots" };
 
   ] |> List.iter ~f:discover
+
+let pkg_config_var ~var pkg =
+  (* hack: this should be supported in configurator directly.
+     see dune issue #3332 *)
+  let cin = Unix.open_process_in
+      (Printf.sprintf "pkg-config --variable=%s %s" var pkg) in
+  let res = In_channel.input_all cin in
+  let _ = Unix.close_process_in cin in
+  res
+
+let () =
+  Out_channel.write_all "wayland-protocols-dir"
+    ~data:(pkg_config_var ~var:"pkgdatadir" "wayland-protocols");
+  Out_channel.write_all "wayland-scanner-bin"
+    ~data:(pkg_config_var ~var:"wayland_scanner" "wayland-scanner");
+  ()

ffi/ffi.ml

@@ -88,8 +88,11 @@ struct
   let wl_display_destroy = foreign "wl_display_destroy"
       (wl_display_p @-> returning void)
 
+  let wl_display_destroy_clients = foreign "wl_display_destroy_clients"
+      (wl_display_p @-> returning void)
+
   let wl_display_add_socket_auto = foreign "wl_display_add_socket_auto"
-      (wl_display_p @-> returning string)
+      (wl_display_p @-> returning string_opt)
 
   let wl_display_init_shm = foreign "wl_display_init_shm"
       (wl_display_p @-> returning int)
@@ -121,6 +124,13 @@ struct
   let wlr_output_commit = foreign "wlr_output_commit"
       (wlr_output_p @-> returning bool)
 
+  (* wlr_output_layout *)
+
+  let wlr_output_layout_p = ptr Output_layout.t
+
+  let wlr_output_layout_create = foreign "wlr_output_layout_create"
+      (void @-> returning wlr_output_layout_p)
+
   (* wlr_box *)
 
   let wlr_box_p = ptr Box.t
@@ -163,6 +173,9 @@ struct
   let wlr_renderer_clear = foreign "wlr_renderer_clear"
       (wlr_renderer_p @-> ptr float @-> returning void)
 
+  let wlr_renderer_init_wl_display = foreign "wlr_renderer_init_wl_display"
+      (wlr_renderer_p @-> wl_display_p @-> returning bool)
+
   (* wlr_keyboard *)
 
   let wlr_keyboard_p = ptr Keyboard.t
@@ -186,13 +199,55 @@ struct
   let wlr_backend_destroy = foreign "wlr_backend_destroy"
       (wlr_backend_p @-> returning void)
 
+  (* wlr_data_device_manager *)
+
+  let wlr_data_device_manager_p = ptr Data_device_manager.t
+
+  let wlr_data_device_manager_create = foreign "wlr_data_device_manager_create"
+      (wl_display_p @-> returning wlr_data_device_manager_p)
+
   (* wlr_compositor *)
 
   let wlr_compositor_p = ptr Compositor.t
 
   let wlr_compositor_create = foreign "wlr_compositor_create"
       (wl_display_p @-> wlr_renderer_p @-> returning wlr_compositor_p)
 
+  (* wlr_xdg_shell *)
+
+  let wlr_xdg_shell_p = ptr Xdg_shell.t
+
+  let wlr_xdg_shell_create = foreign "wlr_xdg_shell_create"
+      (wl_display_p @-> returning wlr_xdg_shell_p)
+
+  (* wlr_cursor *)
+
+  let wlr_cursor_p = ptr Cursor.t
+
+  let wlr_cursor_create = foreign "wlr_cursor_create"
+      (void @-> returning wlr_cursor_p)
+
+  let wlr_cursor_attach_output_layout =
+    foreign "wlr_cursor_attach_output_layout"
+      (wlr_cursor_p @-> wlr_output_layout_p @-> returning void)
+
+  (* wlr_xcursor_manager *)
+
+  let wlr_xcursor_manager_p = ptr Xcursor_manager.t
+
+  let wlr_xcursor_manager_create = foreign "wlr_xcursor_manager_create"
+      (string_opt @-> int @-> returning wlr_xcursor_manager_p)
+
+  let wlr_xcursor_manager_load = foreign "wlr_xcursor_manager_load"
+      (wlr_xcursor_manager_p @-> float @-> returning int)
+
+  (* wlr_seat *)
+
+  let wlr_seat_p = ptr Seat.t
+
+  let wlr_seat_create = foreign "wlr_seat_create"
+      (wl_display_p @-> string @-> returning wlr_seat_p)
+
   (* wlr_log *)
 
   (* TODO *)

lib/compositor.ml

@@ -5,6 +5,7 @@ module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi)
 module Types = Wlroots_ffi_f.Ffi.Types
 
 type t = Types.Compositor.t ptr
+include Ptr
 
 let create dpy renderer =
   Bindings.wlr_compositor_create dpy renderer

lib/cursor.ml

@@ -0,0 +1,37 @@
+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.Cursor.t ptr
+include Ptr
+
+let create = Bindings.wlr_cursor_create
+let attach_output_layout = Bindings.wlr_cursor_attach_output_layout
+
+let signal_motion (cursor: t) : Pointer.Event_motion.t Wl.Signal.t = {
+  c = cursor |-> Types.Cursor.events_motion;
+  typ = Pointer.Event_motion.t;
+}
+
+let signal_motion_absolute (cursor: t) :
+  Pointer.Event_motion_absolute.t Wl.Signal.t = {
+  c = cursor |-> Types.Cursor.events_motion_absolute;
+  typ = Pointer.Event_motion_absolute.t;
+}
+
+let signal_button (cursor: t) : Pointer.Event_button.t Wl.Signal.t = {
+  c = cursor |-> Types.Cursor.events_button;
+  typ = Pointer.Event_button.t;
+}
+
+let signal_axis (cursor: t) : Pointer.Event_axis.t Wl.Signal.t = {
+  c = cursor |-> Types.Cursor.events_axis;
+  typ = Pointer.Event_axis.t;
+}
+
+let signal_frame (cursor: t) : unit Wl.Signal.t = {
+  c = cursor |-> Types.Cursor.events_frame;
+  typ = void;
+}

lib/data_device.ml

@@ -0,0 +1,12 @@
+open Ctypes
+open Wlroots_common.Utils
+
+module Bindings = Wlroots_ffi_f.Ffi.Make (Generated_ffi)
+module Types = Wlroots_ffi_f.Ffi.Types
+
+module Manager = struct
+  type t = Types.Data_device_manager.t ptr
+  include Ptr
+
+  let create = Bindings.wlr_data_device_manager_create
+end

lib/dune

@@ -16,7 +16,8 @@
            generated_ffi
            wl log texture surface box matrix output
            keyboard pointer touch tablet_tool tablet_pad input_device
-           backend renderer compositor)
+           backend renderer data_device compositor xdg_shell cursor
+           xcursor_manager seat)
   (c_names generated_ffi_stubs)
   (c_flags (:standard -Werror -pedantic -Wall -Wunused -DWLR_USE_UNSTABLE -O0) -w
            (:include ../config/wlroots-ccopt.sexp)

lib/output.ml

@@ -59,3 +59,10 @@ let attach_render (output : t): bool =
 
 let commit (output : t): bool =
   Bindings.wlr_output_commit output
+
+module Layout = struct
+  type t = Types.Output_layout.t ptr
+  include Ptr
+
+  let create = Bindings.wlr_output_layout_create
+end

lib/pointer.ml

@@ -6,3 +6,27 @@ module Types = Wlroots_ffi_f.Ffi.Types
 
 type t = Types.Pointer.t ptr
 include Ptr
+
+module Event_motion = struct
+  type t = Types.Event_pointer_motion.t ptr
+  let t = ptr Types.Event_pointer_motion.t
+  include Ptr
+end
+
+module Event_motion_absolute = struct
+  type t = Types.Event_pointer_motion_absolute.t ptr
+  let t = ptr Types.Event_pointer_motion_absolute.t
+  include Ptr
+end
+
+module Event_button = struct
+  type t = Types.Event_pointer_button.t ptr
+  let t = ptr Types.Event_pointer_button.t
+  include Ptr
+end
+
+module Event_axis = struct
+  type t = Types.Event_pointer_axis.t ptr
+  let t = ptr Types.Event_pointer_axis.t
+  include Ptr
+end

lib/renderer.ml

@@ -16,3 +16,5 @@ let end_ (renderer : t) =
 let clear (renderer : t) ((c1,c2,c3,c4) : float * float * float * float) =
   let color_arr = CArray.of_list float [c1;c2;c3;c4] in
   Bindings.wlr_renderer_clear renderer (CArray.start color_arr)
+
+let init_wl_display = Bindings.wlr_renderer_init_wl_display