#!/usr/bin/env jolt
;; A Wayland compositor for wayland-bar, written in jolt on raw wlroots.
;;
;; It replaces the nested sway: one wlroots X11 output of the requested size,
;; layer-shell and xdg-shell surfaces drawn by the wlroots scene graph, pointer
;; and keyboard forwarded to them. Because it owns the scene, it knows where
;; every popup is, so it shapes its own X11 window (strip + popups) through
;; XShape directly — no screenshots, no polling.
;;
;; usage: wayland-bar-compositor --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]
;;
;; Struct offsets come from offsets.edn, generated from the installed wlroots
;; headers by ./build. Single-threaded: every wlroots callback arrives on this
;; thread from inside wl_event_loop_dispatch.

(require '[jolt.ffi :as ffi]
         '[babashka.fs :as fs]
         '[babashka.process :as p]
         '[clojure.edn :as edn]
         '[clojure.string :as str])

(def here (str (fs/parent (fs/canonicalize *file*))))

(def debug? (some? (System/getenv "WBC_DEBUG")))

(defn debug [& parts]
  (when debug?
    (binding [*out* *err*] (apply println "wbc:" parts))))

(defn die [& msg]
  (binding [*out* *err*] (apply println "wayland-bar-compositor:" msg))
  (System/exit 1))

;; --- arguments ---------------------------------------------------------------

(defn parse-args [args]
  (loop [[a b & more :as args] args opts {}]
    (cond
      (empty? args) opts
      (= a "--") (assoc opts :command (vec (rest args)))
      (= a "--size") (let [[w h] (map parse-long (str/split b #"x"))] (recur more (assoc opts :width w :height h)))
      (= a "--strip") (recur more (assoc opts :strip (mapv parse-long (str/split b #","))))
      (= a "--title") (recur more (assoc opts :title b))
      (str/starts-with? a "--") (die "unknown argument" a)
      ;; jolt may consume a "--" itself, so the first non-option starts the command.
      :else (assoc opts :command (vec args)))))

(def opts (parse-args *command-line-args*))
(let [{:keys [width height strip title command]} opts]
  (when-not (and width height strip title (seq command))
    (die "usage: --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]")))

;; --- layout facts --------------------------------------------------------------

(def layout
  (let [f (str here "/offsets.edn")]
    (when-not (fs/exists? f) (die "missing" f "- run" (str here "/build")))
    (edn/read-string (slurp f))))

(defn off [k]
  (or (get layout k) (die "offsets.edn has no" k)))

;; --- libraries -----------------------------------------------------------------

(ffi/load-library "libc.so.6")
(ffi/load-library "libwayland-server.so.0")
(ffi/load-library "libxkbcommon.so.0")
(ffi/load-library "libwlroots-0.20.so")
(ffi/load-library "libX11.so.6")
(ffi/load-library "libXext.so.6")

(ffi/defcfn clock-gettime "clock_gettime" [:int :pointer] :int)

(ffi/defcfn wl-display-create "wl_display_create" [] :pointer)
(ffi/defcfn wl-display-get-event-loop "wl_display_get_event_loop" [:pointer] :pointer)
(ffi/defcfn wl-display-add-socket-auto "wl_display_add_socket_auto" [:pointer] :string)
(ffi/defcfn wl-display-flush-clients "wl_display_flush_clients" [:pointer] :void)
(ffi/defcfn wl-display-destroy-clients "wl_display_destroy_clients" [:pointer] :void)
(ffi/defcfn wl-event-loop-dispatch "wl_event_loop_dispatch" [:pointer :int] :int)
(ffi/defcfn wl-list-insert "wl_list_insert" [:pointer :pointer] :void)
(ffi/defcfn wl-list-remove "wl_list_remove" [:pointer] :void)

(ffi/defcfn xkb-context-new "xkb_context_new" [:int] :pointer)
(ffi/defcfn xkb-keymap-new-from-names "xkb_keymap_new_from_names" [:pointer :pointer :int] :pointer)
(ffi/defcfn xkb-keymap-unref "xkb_keymap_unref" [:pointer] :void)
(ffi/defcfn xkb-context-unref "xkb_context_unref" [:pointer] :void)

(ffi/defcfn backend-autocreate "wlr_backend_autocreate" [:pointer :pointer] :pointer)
(ffi/defcfn backend-start "wlr_backend_start" [:pointer] :bool)
(ffi/defcfn renderer-autocreate "wlr_renderer_autocreate" [:pointer] :pointer)
(ffi/defcfn renderer-init-wl-display "wlr_renderer_init_wl_display" [:pointer :pointer] :bool)
(ffi/defcfn allocator-autocreate "wlr_allocator_autocreate" [:pointer :pointer] :pointer)

(ffi/defcfn compositor-create "wlr_compositor_create" [:pointer :uint32 :pointer] :pointer)
(ffi/defcfn subcompositor-create "wlr_subcompositor_create" [:pointer] :pointer)
(ffi/defcfn data-device-manager-create "wlr_data_device_manager_create" [:pointer] :pointer)
(ffi/defcfn primary-selection-manager-create "wlr_primary_selection_v1_device_manager_create" [:pointer] :pointer)
(ffi/defcfn data-control-manager-create "wlr_data_control_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn xdg-output-manager-create "wlr_xdg_output_manager_v1_create" [:pointer :pointer] :pointer)
(ffi/defcfn screencopy-manager-create "wlr_screencopy_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn viewporter-create "wlr_viewporter_create" [:pointer] :pointer)
(ffi/defcfn fractional-scale-manager-create "wlr_fractional_scale_manager_v1_create" [:pointer :uint32] :pointer)
(ffi/defcfn single-pixel-buffer-manager-create "wlr_single_pixel_buffer_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn presentation-create "wlr_presentation_create" [:pointer :pointer :uint32] :pointer)
(ffi/defcfn xdg-activation-create "wlr_xdg_activation_v1_create" [:pointer] :pointer)

(ffi/defcfn output-layout-create "wlr_output_layout_create" [:pointer] :pointer)
(ffi/defcfn output-layout-add-auto "wlr_output_layout_add_auto" [:pointer :pointer] :pointer)
(ffi/defcfn output-init-render "wlr_output_init_render" [:pointer :pointer :pointer] :bool)
(ffi/defcfn output-state-init "wlr_output_state_init" [:pointer] :void)
(ffi/defcfn output-state-finish "wlr_output_state_finish" [:pointer] :void)
(ffi/defcfn output-state-set-enabled "wlr_output_state_set_enabled" [:pointer :bool] :void)
(ffi/defcfn output-state-set-custom-mode "wlr_output_state_set_custom_mode" [:pointer :int32 :int32 :int32] :void)
(ffi/defcfn output-commit-state "wlr_output_commit_state" [:pointer :pointer] :bool)
(ffi/defcfn x11-output-set-title "wlr_x11_output_set_title" [:pointer :string] :void)
(ffi/defcfn output-is-x11 "wlr_output_is_x11" [:pointer] :bool)

(ffi/defcfn scene-create "wlr_scene_create" [] :pointer)
(ffi/defcfn scene-attach-output-layout "wlr_scene_attach_output_layout" [:pointer :pointer] :pointer)
(ffi/defcfn scene-output-create "wlr_scene_output_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-output-layout-add-output "wlr_scene_output_layout_add_output" [:pointer :pointer :pointer] :void)
(ffi/defcfn scene-output-needs-frame "wlr_scene_output_needs_frame" [:pointer] :bool)
(ffi/defcfn scene-output-build-state "wlr_scene_output_build_state" [:pointer :pointer :pointer] :bool)
(ffi/defcfn buffer-begin-data-ptr-access "wlr_buffer_begin_data_ptr_access" [:pointer :uint32 :pointer :pointer :pointer] :bool)
(ffi/defcfn buffer-end-data-ptr-access "wlr_buffer_end_data_ptr_access" [:pointer] :void)
(ffi/defcfn scene-output-send-frame-done "wlr_scene_output_send_frame_done" [:pointer :pointer] :void)
(ffi/defcfn scene-tree-create "wlr_scene_tree_create" [:pointer] :pointer)
(ffi/defcfn scene-node-at "wlr_scene_node_at" [:pointer :double :double :pointer :pointer] :pointer)
(ffi/defcfn scene-node-coords "wlr_scene_node_coords" [:pointer :pointer :pointer] :bool)
(ffi/defcfn scene-buffer-from-node "wlr_scene_buffer_from_node" [:pointer] :pointer)
(ffi/defcfn scene-surface-try-from-buffer "wlr_scene_surface_try_from_buffer" [:pointer] :pointer)
(ffi/defcfn scene-xdg-surface-create "wlr_scene_xdg_surface_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-layer-surface-create "wlr_scene_layer_surface_v1_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-layer-surface-configure "wlr_scene_layer_surface_v1_configure" [:pointer :pointer :pointer] :void)

(ffi/defcfn xdg-shell-create "wlr_xdg_shell_create" [:pointer :uint32] :pointer)
(ffi/defcfn xdg-surface-try-from-wlr-surface "wlr_xdg_surface_try_from_wlr_surface" [:pointer] :pointer)
(ffi/defcfn xdg-surface-schedule-configure "wlr_xdg_surface_schedule_configure" [:pointer] :uint32)
(ffi/defcfn xdg-toplevel-set-size "wlr_xdg_toplevel_set_size" [:pointer :int32 :int32] :uint32)
(ffi/defcfn xdg-popup-unconstrain-from-box "wlr_xdg_popup_unconstrain_from_box" [:pointer :pointer] :void)
(ffi/defcfn layer-shell-create "wlr_layer_shell_v1_create" [:pointer :uint32] :pointer)
(ffi/defcfn layer-surface-try-from-wlr-surface "wlr_layer_surface_v1_try_from_wlr_surface" [:pointer] :pointer)

(ffi/defcfn cursor-create "wlr_cursor_create" [] :pointer)
(ffi/defcfn cursor-attach-output-layout "wlr_cursor_attach_output_layout" [:pointer :pointer] :void)
(ffi/defcfn cursor-attach-input-device "wlr_cursor_attach_input_device" [:pointer :pointer] :void)
(ffi/defcfn cursor-move "wlr_cursor_move" [:pointer :pointer :double :double] :void)
(ffi/defcfn cursor-warp-absolute "wlr_cursor_warp_absolute" [:pointer :pointer :double :double] :void)
(ffi/defcfn cursor-set-xcursor "wlr_cursor_set_xcursor" [:pointer :pointer :string] :void)
(ffi/defcfn cursor-set-surface "wlr_cursor_set_surface" [:pointer :pointer :int32 :int32] :void)
(ffi/defcfn xcursor-manager-create "wlr_xcursor_manager_create" [:pointer :uint32] :pointer)

(ffi/defcfn seat-create "wlr_seat_create" [:pointer :string] :pointer)
(ffi/defcfn seat-set-capabilities "wlr_seat_set_capabilities" [:pointer :uint32] :void)
(ffi/defcfn seat-set-keyboard "wlr_seat_set_keyboard" [:pointer :pointer] :void)
(ffi/defcfn seat-set-selection "wlr_seat_set_selection" [:pointer :pointer :uint32] :void)
(ffi/defcfn seat-set-primary-selection "wlr_seat_set_primary_selection" [:pointer :pointer :uint32] :void)
(ffi/defcfn seat-pointer-notify-enter "wlr_seat_pointer_notify_enter" [:pointer :pointer :double :double] :void)
(ffi/defcfn seat-pointer-notify-motion "wlr_seat_pointer_notify_motion" [:pointer :uint32 :double :double] :void)
(ffi/defcfn seat-pointer-notify-button "wlr_seat_pointer_notify_button" [:pointer :uint32 :uint32 :int] :uint32)
(ffi/defcfn seat-pointer-notify-axis "wlr_seat_pointer_notify_axis" [:pointer :uint32 :int :double :int32 :int :int] :void)
(ffi/defcfn seat-pointer-notify-frame "wlr_seat_pointer_notify_frame" [:pointer] :void)
(ffi/defcfn seat-pointer-clear-focus "wlr_seat_pointer_clear_focus" [:pointer] :void)
(ffi/defcfn seat-keyboard-notify-enter "wlr_seat_keyboard_notify_enter" [:pointer :pointer :pointer :size_t :pointer] :void)
(ffi/defcfn seat-keyboard-notify-key "wlr_seat_keyboard_notify_key" [:pointer :uint32 :uint32 :uint32] :void)
(ffi/defcfn seat-keyboard-notify-modifiers "wlr_seat_keyboard_notify_modifiers" [:pointer :pointer] :void)
(ffi/defcfn keyboard-from-input-device "wlr_keyboard_from_input_device" [:pointer] :pointer)
(ffi/defcfn keyboard-set-keymap "wlr_keyboard_set_keymap" [:pointer :pointer] :bool)
(ffi/defcfn keyboard-set-repeat-info "wlr_keyboard_set_repeat_info" [:pointer :int32 :int32] :void)

(ffi/load-library "libXi.so.6")
(ffi/defcfn wl-event-loop-add-fd "wl_event_loop_add_fd" [:pointer :int :uint32 :pointer :pointer] :pointer)
(ffi/defcfn xdg-popup-destroy "wlr_xdg_popup_destroy" [:pointer] :void)
(ffi/defcfn x-query-extension "XQueryExtension" [:pointer :string :pointer :pointer :pointer] :int)
(ffi/defcfn xi-query-version "XIQueryVersion" [:pointer :pointer :pointer] :int)
(ffi/defcfn xi-select-events "XISelectEvents" [:pointer :long :pointer :int] :int)
(ffi/defcfn x-pending "XPending" [:pointer] :int)
(ffi/defcfn x-next-event "XNextEvent" [:pointer :pointer] :int)
(ffi/defcfn x-get-event-data "XGetEventData" [:pointer :pointer] :int)
(ffi/defcfn x-free-event-data "XFreeEventData" [:pointer :pointer] :void)
(ffi/defcfn x-query-pointer "XQueryPointer"
  [:pointer :long :pointer :pointer :pointer :pointer :pointer :pointer :pointer] :int)
(ffi/defcfn x-default-root-window "XDefaultRootWindow" [:pointer] :long)
(ffi/defcfn x-connection-number "XConnectionNumber" [:pointer] :int)
(ffi/defcfn x-open-display "XOpenDisplay" [:pointer] :pointer)
(ffi/defcfn x-flush "XFlush" [:pointer] :int)
(ffi/defcfn x-shape-combine-rectangles "XShapeCombineRectangles"
  [:pointer :long :int :int :int :pointer :int :int :int] :void)

;; --- memory helpers ---------------------------------------------------------------

(def arena (ffi/global-arena))
(defn ptr [p k] (ffi/read p :pointer (off k)))
(defn i32 [p k] (ffi/read p :int (off k)))
(defn u32 [p k] (ffi/read p :uint32 (off k)))
(defn f64 [p k] (ffi/read p :double (off k)))
(defn flag [p k] (not (zero? (ffi/read p :uint8 (off k)))))
(defn field [p k] (+ p (off k)))

;; Scratch buffers reused by every callback; this compositor is single-threaded.
(def out-a (ffi/alloc arena 8))
(def out-b (ffi/alloc arena 8))
(def box-buf (ffi/alloc arena (off :wlr_box/sizeof)))
(def usable-buf (ffi/alloc arena (off :wlr_box/sizeof)))
(def timespec (ffi/alloc arena (off :timespec/sizeof)))

(defn write-box! [buf x y w h]
  (ffi/write buf :int x (off :wlr_box/x))
  (ffi/write buf :int y (off :wlr_box/y))
  (ffi/write buf :int w (off :wlr_box/width))
  (ffi/write buf :int h (off :wlr_box/height))
  buf)

;; --- signals ----------------------------------------------------------------------
;; wl_signal_add is a static inline in C. Every listener here shares ONE native
;; callback, which looks the listener's address up in `handlers`; listeners come
;; from a free list, so surfaces that come and go don't leak callbacks.

(def handlers (atom {}))
(def free-listeners (atom ()))

(defn- dispatch [listener data]
  (when-let [f (get @handlers listener)]
    (try (f data)
         (catch Throwable e
           (binding [*out* *err*] (println "wayland-bar-compositor: handler failed:" e))))))

(def notify (ffi/callback arena dispatch [:pointer :pointer] :void))

(defn listen!
  "Hook f onto the wl_signal at address `signal`. Answers the listener."
  [signal f]
  (let [listener (or (let [[l] @free-listeners] (when l (swap! free-listeners rest) l))
                     (ffi/alloc arena (off :wl_listener/sizeof)))]
    (ffi/write listener :pointer notify (off :wl_listener/notify))
    (swap! handlers assoc listener f)
    ;; wl_list_insert(signal->listener_list.prev, &listener->link)
    (wl-list-insert (ffi/read signal :pointer 0) (field listener :wl_listener/link))
    listener))

(defn unlisten! [& listeners]
  (doseq [l listeners]
    (wl-list-remove (field l :wl_listener/link))
    (swap! handlers dissoc l)
    (swap! free-listeners conj l)))

;; --- the server -----------------------------------------------------------------

(def width (:width opts))
(def height (:height opts))
(def display (wl-display-create))
(def event-loop (wl-display-get-event-loop display))
(def backend (backend-autocreate event-loop 0))
(when (zero? backend) (die "no wlroots backend; is DISPLAY set and WLR_BACKENDS=x11?"))
(def renderer (renderer-autocreate backend))
(when (zero? renderer) (die "no renderer"))
(renderer-init-wl-display renderer display)
(def allocator (allocator-autocreate backend renderer))
(when (zero? allocator) (die "no allocator"))

(compositor-create display 5 renderer)
(subcompositor-create display)
(data-device-manager-create display)
(primary-selection-manager-create display)
(data-control-manager-create display)
(viewporter-create display)
(fractional-scale-manager-create display 1)
(single-pixel-buffer-manager-create display)
(screencopy-manager-create display)
(xdg-activation-create display)
(presentation-create display backend 2)

(def output-layout (output-layout-create display))
(xdg-output-manager-create display output-layout)
(def scene (scene-create))
(def scene-layout (scene-attach-output-layout scene output-layout))
(def root (field scene :wlr_scene/tree))

;; Layer-shell layers, bottom to top; popups float above everything.
(def layer-trees (vec (repeatedly 4 #(scene-tree-create root))))
(def toplevel-tree (scene-tree-create root))
(def popup-tree (scene-tree-create root))

(def output (atom nil))           ; the one wlr_output
(def layer-surfaces (atom {}))    ; wlr_layer_surface_v1 -> scene layer surface
(def popups (atom {}))            ; wlr_xdg_popup -> scene tree

;; --- X11 window shape --------------------------------------------------------------

(def x-display (x-open-display 0))
(when (zero? x-display) (die "cannot open the X display"))
(def x-window (atom nil))
(def shown-rects (atom nil))
(def max-rects 1024)
(def rect-buf (ffi/alloc arena (* 8 max-rects)))  ; XRectangle { short x, y; ushort w, h }

(defn find-x-window
  "wlroots owns the X11 window; we gave it a unique title, so look it up."
  []
  (let [out (:out (p/sh "xwininfo" "-name" (:title opts)))]
    (some->> (re-find #"Window id: (0x[0-9a-f]+)" out) second (#(Long/parseLong (subs % 2) 16)))))

(defn popup-rects
  "Layout-space boxes of every mapped popup: its geometry, without shadows."
  []
  (for [[popup tree] @popups
        :let [base (ptr popup :wlr_xdg_popup/base)
              surface (ptr base :wlr_xdg_surface/surface)]
        :when (flag surface :wlr_surface/mapped)
        :let [_ (scene-node-coords (field tree :wlr_scene_tree/node) out-a out-b)
              geo (field base :wlr_xdg_surface/geometry)
              w (i32 geo :wlr_box/width)
              h (i32 geo :wlr_box/height)]
        :when (and (pos? w) (pos? h))]
    [(ffi/read out-a :int) (ffi/read out-b :int) w h]))

;; Popups have rounded corners; their geometry box would show the black output
;; behind the corners. So read the frame about to be shown and trace each
;; corner row inward to the first painted pixel. Pixman frames are plain
;; memory, and only corner rows are scanned, only when the popups change.

(def data-out (ffi/alloc arena 8))
(def format-out (ffi/alloc arena 4))
(def stride-out (ffi/alloc arena 8))
(def rgb32-formats #{0x34325258 0x34325241 0x34324258 0x34324241})   ; XRGB/ARGB/XBGR/ABGR8888

;; Transparent margins and faint shadows composite onto the black output as
;; black or near-black; a popup's own background is well above this.
(def paint-threshold 10)

(defn- painted? [px]
  (or (> (bit-and (bit-shift-right px 16) 0xff) paint-threshold)
      (> (bit-and (bit-shift-right px 8) 0xff) paint-threshold)
      (> (bit-and px 0xff) paint-threshold)))

(defn- row-span
  "[left right) of the painted part of row y within [x, x+w); nil if none.
  The row is copied out in one call rather than read pixel by pixel."
  [data stride x y w]
  (let [row (ffi/read-array (+ data (* y stride)) :uint32 w (* 4 x))
        left (loop [i 0] (cond (= i w) nil (painted? (aget row i)) i :else (recur (inc i))))]
    (when left
      (let [right (loop [i (dec w)] (if (painted? (aget row i)) (inc i) (recur (dec i))))]
        [(+ x left) (+ x right)]))))

(defn outline-rects
  "XShape rects for popup box [x y w h], following what the popup actually
  painted: rounded corners, and any transparent margin its geometry includes.
  Consecutive rows with the same span merge into one rect."
  [data stride [x y w h]]
  (let [rows (for [row (range y (+ y h))
                   :let [[l r] (row-span data stride x row w)]
                   :when l]
               [l row (- r l) 1])]
    (->> rows
         (reduce (fn [acc [rx ry rw rh :as rect]]
                   (let [[px py pw ph] (peek acc)]
                     (if (and px (= px rx) (= pw rw) (= (+ py ph) ry))
                       (conj (pop acc) [px py pw (+ ph rh)])
                       (conj acc rect))))
                 []))))

(defn- frame-outlines
  "Outline rects for every popup box, read from `buffer`; nil if unreadable."
  [buffer boxes]
  (when (and (pos? buffer)
             (buffer-begin-data-ptr-access buffer (off :enum/buffer-data-ptr-access-read)
                                           data-out format-out stride-out))
    (try
      (when (rgb32-formats (ffi/read format-out :uint32))
        (let [data (ffi/read data-out :pointer)
              stride (ffi/read stride-out :size_t)]
          (vec (mapcat (fn [[x y w h]]
                         ;; clamp to the output so a scan never leaves the buffer
                         (let [x (max 0 x) y (max 0 y)
                               w (min w (- width x)) h (min h (- height y))]
                           (when (and (pos? w) (pos? h))
                             (outline-rects data stride [x y w h]))))
                       boxes))))
      (finally (buffer-end-data-ptr-access buffer)))))

(def shown-boxes (atom nil))
(def popups-dirty (atom false))   ; a popup committed since its outline was traced

(defn update-shape!
  "Shape the window to the strip plus the popups' outlines. `buffer` is the
  frame about to be shown, or nil when nothing was rendered."
  [buffer]
  (when-not @x-window
    (reset! x-window (find-x-window)))
  (when-let [win @x-window]
    (let [boxes (vec (popup-rects))
          retrace? (and (seq boxes) (or (not= boxes @shown-boxes) (and buffer @popups-dirty)))
          outlines (when retrace?
                     ;; tracing needs a rendered frame; without one, wait for it
                     (when buffer
                       (reset! popups-dirty false)
                       (or (frame-outlines buffer boxes) boxes)))
          rects (cond
                  (empty? boxes) [(:strip opts)]
                  outlines (vec (take max-rects (cons (:strip opts) outlines)))
                  :else nil)]
      (when (and rects (not= rects @shown-rects))
        (reset! shown-boxes boxes)
        (debug "shape" (count rects) "rects" (take 4 rects))
        (doseq [[i [x y w h]] (map-indexed vector rects)]
          (ffi/write rect-buf :short (short x) (* 8 i))
          (ffi/write rect-buf :short (short y) (+ 2 (* 8 i)))
          (ffi/write rect-buf :short (unchecked-short w) (+ 4 (* 8 i)))
          (ffi/write rect-buf :short (unchecked-short h) (+ 6 (* 8 i))))
        ;; ShapeBounding = 0, ShapeInput = 2; ShapeSet = 0; Unsorted = 0
        (x-shape-combine-rectangles x-display win 0 0 0 rect-buf (count rects) 0 0)
        (x-shape-combine-rectangles x-display win 2 0 0 rect-buf (count rects) 0 0)
        (x-flush x-display)
        (reset! shown-rects rects)))))

;; --- outputs ------------------------------------------------------------------------

(defn with-output-state [f]
  (let [state (ffi/alloc arena (off :wlr_output_state/sizeof))]
    (output-state-init state)
    (try (f state) (finally (output-state-finish state)))))

(def child (atom nil))
(def frame-state (ffi/alloc arena (off :wlr_output_state/sizeof)))   ; reused every frame

(defn arrange-layers! []
  (write-box! box-buf 0 0 width height)
  (write-box! usable-buf 0 0 width height)
  (doseq [[_ scene-ls] @layer-surfaces]
    (scene-layer-surface-configure scene-ls box-buf usable-buf)))

(listen! (field backend :wlr_backend/events.new_output)
  (fn [wlr-output]
    (if @output
      (println "wayland-bar-compositor: ignoring extra output")
      (do
        (reset! output wlr-output)
        (output-init-render wlr-output allocator renderer)
        (with-output-state
          (fn [state]
            (output-state-set-enabled state true)
            (output-state-set-custom-mode state width height 0)
            (output-commit-state wlr-output state)))
        (when (output-is-x11 wlr-output)
          (x11-output-set-title wlr-output (:title opts)))
        (let [scene-output (scene-output-create scene wlr-output)]
          (scene-output-layout-add-output scene-layout (output-layout-add-auto output-layout wlr-output) scene-output)
          (listen! (field wlr-output :wlr_output/events.frame)
            (fn [_]
              ;; wlr_scene_output_commit, split open so the frame can be read
              ;; for popup outlines between rendering and showing it.
              (if (scene-output-needs-frame scene-output)
                (do
                  (output-state-init frame-state)
                  (try
                    (when (scene-output-build-state scene-output frame-state 0)
                      (update-shape! (when (pos? (bit-and (u32 frame-state :wlr_output_state/committed)
                                                          (off :enum/output-state-buffer)))
                                       (ptr frame-state :wlr_output_state/buffer)))
                      (output-commit-state wlr-output frame-state))
                    (finally (output-state-finish frame-state))))
                (update-shape! nil))
              (clock-gettime 1 timespec)           ; CLOCK_MONOTONIC
              (scene-output-send-frame-done scene-output timespec)))
          (listen! (field wlr-output :wlr_output/events.request_state)
            (fn [event]
              (output-commit-state wlr-output (ptr event :wlr_output_event_request_state/state)))))))))

;; --- layer shell -----------------------------------------------------------------

(def layer-shell (layer-shell-create display 4))
(declare add-popup!)

(listen! (field layer-shell :wlr_layer_shell_v1/events.new_surface)
  (fn [ls]
    (when (zero? (ptr ls :wlr_layer_surface_v1/output))
      (ffi/write ls :pointer (or @output 0) (off :wlr_layer_surface_v1/output)))
    (let [layer (min 3 (max 0 (i32 ls :wlr_layer_surface_v1/current.layer)))
          scene-ls (scene-layer-surface-create (nth layer-trees layer) ls)
          surface (ptr ls :wlr_layer_surface_v1/surface)]
      ;; popups find their parent's scene tree through data
      (ffi/write ls :pointer (ptr scene-ls :wlr_scene_layer_surface_v1/tree) (off :wlr_layer_surface_v1/data))
      (swap! layer-surfaces assoc ls scene-ls)
      (let [commit (listen! (field surface :wlr_surface/events.commit)
                     (fn [_] (when (flag ls :wlr_layer_surface_v1/initialized) (arrange-layers!))))
            ;; xdg-shell announces a layer surface's popup before it has a
            ;; parent; this signal comes once the parent is set.
            new-popup (listen! (field ls :wlr_layer_surface_v1/events.new_popup) add-popup!)
            destroy (atom nil)]
        (reset! destroy
          (listen! (field ls :wlr_layer_surface_v1/events.destroy)
            (fn [_]
              (swap! layer-surfaces dissoc ls)
              (unlisten! commit new-popup @destroy))))))))

;; --- xdg shell -------------------------------------------------------------------

(def xdg-shell (xdg-shell-create display 6))

(listen! (field xdg-shell :wlr_xdg_shell/events.new_toplevel)
  (fn [toplevel]
    (let [base (ptr toplevel :wlr_xdg_toplevel/base)
          tree (scene-xdg-surface-create toplevel-tree base)
          surface (ptr base :wlr_xdg_surface/surface)]
      (ffi/write base :pointer tree (off :wlr_xdg_surface/data))
      (let [commit (listen! (field surface :wlr_surface/events.commit)
                     (fn [_] (when (flag base :wlr_xdg_surface/initial_commit)
                               (xdg-toplevel-set-size toplevel 0 0))))
            destroy (atom nil)]
        (reset! destroy
          (listen! (field toplevel :wlr_xdg_toplevel/events.destroy)
            (fn [_] (unlisten! commit @destroy))))))))

(defn parent-tree
  "The scene tree a popup's parent surface draws into: an xdg surface's or a
  layer surface's, both kept in their data field."
  [parent-surface]
  (let [xdg (xdg-surface-try-from-wlr-surface parent-surface)]
    (if (pos? xdg)
      (ptr xdg :wlr_xdg_surface/data)
      (let [ls (layer-surface-try-from-wlr-surface parent-surface)]
        (when (pos? ls) (ptr ls :wlr_layer_surface_v1/data))))))

(defn add-popup!
  "Put a popup whose parent is set into the scene, under its parent's tree."
  [popup]
  (let [base (ptr popup :wlr_xdg_popup/base)
        surface (ptr base :wlr_xdg_surface/surface)
        parent (parent-tree (ptr popup :wlr_xdg_popup/parent))]
    (debug "add popup" popup "parent tree" parent)
    (if-not parent
      (println "wayland-bar-compositor: popup with no known parent")
      (let [tree (scene-xdg-surface-create parent base)]
          (ffi/write base :pointer tree (off :wlr_xdg_surface/data))
          (swap! popups assoc popup tree)
          (let [commit (listen! (field surface :wlr_surface/events.commit)
                         (fn [_]
                           ;; new content may change the outline (a client's
                           ;; first buffer is often blank), so retrace it
                           (reset! popups-dirty true)
                           (when (flag base :wlr_xdg_surface/initial_commit)
                             ;; keep the popup inside the output, in parent-relative space
                             (scene-node-coords (field parent :wlr_scene_tree/node) out-a out-b)
                             (xdg-popup-unconstrain-from-box
                               popup (write-box! box-buf (- (ffi/read out-a :int)) (- (ffi/read out-b :int)) width height))
                             (xdg-surface-schedule-configure base))))
                destroy (atom nil)]
            (reset! destroy
              (listen! (field popup :wlr_xdg_popup/events.destroy)
                (fn [_]
                  (swap! popups dissoc popup)
                  (unlisten! commit @destroy)))))))))

;; A layer surface's popup arrives here with no parent yet and again, parented,
;; on the layer surface's own new_popup; only take the parented ones here.
(listen! (field xdg-shell :wlr_xdg_shell/events.new_popup)
  (fn [popup]
    (when (pos? (ptr popup :wlr_xdg_popup/parent))
      (add-popup! popup))))

;; --- clicks on X11 apps close popups --------------------------------------------
;; A click on an X11 window never reaches Wayland, so popups' own grabs can't
;; see it. XInput2 raw button presses on the root window report every click
;; without grabbing anything; if the pointer is outside what our window shows,
;; close the open popups. Layouts below checked against the X11/XI2 headers.

(def generic-event 35)
(def xi-raw-button-press 15)

(def xi-opcode
  (let [opcode (ffi/alloc arena 4) event (ffi/alloc arena 4) error (ffi/alloc arena 4)]
    (when (pos? (x-query-extension x-display "XInputExtension" opcode event error))
      (ffi/read opcode :int))))

(if-not xi-opcode
  (println "wayland-bar-compositor: no XInput2; clicks on X11 apps won't close popups")
  (let [major (ffi/alloc arena 4) minor (ffi/alloc arena 4)
        mask (ffi/alloc arena 5)               ; XIMaskLen(XI_LASTEVENT)
        event-mask (ffi/alloc arena 16)]       ; XIEventMask { deviceid; mask_len; mask* }
    (ffi/write major :int 2)
    (ffi/write minor :int 0)
    (xi-query-version x-display major minor)   ; required before XI2 selection
    (ffi/write mask :uint8 (bit-shift-left 1 (mod xi-raw-button-press 8)) (quot xi-raw-button-press 8))
    (ffi/write event-mask :int 1 0)            ; XIAllMasterDevices
    (ffi/write event-mask :int 5 4)
    (ffi/write event-mask :pointer mask 8)
    (xi-select-events x-display (x-default-root-window x-display) event-mask 1)
    (x-flush x-display)))

(def x-event (ffi/alloc arena 192))           ; sizeof(XEvent)
(def query-bufs (vec (repeatedly 7 #(ffi/alloc arena 8))))

(defn pointer-in-window?
  "Whether the pointer is over a part of our window that is shown."
  []
  (let [[root child root-x root-y win-x win-y buttons] query-bufs]
    (x-query-pointer x-display @x-window root child root-x root-y win-x win-y buttons)
    (let [x (ffi/read win-x :int) y (ffi/read win-y :int)]
      (some (fn [[rx ry rw rh]] (and (<= rx x) (< x (+ rx rw)) (<= ry y) (< y (+ ry rh))))
            @shown-rects))))

(defn dismiss-popups!
  "Destroy the top-level popups; wlroots takes their child popups with them."
  []
  (let [roots (doall (for [[popup _] @popups
                           :when (zero? (xdg-surface-try-from-wlr-surface (ptr popup :wlr_xdg_popup/parent)))]
                       popup))]
    (debug "click outside on X11: closing" (count roots) "popup(s)")
    (doseq [popup roots] (xdg-popup-destroy popup))))

(defn drain-x-events! []
  (while (pos? (x-pending x-display))
    (x-next-event x-display x-event)
    (when (and xi-opcode
               (= (ffi/read x-event :int 0) generic-event)    ; cookie.type
               (= (ffi/read x-event :int 32) xi-opcode)       ; cookie.extension
               (pos? (x-get-event-data x-display x-event)))
      (let [evtype (ffi/read x-event :int 36)]                 ; cookie.evtype
        (x-free-event-data x-display x-event)
        (when (and (= evtype xi-raw-button-press) (seq @popups) @x-window (not (pointer-in-window?)))
          (dismiss-popups!))))))

(def x-fd-ready
  (ffi/callback arena
    (fn [_fd _mask _data]
      (try (drain-x-events!)
           (catch Throwable e
             (binding [*out* *err*] (println "wayland-bar-compositor: X event handling failed:" e))))
      0)
    [:int :uint32 :pointer] :int))

(when xi-opcode
  (wl-event-loop-add-fd event-loop (x-connection-number x-display) 1 x-fd-ready 0))   ; WL_EVENT_READABLE

;; --- seat and input ----------------------------------------------------------------

(def seat (seat-create display "seat0"))
(def cursor (cursor-create))
(cursor-attach-output-layout cursor output-layout)
(def cursor-manager (xcursor-manager-create 0 24))
(def keyboards (atom #{}))

(defn surface-at
  "[surface sx sy] under layout point (lx, ly), or nil."
  [lx ly]
  (let [node (scene-node-at (field root :wlr_scene_tree/node) lx ly out-a out-b)]
    (when (and (pos? node) (= (i32 node :wlr_scene_node/type) (off :enum/scene-node-buffer)))
      (let [scene-surface (scene-surface-try-from-buffer (scene-buffer-from-node node))]
        (when (pos? scene-surface)
          [(ptr scene-surface :wlr_scene_surface/surface) (ffi/read out-a :double) (ffi/read out-b :double)])))))

(defn focus-keyboard! [surface]
  (when-let [kb (first @keyboards)]
    (seat-keyboard-notify-enter seat surface (field kb :wlr_keyboard/keycodes)
                                (ffi/read kb :size_t (off :wlr_keyboard/num_keycodes))
                                (field kb :wlr_keyboard/modifiers))))

(defn pointer-motion! [time]
  (debug "motion" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))
  (if-let [[surface sx sy] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
    (do (seat-pointer-notify-enter seat surface sx sy)
        (seat-pointer-notify-motion seat time sx sy))
    (do (cursor-set-xcursor cursor cursor-manager "default")
        (seat-pointer-clear-focus seat))))

(listen! (field cursor :wlr_cursor/events.motion)
  (fn [e]
    (cursor-move cursor (field (ptr e :wlr_pointer_motion_event/pointer) :wlr_pointer/base)
                 (f64 e :wlr_pointer_motion_event/delta_x) (f64 e :wlr_pointer_motion_event/delta_y))
    (pointer-motion! (u32 e :wlr_pointer_motion_event/time_msec))))

(listen! (field cursor :wlr_cursor/events.motion_absolute)
  (fn [e]
    (cursor-warp-absolute cursor (field (ptr e :wlr_pointer_motion_absolute_event/pointer) :wlr_pointer/base)
                          (f64 e :wlr_pointer_motion_absolute_event/x) (f64 e :wlr_pointer_motion_absolute_event/y))
    (pointer-motion! (u32 e :wlr_pointer_motion_absolute_event/time_msec))))

(listen! (field cursor :wlr_cursor/events.button)
  (fn [e]
    (seat-pointer-notify-button seat (u32 e :wlr_pointer_button_event/time_msec)
                                (u32 e :wlr_pointer_button_event/button) (i32 e :wlr_pointer_button_event/state))
    (debug "button" (u32 e :wlr_pointer_button_event/button) "state" (i32 e :wlr_pointer_button_event/state)
           "at" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y)
           "surface" (first (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))))
    (when (= (i32 e :wlr_pointer_button_event/state) (off :enum/button-pressed))
      (when-let [[surface] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
        (focus-keyboard! surface)))))

(listen! (field cursor :wlr_cursor/events.axis)
  (fn [e]
    (seat-pointer-notify-axis seat (u32 e :wlr_pointer_axis_event/time_msec)
                              (i32 e :wlr_pointer_axis_event/orientation) (f64 e :wlr_pointer_axis_event/delta)
                              (i32 e :wlr_pointer_axis_event/delta_discrete) (i32 e :wlr_pointer_axis_event/source)
                              (i32 e :wlr_pointer_axis_event/relative_direction))))

(listen! (field cursor :wlr_cursor/events.frame)
  (fn [_] (seat-pointer-notify-frame seat)))

(listen! (field seat :wlr_seat/events.request_set_cursor)
  (fn [e]
    (when (= (ptr e :wlr_seat_pointer_request_set_cursor_event/seat_client)
             (ptr seat :wlr_seat/pointer_state.focused_client))
      (cursor-set-surface cursor (ptr e :wlr_seat_pointer_request_set_cursor_event/surface)
                          (i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_x)
                          (i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_y)))))

(listen! (field seat :wlr_seat/events.request_set_selection)
  (fn [e] (seat-set-selection seat (ptr e :wlr_seat_request_set_selection_event/source)
                              (u32 e :wlr_seat_request_set_selection_event/serial))))

(listen! (field seat :wlr_seat/events.request_set_primary_selection)
  (fn [e] (seat-set-primary-selection seat (ptr e :wlr_seat_request_set_primary_selection_event/source)
                                      (u32 e :wlr_seat_request_set_primary_selection_event/serial))))

(defn update-capabilities! []
  (seat-set-capabilities seat (bit-or (off :enum/seat-capability-pointer)
                                      (if (seq @keyboards) (off :enum/seat-capability-keyboard) 0))))

(defn add-keyboard! [device]
  (let [kb (keyboard-from-input-device device)
        context (xkb-context-new 0)
        keymap (xkb-keymap-new-from-names context 0 0)]
    (keyboard-set-keymap kb keymap)
    (xkb-keymap-unref keymap)
    (xkb-context-unref context)
    (keyboard-set-repeat-info kb 25 600)
    (let [modifiers (listen! (field kb :wlr_keyboard/events.modifiers)
                      (fn [_]
                        (seat-set-keyboard seat kb)
                        (seat-keyboard-notify-modifiers seat (field kb :wlr_keyboard/modifiers))))
          key (listen! (field kb :wlr_keyboard/events.key)
                (fn [e]
                  (seat-set-keyboard seat kb)
                  (seat-keyboard-notify-key seat (u32 e :wlr_keyboard_key_event/time_msec)
                                            (u32 e :wlr_keyboard_key_event/keycode)
                                            (u32 e :wlr_keyboard_key_event/state))))
          destroy (atom nil)]
      (reset! destroy
        (listen! (field device :wlr_input_device/events.destroy)
          (fn [_]
            (swap! keyboards disj kb)
            (unlisten! modifiers key @destroy)
            (update-capabilities!)))))
    (seat-set-keyboard seat kb)
    (swap! keyboards conj kb)))

(listen! (field backend :wlr_backend/events.new_input)
  (fn [device]
    (let [type (i32 device :wlr_input_device/type)]
      (debug "new input device type" type)
      (cond
        (= type (off :enum/input-device-keyboard)) (add-keyboard! device)
        (= type (off :enum/input-device-pointer)) (cursor-attach-input-device cursor device)))
    (update-capabilities!)))

;; --- run -----------------------------------------------------------------------------

(def socket (wl-display-add-socket-auto display))
(when-not socket (die "cannot create a wayland socket"))
(when-not (backend-start backend) (die "backend failed to start"))
(println "wayland-bar-compositor: WAYLAND_DISPLAY" socket)

(reset! child (p/process (:command opts) {:extra-env {"WAYLAND_DISPLAY" socket}
                                          :out :inherit :err :inherit}))
(.addShutdownHook (Runtime/getRuntime)
                  (Thread. (fn [] (when @child (p/destroy @child)))))

(while (p/alive? @child)
  (wl-event-loop-dispatch event-loop 250)
  ;; Xlib may have read events into its queue during our own X calls, where
  ;; the fd never becomes readable again; drain them here too.
  (drain-x-events!)
  (wl-display-flush-clients display))

(println "wayland-bar-compositor:" (first (:command opts)) "exited")
(wl-display-destroy-clients display)
(System/exit 0)
