nandi/jolt-native · wayland-bar-compositor

⑂ main
wayland-bar-compositor · 778 lines · 39.3 KBGDScript3    Blame HistoryRaw
wayland-bar-compositor: a wlroots compositor in jolt, for panels on X11   1#!/usr/bin/env jolt
2;; A Wayland compositor for wayland-bar, written in jolt on raw wlroots.
4;; It replaces the nested sway: one wlroots X11 output of the requested size,
5;; layer-shell and xdg-shell surfaces drawn by the wlroots scene graph, pointer
6;; and keyboard forwarded to them. Because it owns the scene, it knows where
7;; every popup is, so it shapes its own X11 window (strip + popups) through
8;; XShape directly — no screenshots, no polling.
10;; usage: wayland-bar-compositor --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]
12;; Struct offsets come from offsets.edn, generated from the installed wlroots
13;; headers by ./build. Single-threaded: every wlroots callback arrives on this
14;; thread from inside wl_event_loop_dispatch.
16(require '[jolt.ffi :as ffi]
17         '[babashka.fs :as fs]
18         '[babashka.process :as p]
19         '[clojure.edn :as edn]
20         '[clojure.string :as str])
22(def here (str (fs/parent (fs/canonicalize *file*))))
24(def debug? (some? (System/getenv "WBC_DEBUG")))
26(defn debug [& parts]
27  (when debug?
28    (binding [*out* *err*] (apply println "wbc:" parts))))
30(defn die [& msg]
31  (binding [*out* *err*] (apply println "wayland-bar-compositor:" msg))
32  (System/exit 1))
34;; --- arguments ---------------------------------------------------------------
36(defn parse-args [args]
37  (loop [[a b & more :as args] args opts {}]
38
39      (empty? args) opts
40      (= a "--") (assoc opts :command (vec (rest args)))
41      (= a "--size") (let [[w h] (map parse-long (str/split b #"x"))] (recur more (assoc opts :width w :height h)))
42      (= a "--strip") (recur more (assoc opts :strip (mapv parse-long (str/split b #","))))
43      (= a "--title") (recur more (assoc opts :title b))
44      (str/starts-with? a "--") (die "unknown argument" a)
45      ;; jolt may consume a "--" itself, so the first non-option starts the command.
46      :else (assoc opts :command (vec args)))))
48(def opts (parse-args *command-line-args*))
49(let [{:keys [width height strip title command]} opts]
50  (when-not (and width height strip title (seq command))
51    (die "usage: --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]")))
53;; --- layout facts --------------------------------------------------------------
55(def layout
56  (let [f (str here "/offsets.edn")]
57    (when-not (fs/exists? f) (die "missing" f "- run" (str here "/build")))
58    (edn/read-string (slurp f))))
60(defn off [k]
61  (or (get layout k) (die "offsets.edn has no" k)))
63;; --- libraries -----------------------------------------------------------------
65(ffi/load-library "libc.so.6")
66(ffi/load-library "libwayland-server.so.0")
67(ffi/load-library "libxkbcommon.so.0")
68(ffi/load-library "libwlroots-0.20.so")
69(ffi/load-library "libX11.so.6")
70(ffi/load-library "libXext.so.6")
72(ffi/defcfn clock-gettime "clock_gettime" [:int :pointer] :int)
74(ffi/defcfn wl-display-create "wl_display_create" [] :pointer)
75(ffi/defcfn wl-display-get-event-loop "wl_display_get_event_loop" [:pointer] :pointer)
76(ffi/defcfn wl-display-add-socket-auto "wl_display_add_socket_auto" [:pointer] :string)
77(ffi/defcfn wl-display-flush-clients "wl_display_flush_clients" [:pointer] :void)
78(ffi/defcfn wl-display-destroy-clients "wl_display_destroy_clients" [:pointer] :void)
79(ffi/defcfn wl-event-loop-dispatch "wl_event_loop_dispatch" [:pointer :int] :int)
80(ffi/defcfn wl-list-insert "wl_list_insert" [:pointer :pointer] :void)
81(ffi/defcfn wl-list-remove "wl_list_remove" [:pointer] :void)
83(ffi/defcfn xkb-context-new "xkb_context_new" [:int] :pointer)
84(ffi/defcfn xkb-keymap-new-from-names "xkb_keymap_new_from_names" [:pointer :pointer :int] :pointer)
85(ffi/defcfn xkb-keymap-unref "xkb_keymap_unref" [:pointer] :void)
86(ffi/defcfn xkb-context-unref "xkb_context_unref" [:pointer] :void)
88(ffi/defcfn backend-autocreate "wlr_backend_autocreate" [:pointer :pointer] :pointer)
89(ffi/defcfn backend-start "wlr_backend_start" [:pointer] :bool)
90(ffi/defcfn renderer-autocreate "wlr_renderer_autocreate" [:pointer] :pointer)
91(ffi/defcfn renderer-init-wl-display "wlr_renderer_init_wl_display" [:pointer :pointer] :bool)
92(ffi/defcfn allocator-autocreate "wlr_allocator_autocreate" [:pointer :pointer] :pointer)
94(ffi/defcfn compositor-create "wlr_compositor_create" [:pointer :uint32 :pointer] :pointer)
95(ffi/defcfn subcompositor-create "wlr_subcompositor_create" [:pointer] :pointer)
96(ffi/defcfn data-device-manager-create "wlr_data_device_manager_create" [:pointer] :pointer)
97(ffi/defcfn primary-selection-manager-create "wlr_primary_selection_v1_device_manager_create" [:pointer] :pointer)
98(ffi/defcfn data-control-manager-create "wlr_data_control_manager_v1_create" [:pointer] :pointer)
99(ffi/defcfn xdg-output-manager-create "wlr_xdg_output_manager_v1_create" [:pointer :pointer] :pointer)
100(ffi/defcfn screencopy-manager-create "wlr_screencopy_manager_v1_create" [:pointer] :pointer)
101(ffi/defcfn viewporter-create "wlr_viewporter_create" [:pointer] :pointer)
102(ffi/defcfn fractional-scale-manager-create "wlr_fractional_scale_manager_v1_create" [:pointer :uint32] :pointer)
103(ffi/defcfn single-pixel-buffer-manager-create "wlr_single_pixel_buffer_manager_v1_create" [:pointer] :pointer)
104(ffi/defcfn presentation-create "wlr_presentation_create" [:pointer :pointer :uint32] :pointer)
105(ffi/defcfn xdg-activation-create "wlr_xdg_activation_v1_create" [:pointer] :pointer)
107(ffi/defcfn output-layout-create "wlr_output_layout_create" [:pointer] :pointer)
108(ffi/defcfn output-layout-add-auto "wlr_output_layout_add_auto" [:pointer :pointer] :pointer)
109(ffi/defcfn output-init-render "wlr_output_init_render" [:pointer :pointer :pointer] :bool)
110(ffi/defcfn output-state-init "wlr_output_state_init" [:pointer] :void)
111(ffi/defcfn output-state-finish "wlr_output_state_finish" [:pointer] :void)
112(ffi/defcfn output-state-set-enabled "wlr_output_state_set_enabled" [:pointer :bool] :void)
113(ffi/defcfn output-state-set-custom-mode "wlr_output_state_set_custom_mode" [:pointer :int32 :int32 :int32] :void)
114(ffi/defcfn output-commit-state "wlr_output_commit_state" [:pointer :pointer] :bool)
115(ffi/defcfn x11-output-set-title "wlr_x11_output_set_title" [:pointer :string] :void)
116(ffi/defcfn output-is-x11 "wlr_output_is_x11" [:pointer] :bool)
118(ffi/defcfn scene-create "wlr_scene_create" [] :pointer)
119(ffi/defcfn scene-attach-output-layout "wlr_scene_attach_output_layout" [:pointer :pointer] :pointer)
120(ffi/defcfn scene-output-create "wlr_scene_output_create" [:pointer :pointer] :pointer)
121(ffi/defcfn scene-output-layout-add-output "wlr_scene_output_layout_add_output" [:pointer :pointer :pointer] :void)
122(ffi/defcfn scene-output-needs-frame "wlr_scene_output_needs_frame" [:pointer] :bool)
123(ffi/defcfn scene-output-build-state "wlr_scene_output_build_state" [:pointer :pointer :pointer] :bool)
124(ffi/defcfn buffer-begin-data-ptr-access "wlr_buffer_begin_data_ptr_access" [:pointer :uint32 :pointer :pointer :pointer] :bool)
125(ffi/defcfn buffer-end-data-ptr-access "wlr_buffer_end_data_ptr_access" [:pointer] :void)
126(ffi/defcfn scene-output-send-frame-done "wlr_scene_output_send_frame_done" [:pointer :pointer] :void)
127(ffi/defcfn scene-tree-create "wlr_scene_tree_create" [:pointer] :pointer)
128(ffi/defcfn scene-node-at "wlr_scene_node_at" [:pointer :double :double :pointer :pointer] :pointer)
129(ffi/defcfn scene-node-coords "wlr_scene_node_coords" [:pointer :pointer :pointer] :bool)
130(ffi/defcfn scene-buffer-from-node "wlr_scene_buffer_from_node" [:pointer] :pointer)
131(ffi/defcfn scene-surface-try-from-buffer "wlr_scene_surface_try_from_buffer" [:pointer] :pointer)
132(ffi/defcfn scene-xdg-surface-create "wlr_scene_xdg_surface_create" [:pointer :pointer] :pointer)
133(ffi/defcfn scene-layer-surface-create "wlr_scene_layer_surface_v1_create" [:pointer :pointer] :pointer)
134(ffi/defcfn scene-layer-surface-configure "wlr_scene_layer_surface_v1_configure" [:pointer :pointer :pointer] :void)
136(ffi/defcfn xdg-shell-create "wlr_xdg_shell_create" [:pointer :uint32] :pointer)
137(ffi/defcfn xdg-surface-try-from-wlr-surface "wlr_xdg_surface_try_from_wlr_surface" [:pointer] :pointer)
138(ffi/defcfn xdg-surface-schedule-configure "wlr_xdg_surface_schedule_configure" [:pointer] :uint32)
139(ffi/defcfn xdg-toplevel-set-size "wlr_xdg_toplevel_set_size" [:pointer :int32 :int32] :uint32)
140(ffi/defcfn xdg-popup-unconstrain-from-box "wlr_xdg_popup_unconstrain_from_box" [:pointer :pointer] :void)
141(ffi/defcfn layer-shell-create "wlr_layer_shell_v1_create" [:pointer :uint32] :pointer)
142(ffi/defcfn layer-surface-try-from-wlr-surface "wlr_layer_surface_v1_try_from_wlr_surface" [:pointer] :pointer)
144(ffi/defcfn cursor-create "wlr_cursor_create" [] :pointer)
145(ffi/defcfn cursor-attach-output-layout "wlr_cursor_attach_output_layout" [:pointer :pointer] :void)
146(ffi/defcfn cursor-attach-input-device "wlr_cursor_attach_input_device" [:pointer :pointer] :void)
147(ffi/defcfn cursor-move "wlr_cursor_move" [:pointer :pointer :double :double] :void)
148(ffi/defcfn cursor-warp-absolute "wlr_cursor_warp_absolute" [:pointer :pointer :double :double] :void)
149(ffi/defcfn cursor-set-xcursor "wlr_cursor_set_xcursor" [:pointer :pointer :string] :void)
150(ffi/defcfn cursor-set-surface "wlr_cursor_set_surface" [:pointer :pointer :int32 :int32] :void)
151(ffi/defcfn xcursor-manager-create "wlr_xcursor_manager_create" [:pointer :uint32] :pointer)
153(ffi/defcfn seat-create "wlr_seat_create" [:pointer :string] :pointer)
154(ffi/defcfn seat-set-capabilities "wlr_seat_set_capabilities" [:pointer :uint32] :void)
155(ffi/defcfn seat-set-keyboard "wlr_seat_set_keyboard" [:pointer :pointer] :void)
156(ffi/defcfn seat-set-selection "wlr_seat_set_selection" [:pointer :pointer :uint32] :void)
157(ffi/defcfn seat-set-primary-selection "wlr_seat_set_primary_selection" [:pointer :pointer :uint32] :void)
158(ffi/defcfn seat-pointer-notify-enter "wlr_seat_pointer_notify_enter" [:pointer :pointer :double :double] :void)
159(ffi/defcfn seat-pointer-notify-motion "wlr_seat_pointer_notify_motion" [:pointer :uint32 :double :double] :void)
160(ffi/defcfn seat-pointer-notify-button "wlr_seat_pointer_notify_button" [:pointer :uint32 :uint32 :int] :uint32)
161(ffi/defcfn seat-pointer-notify-axis "wlr_seat_pointer_notify_axis" [:pointer :uint32 :int :double :int32 :int :int] :void)
162(ffi/defcfn seat-pointer-notify-frame "wlr_seat_pointer_notify_frame" [:pointer] :void)
163(ffi/defcfn seat-pointer-clear-focus "wlr_seat_pointer_clear_focus" [:pointer] :void)
164(ffi/defcfn seat-keyboard-notify-enter "wlr_seat_keyboard_notify_enter" [:pointer :pointer :pointer :size_t :pointer] :void)
165(ffi/defcfn seat-keyboard-notify-key "wlr_seat_keyboard_notify_key" [:pointer :uint32 :uint32 :uint32] :void)
166(ffi/defcfn seat-keyboard-notify-modifiers "wlr_seat_keyboard_notify_modifiers" [:pointer :pointer] :void)
167(ffi/defcfn keyboard-from-input-device "wlr_keyboard_from_input_device" [:pointer] :pointer)
168(ffi/defcfn keyboard-set-keymap "wlr_keyboard_set_keymap" [:pointer :pointer] :bool)
169(ffi/defcfn keyboard-set-repeat-info "wlr_keyboard_set_repeat_info" [:pointer :int32 :int32] :void)
171(ffi/load-library "libXi.so.6")
172(ffi/defcfn wl-event-loop-add-fd "wl_event_loop_add_fd" [:pointer :int :uint32 :pointer :pointer] :pointer)
173(ffi/defcfn xdg-popup-destroy "wlr_xdg_popup_destroy" [:pointer] :void)
174(ffi/defcfn x-query-extension "XQueryExtension" [:pointer :string :pointer :pointer :pointer] :int)
175(ffi/defcfn xi-query-version "XIQueryVersion" [:pointer :pointer :pointer] :int)
176(ffi/defcfn xi-select-events "XISelectEvents" [:pointer :long :pointer :int] :int)
177(ffi/defcfn x-pending "XPending" [:pointer] :int)
178(ffi/defcfn x-next-event "XNextEvent" [:pointer :pointer] :int)
179(ffi/defcfn x-get-event-data "XGetEventData" [:pointer :pointer] :int)
180(ffi/defcfn x-free-event-data "XFreeEventData" [:pointer :pointer] :void)
181(ffi/defcfn x-query-pointer "XQueryPointer"
182  [:pointer :long :pointer :pointer :pointer :pointer :pointer :pointer :pointer] :int)
183(ffi/defcfn x-default-root-window "XDefaultRootWindow" [:pointer] :long)
184(ffi/defcfn x-connection-number "XConnectionNumber" [:pointer] :int)
185(ffi/defcfn x-open-display "XOpenDisplay" [:pointer] :pointer)
186(ffi/defcfn x-flush "XFlush" [:pointer] :int)
187(ffi/defcfn x-shape-combine-rectangles "XShapeCombineRectangles"
188  [:pointer :long :int :int :int :pointer :int :int :int] :void)
190;; --- memory helpers ---------------------------------------------------------------
192(def arena (ffi/global-arena))
193(defn ptr [p k] (ffi/read p :pointer (off k)))
194(defn i32 [p k] (ffi/read p :int (off k)))
195(defn u32 [p k] (ffi/read p :uint32 (off k)))
196(defn f64 [p k] (ffi/read p :double (off k)))
197(defn flag [p k] (not (zero? (ffi/read p :uint8 (off k)))))
198(defn field [p k] (+ p (off k)))
200;; Scratch buffers reused by every callback; this compositor is single-threaded.
201(def out-a (ffi/alloc arena 8))
202(def out-b (ffi/alloc arena 8))
203(def box-buf (ffi/alloc arena (off :wlr_box/sizeof)))
204(def usable-buf (ffi/alloc arena (off :wlr_box/sizeof)))
205(def timespec (ffi/alloc arena (off :timespec/sizeof)))
207(defn write-box! [buf x y w h]
208  (ffi/write buf :int x (off :wlr_box/x))
209  (ffi/write buf :int y (off :wlr_box/y))
210  (ffi/write buf :int w (off :wlr_box/width))
211  (ffi/write buf :int h (off :wlr_box/height))
214;; --- signals ----------------------------------------------------------------------
215;; wl_signal_add is a static inline in C. Every listener here shares ONE native
216;; callback, which looks the listener's address up in `handlers`; listeners come
217;; from a free list, so surfaces that come and go don't leak callbacks.
219(def handlers (atom {}))
220(def free-listeners (atom ()))
222(defn- dispatch [listener data]
223  (when-let [f (get @handlers listener)]
224    (try (f data)
225         (catch Throwable e
226           (binding [*out* *err*] (println "wayland-bar-compositor: handler failed:" e))))))
228(def notify (ffi/callback arena dispatch [:pointer :pointer] :void))
230(defn listen!
231  "Hook f onto the wl_signal at address `signal`. Answers the listener."
232  [signal f]
233  (let [listener (or (let [[l] @free-listeners] (when l (swap! free-listeners rest) l))
234                     (ffi/alloc arena (off :wl_listener/sizeof)))]
235    (ffi/write listener :pointer notify (off :wl_listener/notify))
236    (swap! handlers assoc listener f)
237    ;; wl_list_insert(signal->listener_list.prev, &listener->link)
238    (wl-list-insert (ffi/read signal :pointer 0) (field listener :wl_listener/link))
239    listener))
241(defn unlisten! [& listeners]
242  (doseq [l listeners]
243    (wl-list-remove (field l :wl_listener/link))
244    (swap! handlers dissoc l)
245    (swap! free-listeners conj l)))
247;; --- the server -----------------------------------------------------------------
249(def width (:width opts))
250(def height (:height opts))
251(def display (wl-display-create))
252(def event-loop (wl-display-get-event-loop display))
253(def backend (backend-autocreate event-loop 0))
254(when (zero? backend) (die "no wlroots backend; is DISPLAY set and WLR_BACKENDS=x11?"))
255(def renderer (renderer-autocreate backend))
256(when (zero? renderer) (die "no renderer"))
257(renderer-init-wl-display renderer display)
258(def allocator (allocator-autocreate backend renderer))
259(when (zero? allocator) (die "no allocator"))
261(compositor-create display 5 renderer)
262(subcompositor-create display)
263(data-device-manager-create display)
264(primary-selection-manager-create display)
265(data-control-manager-create display)
266(viewporter-create display)
267(fractional-scale-manager-create display 1)
268(single-pixel-buffer-manager-create display)
269(screencopy-manager-create display)
270(xdg-activation-create display)
271(presentation-create display backend 2)
273(def output-layout (output-layout-create display))
274(xdg-output-manager-create display output-layout)
275(def scene (scene-create))
276(def scene-layout (scene-attach-output-layout scene output-layout))
277(def root (field scene :wlr_scene/tree))
279;; Layer-shell layers, bottom to top; popups float above everything.
280(def layer-trees (vec (repeatedly 4 #(scene-tree-create root))))
281(def toplevel-tree (scene-tree-create root))
282(def popup-tree (scene-tree-create root))
284(def output (atom nil))           ; the one wlr_output
285(def layer-surfaces (atom {}))    ; wlr_layer_surface_v1 -> scene layer surface
286(def popups (atom {}))            ; wlr_xdg_popup -> scene tree
288;; --- X11 window shape --------------------------------------------------------------
290(def x-display (x-open-display 0))
291(when (zero? x-display) (die "cannot open the X display"))
292(def x-window (atom nil))
293(def shown-rects (atom nil))
294(def max-rects 1024)
295(def rect-buf (ffi/alloc arena (* 8 max-rects)))  ; XRectangle { short x, y; ushort w, h }
297(defn find-x-window
298  "wlroots owns the X11 window; we gave it a unique title, so look it up."
300  (let [out (:out (p/sh "xwininfo" "-name" (:title opts)))]
301    (some->> (re-find #"Window id: (0x[0-9a-f]+)" out) second (#(Long/parseLong (subs % 2) 16)))))
303(defn popup-rects
304  "Layout-space boxes of every mapped popup: its geometry, without shadows."
306  (for [[popup tree] @popups
307        :let [base (ptr popup :wlr_xdg_popup/base)
308              surface (ptr base :wlr_xdg_surface/surface)]
309        :when (flag surface :wlr_surface/mapped)
310        :let [_ (scene-node-coords (field tree :wlr_scene_tree/node) out-a out-b)
311              geo (field base :wlr_xdg_surface/geometry)
312              w (i32 geo :wlr_box/width)
313              h (i32 geo :wlr_box/height)]
314        :when (and (pos? w) (pos? h))]
315    [(ffi/read out-a :int) (ffi/read out-b :int) w h]))
317;; Popups have rounded corners; their geometry box would show the black output
318;; behind the corners. So read the frame about to be shown and trace each
319;; corner row inward to the first painted pixel. Pixman frames are plain
320;; memory, and only corner rows are scanned, only when the popups change.
322(def data-out (ffi/alloc arena 8))
323(def format-out (ffi/alloc arena 4))
324(def stride-out (ffi/alloc arena 8))
325(def rgb32-formats #{0x34325258 0x34325241 0x34324258 0x34324241})   ; XRGB/ARGB/XBGR/ABGR8888
327;; Transparent margins and faint shadows composite onto the black output as
328;; black or near-black; a popup's own background is well above this.
329(def paint-threshold 10)
331(defn- painted? [px]
332  (or (> (bit-and (bit-shift-right px 16) 0xff) paint-threshold)
333      (> (bit-and (bit-shift-right px 8) 0xff) paint-threshold)
334      (> (bit-and px 0xff) paint-threshold)))
336(defn- row-span
337  "[left right) of the painted part of row y within [x, x+w); nil if none.
338  The row is copied out in one call rather than read pixel by pixel."
339  [data stride x y w]
340  (let [row (ffi/read-array (+ data (* y stride)) :uint32 w (* 4 x))
341        left (loop [i 0] (cond (= i w) nil (painted? (aget row i)) i :else (recur (inc i))))]
342    (when left
343      (let [right (loop [i (dec w)] (if (painted? (aget row i)) (inc i) (recur (dec i))))]
344        [(+ x left) (+ x right)]))))
346(defn outline-rects
347  "XShape rects for popup box [x y w h], following what the popup actually
348  painted: rounded corners, and any transparent margin its geometry includes.
349  Consecutive rows with the same span merge into one rect."
350  [data stride [x y w h]]
351  (let [rows (for [row (range y (+ y h))
352                   :let [[l r] (row-span data stride x row w)]
353                   :when l]
354               [l row (- r l) 1])]
355    (->> rows
356         (reduce (fn [acc [rx ry rw rh :as rect]]
357                   (let [[px py pw ph] (peek acc)]
358                     (if (and px (= px rx) (= pw rw) (= (+ py ph) ry))
359                       (conj (pop acc) [px py pw (+ ph rh)])
360                       (conj acc rect))))
361                 []))))
363(defn- frame-outlines
364  "Outline rects for every popup box, read from `buffer`; nil if unreadable."
365  [buffer boxes]
366  (when (and (pos? buffer)
367             (buffer-begin-data-ptr-access buffer (off :enum/buffer-data-ptr-access-read)
368                                           data-out format-out stride-out))
369
370      (when (rgb32-formats (ffi/read format-out :uint32))
371        (let [data (ffi/read data-out :pointer)
372              stride (ffi/read stride-out :size_t)]
373          (vec (mapcat (fn [[x y w h]]
374                         ;; clamp to the output so a scan never leaves the buffer
375                         (let [x (max 0 x) y (max 0 y)
376                               w (min w (- width x)) h (min h (- height y))]
377                           (when (and (pos? w) (pos? h))
378                             (outline-rects data stride [x y w h]))))
379                       boxes))))
380      (finally (buffer-end-data-ptr-access buffer)))))
382(def shown-boxes (atom nil))
383(def popups-dirty (atom false))   ; a popup committed since its outline was traced
385(defn update-shape!
386  "Shape the window to the strip plus the popups' outlines. `buffer` is the
387  frame about to be shown, or nil when nothing was rendered."
388
389  (when-not @x-window
390    (reset! x-window (find-x-window)))
391  (when-let [win @x-window]
392    (let [boxes (vec (popup-rects))
393          retrace? (and (seq boxes) (or (not= boxes @shown-boxes) (and buffer @popups-dirty)))
394          outlines (when retrace?
395                     ;; tracing needs a rendered frame; without one, wait for it
396                     (when buffer
397                       (reset! popups-dirty false)
398                       (or (frame-outlines buffer boxes) boxes)))
399          rects (cond
400                  (empty? boxes) [(:strip opts)]
401                  outlines (vec (take max-rects (cons (:strip opts) outlines)))
402                  :else nil)]
403      (when (and rects (not= rects @shown-rects))
404        (reset! shown-boxes boxes)
405        (debug "shape" (count rects) "rects" (take 4 rects))
406        (doseq [[i [x y w h]] (map-indexed vector rects)]
407          (ffi/write rect-buf :short (short x) (* 8 i))
408          (ffi/write rect-buf :short (short y) (+ 2 (* 8 i)))
409          (ffi/write rect-buf :short (unchecked-short w) (+ 4 (* 8 i)))
410          (ffi/write rect-buf :short (unchecked-short h) (+ 6 (* 8 i))))
411        ;; ShapeBounding = 0, ShapeInput = 2; ShapeSet = 0; Unsorted = 0
412        (x-shape-combine-rectangles x-display win 0 0 0 rect-buf (count rects) 0 0)
413        (x-shape-combine-rectangles x-display win 2 0 0 rect-buf (count rects) 0 0)
414        (x-flush x-display)
415        (reset! shown-rects rects)))))
417;; --- outputs ------------------------------------------------------------------------
419(defn with-output-state [f]
420  (let [state (ffi/alloc arena (off :wlr_output_state/sizeof))]
421    (output-state-init state)
422    (try (f state) (finally (output-state-finish state)))))
424(def child (atom nil))
425(def frame-state (ffi/alloc arena (off :wlr_output_state/sizeof)))   ; reused every frame
427(defn arrange-layers! []
428  (write-box! box-buf 0 0 width height)
429  (write-box! usable-buf 0 0 width height)
430  (doseq [[_ scene-ls] @layer-surfaces]
431    (scene-layer-surface-configure scene-ls box-buf usable-buf)))
433(listen! (field backend :wlr_backend/events.new_output)
434  (fn [wlr-output]
435    (if @output
436      (println "wayland-bar-compositor: ignoring extra output")
437
438        (reset! output wlr-output)
439        (output-init-render wlr-output allocator renderer)
440        (with-output-state
441          (fn [state]
442            (output-state-set-enabled state true)
443            (output-state-set-custom-mode state width height 0)
444            (output-commit-state wlr-output state)))
445        (when (output-is-x11 wlr-output)
446          (x11-output-set-title wlr-output (:title opts)))
447        (let [scene-output (scene-output-create scene wlr-output)]
448          (scene-output-layout-add-output scene-layout (output-layout-add-auto output-layout wlr-output) scene-output)
449          (listen! (field wlr-output :wlr_output/events.frame)
450            (fn [_]
451              ;; wlr_scene_output_commit, split open so the frame can be read
452              ;; for popup outlines between rendering and showing it.
453              (if (scene-output-needs-frame scene-output)
455                  (output-state-init frame-state)
457                    (when (scene-output-build-state scene-output frame-state 0)
458                      (update-shape! (when (pos? (bit-and (u32 frame-state :wlr_output_state/committed)
459                                                          (off :enum/output-state-buffer)))
460                                       (ptr frame-state :wlr_output_state/buffer)))
461                      (output-commit-state wlr-output frame-state))
462                    (finally (output-state-finish frame-state))))
463                (update-shape! nil))
464              (clock-gettime 1 timespec)           ; CLOCK_MONOTONIC
465              (scene-output-send-frame-done scene-output timespec)))
466          (listen! (field wlr-output :wlr_output/events.request_state)
467            (fn [event]
468              (output-commit-state wlr-output (ptr event :wlr_output_event_request_state/state)))))))))
470;; --- layer shell -----------------------------------------------------------------
472(def layer-shell (layer-shell-create display 4))
473(declare add-popup!)
475(listen! (field layer-shell :wlr_layer_shell_v1/events.new_surface)
476
477    (when (zero? (ptr ls :wlr_layer_surface_v1/output))
478      (ffi/write ls :pointer (or @output 0) (off :wlr_layer_surface_v1/output)))
479    (let [layer (min 3 (max 0 (i32 ls :wlr_layer_surface_v1/current.layer)))
480          scene-ls (scene-layer-surface-create (nth layer-trees layer) ls)
481          surface (ptr ls :wlr_layer_surface_v1/surface)]
482      ;; popups find their parent's scene tree through data
483      (ffi/write ls :pointer (ptr scene-ls :wlr_scene_layer_surface_v1/tree) (off :wlr_layer_surface_v1/data))
484      (swap! layer-surfaces assoc ls scene-ls)
485      (let [commit (listen! (field surface :wlr_surface/events.commit)
486                     (fn [_] (when (flag ls :wlr_layer_surface_v1/initialized) (arrange-layers!))))
487            ;; xdg-shell announces a layer surface's popup before it has a
488            ;; parent; this signal comes once the parent is set.
489            new-popup (listen! (field ls :wlr_layer_surface_v1/events.new_popup) add-popup!)
490            destroy (atom nil)]
491        (reset! destroy
492          (listen! (field ls :wlr_layer_surface_v1/events.destroy)
493            (fn [_]
494              (swap! layer-surfaces dissoc ls)
495              (unlisten! commit new-popup @destroy))))))))
497;; --- xdg shell -------------------------------------------------------------------
499(def xdg-shell (xdg-shell-create display 6))
501(listen! (field xdg-shell :wlr_xdg_shell/events.new_toplevel)
502  (fn [toplevel]
503    (let [base (ptr toplevel :wlr_xdg_toplevel/base)
504          tree (scene-xdg-surface-create toplevel-tree base)
505          surface (ptr base :wlr_xdg_surface/surface)]
506      (ffi/write base :pointer tree (off :wlr_xdg_surface/data))
507      (let [commit (listen! (field surface :wlr_surface/events.commit)
508                     (fn [_] (when (flag base :wlr_xdg_surface/initial_commit)
509                               (xdg-toplevel-set-size toplevel 0 0))))
510            destroy (atom nil)]
511        (reset! destroy
512          (listen! (field toplevel :wlr_xdg_toplevel/events.destroy)
513            (fn [_] (unlisten! commit @destroy))))))))
515(defn parent-tree
516  "The scene tree a popup's parent surface draws into: an xdg surface's or a
517  layer surface's, both kept in their data field."
518  [parent-surface]
519  (let [xdg (xdg-surface-try-from-wlr-surface parent-surface)]
520    (if (pos? xdg)
521      (ptr xdg :wlr_xdg_surface/data)
522      (let [ls (layer-surface-try-from-wlr-surface parent-surface)]
523        (when (pos? ls) (ptr ls :wlr_layer_surface_v1/data))))))
525(defn add-popup!
526  "Put a popup whose parent is set into the scene, under its parent's tree."
527
528  (let [base (ptr popup :wlr_xdg_popup/base)
529        surface (ptr base :wlr_xdg_surface/surface)
530        parent (parent-tree (ptr popup :wlr_xdg_popup/parent))]
531    (debug "add popup" popup "parent tree" parent)
532    (if-not parent
533      (println "wayland-bar-compositor: popup with no known parent")
534      (let [tree (scene-xdg-surface-create parent base)]
535          (ffi/write base :pointer tree (off :wlr_xdg_surface/data))
536          (swap! popups assoc popup tree)
537          (let [commit (listen! (field surface :wlr_surface/events.commit)
539                           ;; new content may change the outline (a client's
540                           ;; first buffer is often blank), so retrace it
541                           (reset! popups-dirty true)
542                           (when (flag base :wlr_xdg_surface/initial_commit)
543                             ;; keep the popup inside the output, in parent-relative space
544                             (scene-node-coords (field parent :wlr_scene_tree/node) out-a out-b)
545                             (xdg-popup-unconstrain-from-box
546                               popup (write-box! box-buf (- (ffi/read out-a :int)) (- (ffi/read out-b :int)) width height))
547                             (xdg-surface-schedule-configure base))))
548                destroy (atom nil)]
549            (reset! destroy
550              (listen! (field popup :wlr_xdg_popup/events.destroy)
551                (fn [_]
552                  (swap! popups dissoc popup)
553                  (unlisten! commit @destroy)))))))))
555;; A layer surface's popup arrives here with no parent yet and again, parented,
556;; on the layer surface's own new_popup; only take the parented ones here.
557(listen! (field xdg-shell :wlr_xdg_shell/events.new_popup)
558  (fn [popup]
559    (when (pos? (ptr popup :wlr_xdg_popup/parent))
560      (add-popup! popup))))
562;; --- clicks on X11 apps close popups --------------------------------------------
563;; A click on an X11 window never reaches Wayland, so popups' own grabs can't
564;; see it. XInput2 raw button presses on the root window report every click
565;; without grabbing anything; if the pointer is outside what our window shows,
566;; close the open popups. Layouts below checked against the X11/XI2 headers.
568(def generic-event 35)
569(def xi-raw-button-press 15)
571(def xi-opcode
572  (let [opcode (ffi/alloc arena 4) event (ffi/alloc arena 4) error (ffi/alloc arena 4)]
573    (when (pos? (x-query-extension x-display "XInputExtension" opcode event error))
574      (ffi/read opcode :int))))
576(if-not xi-opcode
577  (println "wayland-bar-compositor: no XInput2; clicks on X11 apps won't close popups")
578  (let [major (ffi/alloc arena 4) minor (ffi/alloc arena 4)
579        mask (ffi/alloc arena 5)               ; XIMaskLen(XI_LASTEVENT)
580        event-mask (ffi/alloc arena 16)]       ; XIEventMask { deviceid; mask_len; mask* }
581    (ffi/write major :int 2)
582    (ffi/write minor :int 0)
583    (xi-query-version x-display major minor)   ; required before XI2 selection
584    (ffi/write mask :uint8 (bit-shift-left 1 (mod xi-raw-button-press 8)) (quot xi-raw-button-press 8))
585    (ffi/write event-mask :int 1 0)            ; XIAllMasterDevices
586    (ffi/write event-mask :int 5 4)
587    (ffi/write event-mask :pointer mask 8)
588    (xi-select-events x-display (x-default-root-window x-display) event-mask 1)
589    (x-flush x-display)))
591(def x-event (ffi/alloc arena 192))           ; sizeof(XEvent)
592(def query-bufs (vec (repeatedly 7 #(ffi/alloc arena 8))))
594(defn pointer-in-window?
595  "Whether the pointer is over a part of our window that is shown."
597  (let [[root child root-x root-y win-x win-y buttons] query-bufs]
598    (x-query-pointer x-display @x-window root child root-x root-y win-x win-y buttons)
599    (let [x (ffi/read win-x :int) y (ffi/read win-y :int)]
600      (some (fn [[rx ry rw rh]] (and (<= rx x) (< x (+ rx rw)) (<= ry y) (< y (+ ry rh))))
601            @shown-rects))))
603(defn dismiss-popups!
604  "Destroy the top-level popups; wlroots takes their child popups with them."
606  (let [roots (doall (for [[popup _] @popups
607                           :when (zero? (xdg-surface-try-from-wlr-surface (ptr popup :wlr_xdg_popup/parent)))]
608                       popup))]
609    (debug "click outside on X11: closing" (count roots) "popup(s)")
610    (doseq [popup roots] (xdg-popup-destroy popup))))
612(defn drain-x-events! []
613  (while (pos? (x-pending x-display))
614    (x-next-event x-display x-event)
615    (when (and xi-opcode
616               (= (ffi/read x-event :int 0) generic-event)    ; cookie.type
617               (= (ffi/read x-event :int 32) xi-opcode)       ; cookie.extension
618               (pos? (x-get-event-data x-display x-event)))
619      (let [evtype (ffi/read x-event :int 36)]                 ; cookie.evtype
620        (x-free-event-data x-display x-event)
621        (when (and (= evtype xi-raw-button-press) (seq @popups) @x-window (not (pointer-in-window?)))
622          (dismiss-popups!))))))
624(def x-fd-ready
625  (ffi/callback arena
626    (fn [_fd _mask _data]
627      (try (drain-x-events!)
628           (catch Throwable e
629             (binding [*out* *err*] (println "wayland-bar-compositor: X event handling failed:" e))))
631    [:int :uint32 :pointer] :int))
633(when xi-opcode
634  (wl-event-loop-add-fd event-loop (x-connection-number x-display) 1 x-fd-ready 0))   ; WL_EVENT_READABLE
636;; --- seat and input ----------------------------------------------------------------
638(def seat (seat-create display "seat0"))
639(def cursor (cursor-create))
640(cursor-attach-output-layout cursor output-layout)
641(def cursor-manager (xcursor-manager-create 0 24))
642(def keyboards (atom #{}))
644(defn surface-at
645  "[surface sx sy] under layout point (lx, ly), or nil."
646
647  (let [node (scene-node-at (field root :wlr_scene_tree/node) lx ly out-a out-b)]
648    (when (and (pos? node) (= (i32 node :wlr_scene_node/type) (off :enum/scene-node-buffer)))
649      (let [scene-surface (scene-surface-try-from-buffer (scene-buffer-from-node node))]
650        (when (pos? scene-surface)
651          [(ptr scene-surface :wlr_scene_surface/surface) (ffi/read out-a :double) (ffi/read out-b :double)])))))
653(defn focus-keyboard! [surface]
654  (when-let [kb (first @keyboards)]
655    (seat-keyboard-notify-enter seat surface (field kb :wlr_keyboard/keycodes)
656                                (ffi/read kb :size_t (off :wlr_keyboard/num_keycodes))
657                                (field kb :wlr_keyboard/modifiers))))
659(defn pointer-motion! [time]
660  (debug "motion" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))
661  (if-let [[surface sx sy] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
662    (do (seat-pointer-notify-enter seat surface sx sy)
663        (seat-pointer-notify-motion seat time sx sy))
664    (do (cursor-set-xcursor cursor cursor-manager "default")
665        (seat-pointer-clear-focus seat))))
667(listen! (field cursor :wlr_cursor/events.motion)
668
669    (cursor-move cursor (field (ptr e :wlr_pointer_motion_event/pointer) :wlr_pointer/base)
670                 (f64 e :wlr_pointer_motion_event/delta_x) (f64 e :wlr_pointer_motion_event/delta_y))
671    (pointer-motion! (u32 e :wlr_pointer_motion_event/time_msec))))
673(listen! (field cursor :wlr_cursor/events.motion_absolute)
674
675    (cursor-warp-absolute cursor (field (ptr e :wlr_pointer_motion_absolute_event/pointer) :wlr_pointer/base)
676                          (f64 e :wlr_pointer_motion_absolute_event/x) (f64 e :wlr_pointer_motion_absolute_event/y))
677    (pointer-motion! (u32 e :wlr_pointer_motion_absolute_event/time_msec))))
679(listen! (field cursor :wlr_cursor/events.button)
680
681    (seat-pointer-notify-button seat (u32 e :wlr_pointer_button_event/time_msec)
682                                (u32 e :wlr_pointer_button_event/button) (i32 e :wlr_pointer_button_event/state))
683    (debug "button" (u32 e :wlr_pointer_button_event/button) "state" (i32 e :wlr_pointer_button_event/state)
684           "at" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y)
685           "surface" (first (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))))
686    (when (= (i32 e :wlr_pointer_button_event/state) (off :enum/button-pressed))
687      (when-let [[surface] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
688        (focus-keyboard! surface)))))
690(listen! (field cursor :wlr_cursor/events.axis)
691
692    (seat-pointer-notify-axis seat (u32 e :wlr_pointer_axis_event/time_msec)
693                              (i32 e :wlr_pointer_axis_event/orientation) (f64 e :wlr_pointer_axis_event/delta)
694                              (i32 e :wlr_pointer_axis_event/delta_discrete) (i32 e :wlr_pointer_axis_event/source)
695                              (i32 e :wlr_pointer_axis_event/relative_direction))))
697(listen! (field cursor :wlr_cursor/events.frame)
698  (fn [_] (seat-pointer-notify-frame seat)))
700(listen! (field seat :wlr_seat/events.request_set_cursor)
701
702    (when (= (ptr e :wlr_seat_pointer_request_set_cursor_event/seat_client)
703             (ptr seat :wlr_seat/pointer_state.focused_client))
704      (cursor-set-surface cursor (ptr e :wlr_seat_pointer_request_set_cursor_event/surface)
705                          (i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_x)
706                          (i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_y)))))
708(listen! (field seat :wlr_seat/events.request_set_selection)
709  (fn [e] (seat-set-selection seat (ptr e :wlr_seat_request_set_selection_event/source)
710                              (u32 e :wlr_seat_request_set_selection_event/serial))))
712(listen! (field seat :wlr_seat/events.request_set_primary_selection)
713  (fn [e] (seat-set-primary-selection seat (ptr e :wlr_seat_request_set_primary_selection_event/source)
714                                      (u32 e :wlr_seat_request_set_primary_selection_event/serial))))
716(defn update-capabilities! []
717  (seat-set-capabilities seat (bit-or (off :enum/seat-capability-pointer)
718                                      (if (seq @keyboards) (off :enum/seat-capability-keyboard) 0))))
720(defn add-keyboard! [device]
721  (let [kb (keyboard-from-input-device device)
722        context (xkb-context-new 0)
723        keymap (xkb-keymap-new-from-names context 0 0)]
724    (keyboard-set-keymap kb keymap)
725    (xkb-keymap-unref keymap)
726    (xkb-context-unref context)
727    (keyboard-set-repeat-info kb 25 600)
728    (let [modifiers (listen! (field kb :wlr_keyboard/events.modifiers)
730                        (seat-set-keyboard seat kb)
731                        (seat-keyboard-notify-modifiers seat (field kb :wlr_keyboard/modifiers))))
732          key (listen! (field kb :wlr_keyboard/events.key)
733                (fn [e]
734                  (seat-set-keyboard seat kb)
735                  (seat-keyboard-notify-key seat (u32 e :wlr_keyboard_key_event/time_msec)
736                                            (u32 e :wlr_keyboard_key_event/keycode)
737                                            (u32 e :wlr_keyboard_key_event/state))))
738          destroy (atom nil)]
739      (reset! destroy
740        (listen! (field device :wlr_input_device/events.destroy)
741          (fn [_]
742            (swap! keyboards disj kb)
743            (unlisten! modifiers key @destroy)
744            (update-capabilities!)))))
745    (seat-set-keyboard seat kb)
746    (swap! keyboards conj kb)))
748(listen! (field backend :wlr_backend/events.new_input)
749  (fn [device]
750    (let [type (i32 device :wlr_input_device/type)]
751      (debug "new input device type" type)
752      (cond
753        (= type (off :enum/input-device-keyboard)) (add-keyboard! device)
754        (= type (off :enum/input-device-pointer)) (cursor-attach-input-device cursor device)))
755    (update-capabilities!)))
757;; --- run -----------------------------------------------------------------------------
759(def socket (wl-display-add-socket-auto display))
760(when-not socket (die "cannot create a wayland socket"))
761(when-not (backend-start backend) (die "backend failed to start"))
762(println "wayland-bar-compositor: WAYLAND_DISPLAY" socket)
764(reset! child (p/process (:command opts) {:extra-env {"WAYLAND_DISPLAY" socket}
765                                          :out :inherit :err :inherit}))
766(.addShutdownHook (Runtime/getRuntime)
767                  (Thread. (fn [] (when @child (p/destroy @child)))))
769(while (p/alive? @child)
770  (wl-event-loop-dispatch event-loop 250)
771  ;; Xlib may have read events into its queue during our own X calls, where
772  ;; the fd never becomes readable again; drain them here too.
773  (drain-x-events!)
774  (wl-display-flush-clients display))
776(println "wayland-bar-compositor:" (first (:command opts)) "exited")
777(wl-display-destroy-clients display)
778(System/exit 0)