lime/test/x11.lisp

(in-package #:lime.x11.test)

(def-suite lime-x11-suite
  :description "Adapter-local geometry and placement policy tests.")

(in-suite lime-x11-suite)

(defparameter *configured-command-runs* 0)

(define-condition broken-diagnostic-printer (error) ()
  (:report (lambda (condition stream)
             (declare (ignore condition stream))
             (error "The printer is broken too"))))

(test diagnostic-printing-is-defensive
  (is (string= "[Condition could not be printed]"
               (lime.x11::%diagnostic-condition-message (make-condition 'broken-diagnostic-printer))))
  (is (= 4096 (length (lime.x11::%diagnostic-condition-message
                       (make-condition 'simple-error :format-control "~A"
                                       :format-arguments (list (make-string 5000 :initial-element #\x))))))))

(test x11-race-policy-does-not-hide-ownership-or-programming-errors
  (dolist (major '(2 3 8 10 12 15 18 19 20 25 28 29 38 42))
    (is (eq :ignore (lime.x11::%expected-x-error-policy 'xlib:window-error major t t)))
    (is (eq :client-gone (lime.x11::%expected-x-error-policy 'xlib:window-error major nil t)))
    (is-false (lime.x11::%expected-x-error-policy 'xlib:window-error major t nil)))
  (is (eq :ignore (lime.x11::%expected-x-error-policy 'xlib:match-error 42 t nil)))
  (is-false (lime.x11::%expected-x-error-policy 'xlib:match-error 42 nil nil))
  (is (eq :client-gone (lime.x11::%expected-x-error-policy 'xlib:drawable-error 14 nil t)))
  (dolist (major '(2 28 33 12 42))
    (is-false (lime.x11::%expected-x-error-policy 'xlib:access-error major t t))
    (is-false (lime.x11::%expected-x-error-policy 'xlib:value-error major t t)))
  (is-false (lime.x11::%expected-x-error-policy 'xlib:window-error 99 t t))
  (is-false (lime.x11::%expected-x-error-policy 'xlib:drawable-error 14 t nil)))

(test diagnostic-history-is-bounded-and-does-not-change-the-world
  (let* ((backend (make-head-bar-fixture))
         (revision (world-revision (lime.x11:x11-backend-world backend))))
    (setf (lime.x11::x11-backend-event-context backend) '(:kind :map-request :window-id 42))
    (dotimes (i 50)
      (backend-record-diagnostic backend (make-condition 'simple-error
                                                        :format-control "Failure ~D"
                                                        :format-arguments (list i))))
    (let* ((reports (getf (backend-diagnostics backend) :reports))
           (latest (first reports)))
      (is (= 32 (length reports)))
      (is (string= "Failure 49" (getf latest :message)))
      (is (equal '(:kind :map-request :window-id 42) (getf latest :event)))
      (setf (getf latest :message) "Changed copy")
      (is (string= "Failure 49" (getf (first (getf (backend-diagnostics backend) :reports)) :message))))
    (is (= revision (world-revision (lime.x11:x11-backend-world backend))))))

(test everyday-layouts-do-not-include-manual
  (dolist (direction '(:next :previous))
    (is (eq :monocle (lime.x11::%next-cycle-layout :master-stack direction)))
    (is (eq :master-stack (lime.x11::%next-cycle-layout :monocle direction))))
  (is (eq :master-stack (lime.x11::%next-cycle-layout :manual :next)))
  (is (eq :monocle (lime.x11::%next-cycle-layout :manual :previous)))
  (let* ((nodes (lime.x11::%ui-key-path (make-head-bar-fixture)))
         (layout (find :layout nodes :key #'lime.ui:ui-key-node-id)))
    (is (equal '(:master-stack :monocle :cycle)
               (mapcar #'lime.ui:ui-key-node-id (lime.ui:ui-key-node-children layout))))))

(test floating-delta-render-matches-full-render-geometry
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation (current-presentation world "main"))
         (id (presentation-id presentation)))
    (toggle-client-floating world id "terminal"
                            :data '(:x 1/4 :y 1/3 :width 1/2 :height 1/2))
    (setf (gethash "terminal" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info
           :normal-hints (xlib:make-wm-size-hints :min-width 90 :min-height 70
                                                 :width-inc 8 :height-inc 16)))
    (dolist (mode '(:manual :master-stack :monocle))
      (set-presentation-layout-mode world id mode)
      (let* ((full (configure-effect-for backend "terminal"))
             (delta (lime.x11::%floating-client-configure-effect backend presentation "terminal")))
        (is (eq :configure (x11-effect-kind delta)))
        (is (equalp (x11-effect-geometry full) (x11-effect-geometry delta)))
        (is (= (x11-effect-border-width full) (x11-effect-border-width delta)))
        ;; A position update must not overwrite current focus colors.
        (is-false (x11-effect-border-color delta))))
    (is-false (lime.x11::%floating-client-configure-effect backend presentation "editor"))
    (setf (gethash "terminal" (lime.x11::x11-backend-fullscreen-clients backend)) t)
    (is-false (lime.x11::%floating-client-configure-effect backend presentation "terminal"))
    (remhash "terminal" (lime.x11::x11-backend-fullscreen-clients backend))
    (hide-client-from-presentation world "terminal" id)
    (is-false (lime.x11::%floating-client-configure-effect backend presentation "terminal"))))

(test pointer-deltas-use-work-area-and-remain-bounded
  (let* ((area (make-x11-work-area :x 40 :y 52 :width 800 :height 600))
         (drag (lime.x11::make-pointer-drag
                :mode :move :initial-root-x 200 :initial-root-y 200
                :initial-data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))))
    (is (equal '(:x 3/8 :y 5/12 :width 1/2 :height 1/2)
               (lime.x11::%drag-geometry drag area 300 300)))
    (is (equal '(:x 0 :y 0 :width 1/2 :height 1/2)
               (lime.x11::%drag-geometry drag area -9999 -9999)))
    (is (equal '(:x 1/2 :y 1/2 :width 1/2 :height 1/2)
               (lime.x11::%drag-geometry drag area 9999 9999)))
    (setf (lime.x11::pointer-drag-mode drag) :resize)
    (is (equal '(:x 1/4 :y 1/4 :width 1/20 :height 1/20)
               (lime.x11::%drag-geometry drag area -9999 -9999)))
    (is (equal '(:x 1/4 :y 1/4 :width 3/4 :height 3/4)
               (lime.x11::%drag-geometry drag area 9999 9999)))))

(lime.config:defconfiguration config-dsl-fixture
  (:options :default-keybindings t :default-modifiers '(:mod-4)
            :default-layout :monocle
            :new-client-focus nil
            :new-tiled-client-position :front
            :close-focus-direction :next)
  ;; A layout entry selectively overrides the ordinary fallback policy.
  (:layout-flow :monocle
   :new-tiled-client-position :back
   :close-focus-direction :previous)
  (:command terminal
   :label "Terminal"
   :description "launch a terminal"
   :category "Launch"
   :key #\t
   :action (lambda (backend)
             (declare (ignore backend))
             (incf *configured-command-runs*)))
  (:bind #\t terminal :modifiers '(:mod-4))
  ;; The specific rule must win before the generic fallback rule.
  (:rule :id mpv :class "mpv" :float t :center t)
  (:rule :id fallback :predicate (lambda (backend client-id info)
                                   (declare (ignore backend client-id info))
                                   t)
   :float t)
  (:bar :height 24 :status-providers '() :title-edge-color "#52616b")
  (:appearance :border-width 3 :inner-gap 5 :outer-gap 5
               :focused-border "#ffac54" :unfocused-border "#121f25"))

(test normal-hints-limit-snap-and-contain-rendered-geometry
  (let* ((hints (xlib:make-wm-size-hints
                 :min-width 100 :min-height 50
                 :max-width 220 :max-height 170
                 :base-width 0 :base-height 0
                 :width-inc 20 :height-inc 25))
         (constrained
           (lime.x11::constrain-geometry-to-normal-hints
            (make-geometry :x 20 :y 30 :width 247 :height 149)
            hints :bounds-x 0 :bounds-y 0 :bounds-width 200 :bounds-height 150)))
    ;; The Head bound wins over a too-large requested size, and coordinates
    ;; move only enough to keep the client on that Head.
    (is (= (geometry-x constrained) 0))
    (is (= (geometry-y constrained) 25))
    (is (= (geometry-width constrained) 200))
    (is (= (geometry-height constrained) 125)))
  (let* ((hints (xlib:make-wm-size-hints
                 :min-width 100 :min-height 50
                 :max-width 220 :max-height 170
                 :base-width 0 :base-height 0
                 :width-inc 20 :height-inc 25))
         (constrained
           (lime.x11::constrain-geometry-to-normal-hints
            (make-geometry :x 8 :y 9 :width 87 :height 31) hints)))
    ;; The smallest compatible grid cells at or above the advertised minima.
    (is (= (geometry-x constrained) 8))
    (is (= (geometry-y constrained) 9))
    (is (= (geometry-width constrained) 100))
    (is (= (geometry-height constrained) 50))))

(test absent-normal-hints-leave-a-geometry-unchanged
  (let ((geometry (lime.x11::constrain-geometry-to-normal-hints
                   (make-geometry :x 12 :y 34 :width 567 :height 89) nil)))
    (is (= (geometry-x geometry) 12))
    (is (= (geometry-y geometry) 34))
    (is (= (geometry-width geometry) 567))
    (is (= (geometry-height geometry) 89))))

(test fixed-size-detection-requires-both-explicit-positive-equal-axes
  (is-true (lime.x11::%fixed-size-normal-hints-p
            (xlib:make-wm-size-hints :min-width 300 :max-width 300
                                     :min-height 200 :max-height 200)))
  (is-false (lime.x11::%fixed-size-normal-hints-p nil))
  (dolist (arguments '(()
                       (:min-width 800 :min-height 500)
                       (:max-width 300 :max-height 200)
                       (:min-width 300 :max-width 300)
                       (:min-height 200 :max-height 200)
                       (:min-width 300 :max-width 300 :min-height 200 :max-height 400)
                       (:min-width 300 :max-width 600 :min-height 200 :max-height 200)
                       (:min-width 300 :max-width 200 :min-height 200 :max-height 200)
                       (:min-width 0 :max-width 0 :min-height 200 :max-height 200)
                       (:min-width 300 :max-width 300 :min-height 0 :max-height 0)))
    (is-false (lime.x11::%fixed-size-normal-hints-p
               (apply #'xlib:make-wm-size-hints arguments)))))

(test fixed-size-placement-is-an-overridable-default-not-a-class-rule
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11:x11-backend-world backend))
         (before (lime.persistence:snapshot-world world))
         (info (lime.x11::make-icccm-client-info
                :client-id "popup" :resource-class "discord"
                :normal-hints (xlib:make-wm-size-hints
                               :min-width 300 :max-width 300
                               :min-height 200 :max-height 200)))
         (rectangle '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
         (original (symbol-function 'lime.x11::%centered-floating-data-for-window))
         (rule-calls 0))
    (setf (gethash "popup" (lime.x11::x11-backend-icccm-clients backend)) info)
    (unwind-protect
         (progn
           ;; Geometry itself is covered on a real X server in the smoke test.
           (setf (symbol-function 'lime.x11::%centered-floating-data-for-window)
                 (lambda (b id window head)
                   (declare (ignore b id window head)) rectangle))
           (flet ((decision () (lime.x11::new-client-placement-decision backend "popup" nil)))
             (let ((result (decision)))
               (is (eq :float (lime.x11::x11-placement-decision-kind result)))
               (is (equal rectangle (lime.x11::x11-placement-decision-data result)))
               (is (equal "main" (lime.x11::x11-placement-decision-head-id result)))
               (is (equal "development" (lime.x11::x11-placement-decision-activity-id result)))
               ;; Do not force focus when the user's new-client policy says no.
               (is-false (lime.x11::x11-placement-decision-focus-p result)))
             ;; The same class with only a minimum size is still tiled.
             (let ((fixed-hints (lime.x11::icccm-client-info-normal-hints info)))
               (setf (lime.x11::icccm-client-info-normal-hints info)
                     (xlib:make-wm-size-hints :min-width 800 :min-height 500))
               (is (eq :tile (lime.x11::x11-placement-decision-kind (decision))))
               (setf (lime.x11::icccm-client-info-normal-hints info) fixed-hints))
             ;; Only the first matching rule runs; :FLOAT NIL really overrides
             ;; the default, rather than leaving stale floating geometry.
             (setf (lime.x11::x11-backend-configuration backend)
                   (make-lime-configuration
                    :rules (list (make-window-rule
                                  :resource-class "discord" :float-p nil
                                  :predicate (lambda (&rest args)
                                               (declare (ignore args))
                                               (incf rule-calls) t))
                                 (make-window-rule :float-p t :center-p t))))
             (let ((result (decision)))
               (is (eq :tile (lime.x11::x11-placement-decision-kind result)))
               (is-false (lime.x11::x11-placement-decision-data result))
               (is (= 1 rule-calls)))
             ;; A nonmatching rule leaves the fixed-size default alone.
             (setf (lime.x11::x11-backend-configuration backend)
                   (make-lime-configuration
                    :rules (list (make-window-rule :resource-class "unrelated" :float-p nil))))
             (is (eq :float (lime.x11::x11-placement-decision-kind (decision))))
             (is (equalp before (lime.persistence:snapshot-world world)))))
      (setf (symbol-function 'lime.x11::%centered-floating-data-for-window) original))))

(test icccm-wm-state-uses-the-standard-normal-and-iconic-payloads
  ;; The icon-window XID is deliberately zero: Views, not an icon box, are
  ;; Lime's user-facing way to recover a hidden task client.
  (is (equal (icccm-wm-state-data :withdrawn) '(0 0)))
  (is (equal (icccm-wm-state-data :normal) '(1 0)))
  (is (equal (icccm-wm-state-data :iconic) '(3 0))))

(test icccm-property-refresh-retains-the-renderers-wm-state-cache
  ;; An unrelated property change must not turn an already hidden window back
  ;; into an apparent withdrawal, or queue another pointless unmap.
  (is (eq (lime.x11::%refreshed-wm-state
           (lime.x11::make-icccm-client-info :wm-state :iconic))
          :iconic))
  (is (eq (lime.x11::%refreshed-wm-state nil) :withdrawn)))

(test renderer-unmap-tokens-distinguish-one-view-hide-from-a-later-withdrawal
  (let ((backend (make-head-bar-fixture)))
    ;; Numeric XIDs keep this bookkeeping test independent of a live CLX
    ;; server.  Exactly one token is consumed for each renderer unmap.
    (lime.x11::%note-pending-unmap backend 4242)
    (lime.x11::%note-pending-unmap backend 4242)
    (is-true (lime.x11::%consume-pending-unmap-p backend 4242))
    (is-true (lime.x11::%consume-pending-unmap-p backend 4242))
    (is-false (lime.x11::%consume-pending-unmap-p backend 4242))
    (lime.x11::%note-pending-unmap backend 4242)
    (lime.x11::%forget-pending-unmaps backend 4242)
    (is-false (lime.x11::%consume-pending-unmap-p backend 4242))))

(test withdrawal-cleanup-retires-a-client-from-views-and-backend-caches
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend)))
    (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info :client-id "editor"))
    ;; This is the shared DestroyNotify/withdrawal cleanup seam.  It changes
    ;; durable client membership only after the lifecycle layer has decided
    ;; that the unmap really came from the application.
    (is (equal (lime.x11::%retire-managed-client backend "editor") "editor"))
    (signals unknown-entity (find-client world "editor"))
    (is-false (backend-client-icccm-info backend "editor"))
    (is-false (member "editor"
                      (presentation-client-ids (current-presentation world "main"))
                      :test #'equal))))

(test named-commands-derive-readable-unique-identifiers
  (let ((world (make-world)))
    (create-activity world "lime" "Existing Lime")
    (is (equal (lime.x11::%name-slug "  Lime WM!  " "Activity") "lime-wm"))
    (is (equal (lime.x11::%fresh-id-from-name world "Lime" "Activity"
                                               #'find-activity)
               "lime-2"))
    (is (equal (lime.x11::%fresh-id-from-name world "Code / Debug" "View"
                                               #'find-view :prefix "lime")
               "lime/code-debug"))))

(test only-client-lease-conflicts-offer-lease-policy-choices
  (flet ((report-with (kind)
           (lime.core::make-activation-report
            :conflicts (list (lime.core::make-activation-conflict :kind kind)))))
    (is-true (lime.x11::%ui-lease-conflicts-only-p
              (report-with :client-leased)))
    (is-false (lime.x11::%ui-lease-conflicts-only-p
               (report-with :view-mounted)))))

(test ewmh-state-actions-follow-remove-add-toggle-semantics
  (is-false (lime.x11::%ewmh-state-action-result 0 t))
  (is-true (lime.x11::%ewmh-state-action-result 1 nil))
  (is-true (lime.x11::%ewmh-state-action-result 2 nil))
  (is-false (lime.x11::%ewmh-state-action-result 2 t))
  ;; Unknown action codes must not accidentally alter the client's state.
  (is-true (lime.x11::%ewmh-state-action-result 99 t)))

(test ewmh-window-type-policy-decodes-defaults-and-separates-external-surfaces
  ;; The atom-id decoder is deliberately server-free.  Its production caller
  ;; supplies real atoms interned on the current X display.
  (let ((type-atoms '((:dialog . 10) (:dock . 20) (:utility . 30))))
    (is (equal (lime.x11::%ewmh-types-from-atom-ids '(10 30) type-atoms)
               '(:dialog :utility)))
    (is (equal (lime.x11::%ewmh-types-from-atom-ids '(999) type-atoms)
               '(:normal)))
    (is-true (lime.x11::%ewmh-dialog-like-window-types-p '(:utility)))
    (is-false (lime.x11::%ewmh-dialog-like-window-types-p '(:normal)))
    (is-true (lime.x11::%ewmh-external-window-types-p '(:dock)))
    (is-false (lime.x11::%ewmh-external-window-types-p '(:dialog)))))

(test ewmh-supporting-window-name-is-an-eight-bit-utf8-payload
  ;; CLX requires this specialized payload for a UTF8_STRING property.
  (is (typep lime.x11::+ewmh-wm-name-utf8+
             '(array (unsigned-byte 8) (*))))
  (is (equalp lime.x11::+ewmh-wm-name-utf8+ #(76 105 109 101))))

(test ewmh-client-order-keeps-first-map-order-and-removes-only-the-gone-window
  (let ((order '()))
    (setf order (lime.x11::%ewmh-add-client-window-id order 40)
          order (lime.x11::%ewmh-add-client-window-id order 20)
          order (lime.x11::%ewmh-add-client-window-id order 40))
    (is (equal order '(40 20)))
    (is (equal (lime.x11::%ewmh-remove-client-window-id order 40)
               '(20)))))

(test ewmh-external-configure-masks-admit-only-requested-geometry-components
  ;; X's ConfigureRequest mask uses the conventional CWX/CWY/CWWidth/etc.
  ;; bit positions; docks may update only the fields they actually requested.
  (let ((x-and-width (logior #b00001 #b00100)))
    (is-true (lime.x11::%ewmh-configure-request-includes-p x-and-width :x))
    (is-false (lime.x11::%ewmh-configure-request-includes-p x-and-width :y))
    (is-true (lime.x11::%ewmh-configure-request-includes-p x-and-width :width))
    (is-false (lime.x11::%ewmh-configure-request-includes-p x-and-width :height))
    (is-false (lime.x11::%ewmh-configure-request-includes-p x-and-width
                                                              :border-width))))

(defun make-fullscreen-render-fixture ()
  "Build a server-free adapter fixture for fullscreen render planning."
  (let* ((world (make-world))
         (heads (make-hash-table :test #'equal))
         (backend
           (lime.x11::%make-x11-backend
            :world world
            :head-id "main"
            :activity-id "play"
            :focused-head-id "main"
            :heads heads
            :head-ids '("main"))))
    (setf (gethash "main" heads)
          (make-x11-head :head-id "main" :x 40 :y 30 :width 800 :height 600))
    (create-head world "main")
    (create-activity world "play" "Play")
    (create-client world "game" "play" :name "Game")
    (create-view world "play/home" "play" "Home"
                 (list (make-placement :client-id "game"))
                 :focus-client-id "game")
    (activate-view-strictly world "main" "play/home")
    ;; No X connection is needed to plan.  A truthy placeholder represents a
    ;; managed client; the intentionally hostile max hints prove fullscreen
    ;; bypasses regular tiled geometry constraining.
    (setf (gethash "game" (lime.x11::x11-backend-client-windows backend)) :game
          (gethash "game" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info
           :client-id "game"
           :normal-hints (xlib:make-wm-size-hints :max-width 320 :max-height 240)))
    backend))

(test fullscreen-rendering-owns-the-current-leased-head
  (let* ((backend (make-fullscreen-render-fixture))
         (fullscreen-clients (lime.x11::x11-backend-fullscreen-clients backend)))
    (setf (gethash "game" fullscreen-clients) t)
    (let ((geometry (cdr (assoc "game" (lime.x11::%active-client-geometries backend)
                               :test #'equal))))
      (is (= (geometry-x geometry) 40))
      (is (= (geometry-y geometry) 30))
      (is (= (geometry-width geometry) 800))
      (is (= (geometry-height geometry) 600)))
    (let* ((effects (x11-render-plan-effects (build-render-plan backend)))
           (focus-effect (car (last effects))))
      (is (find :raise effects :key #'x11-effect-kind))
      (is (eq (x11-effect-kind focus-effect) :focus))
      (is (equal (x11-effect-client-id focus-effect) "game")))))

(defun make-head-bar-fixture ()
  "Build a server-free two-client Presentation for Head-bar policy tests."
  (let* ((world (make-world))
         (heads (make-hash-table :test #'equal))
         (backend
           (lime.x11::%make-x11-backend
            :world world :head-id "main" :activity-id "development"
            :focused-head-id "main" :heads heads :head-ids '("main"))))
    (setf (gethash "main" heads)
          (make-x11-head :head-id "main" :x 40 :y 30 :width 800 :height 600))
    (create-head world "main")
    (create-activity world "development" "Development")
    (create-client world "editor" "development" :name "Editor")
    (create-client world "terminal" "development" :name "Terminal")
    ;; Browser begins owned by the Activity but absent from Code: it is the
    ;; small server-free stand-in for a parked/hidden task window.
    (create-client world "browser" "development" :name "Browser")
    (create-view world "development/code" "development" "Code"
                 (list (make-placement :client-id "editor")
                       (make-placement :client-id "terminal"))
                 :focus-client-id "editor")
    (activate-view-strictly world "main" "development/code")
    backend))

(defun make-appearance-fixture ()
  (let ((backend (make-head-bar-fixture)))
    (setf (lime.x11::x11-backend-window-appearance backend)
          (lime-configuration-appearance config-dsl-fixture))
    (dolist (id '("editor" "terminal" "browser"))
      (setf (gethash id (lime.x11::x11-backend-client-windows backend)) id))
    backend))

(defun configure-effect-for (backend client-id)
  (find-if (lambda (effect)
             (and (eq :configure (x11-effect-kind effect))
                  (equal client-id (x11-effect-client-id effect))))
           (x11-render-plan-effects (build-render-plan backend))))

(defun frame-right (effect)
  (let ((geometry (x11-effect-geometry effect)))
    (+ (geometry-x geometry) (geometry-width geometry)
       (* 2 (x11-effect-border-width effect)))))

(defun frame-bottom (effect)
  (let ((geometry (x11-effect-geometry effect)))
    (+ (geometry-y geometry) (geometry-height geometry)
       (* 2 (x11-effect-border-width effect)))))

(test borders-and-odd-gaps-fit-within-the-work-area-without-mutating-views
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (revision (world-revision world))
         (presentation (current-presentation world "main"))
         (editor (configure-effect-for backend "editor"))
         (terminal (configure-effect-for backend "terminal")))
    (is (= 3 (x11-effect-border-width editor)))
    (is (= 45 (geometry-x (x11-effect-geometry editor))))
    (is (= 57 (geometry-y (x11-effect-geometry editor))))
    (is (= 5 (- (geometry-x (x11-effect-geometry terminal)) (frame-right editor))))
    (is (= 835 (frame-right terminal)))
    (is (= 625 (frame-bottom terminal)))
    (is (string= "#ffac54" (x11-effect-border-color editor)))
    (is (string= "#121f25" (x11-effect-border-color terminal)))
    (is-false (configure-effect-for backend "browser"))
    (is (= revision (world-revision world)))
    (is-false (presentation-dirty-p presentation))
    ;; The same gap math works between weighted rows as between columns.
    (show-client-on-presentation world "browser" (presentation-id presentation))
    (set-presentation-master-stack-layout world (presentation-id presentation))
    (set-client-tile-weight world (presentation-id presentation) "terminal" 2)
    (let ((upper (configure-effect-for backend "terminal"))
          (lower (configure-effect-for backend "browser")))
      (is (= 5 (- (geometry-y (x11-effect-geometry lower)) (frame-bottom upper)))))
    (set-presentation-master-stack-layout world (presentation-id presentation)
                                         :orientation :vertical)
    (let ((master (configure-effect-for backend "editor"))
          (left (configure-effect-for backend "terminal"))
          (right (configure-effect-for backend "browser")))
      (is (= 5 (- (geometry-y (x11-effect-geometry left)) (frame-bottom master))))
      (is (= 5 (- (geometry-x (x11-effect-geometry right)) (frame-right left)))))))

(test border-highlight-follows-global-focus-not-each-heads-local-focus
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation (current-presentation world "main")))
    (focus-client-on-presentation world "terminal" (presentation-id presentation))
    (is (string= "#121f25" (x11-effect-border-color (configure-effect-for backend "editor"))))
    (is (string= "#ffac54" (x11-effect-border-color (configure-effect-for backend "terminal"))))
    (setf (lime.x11::x11-backend-focus-root-override-p backend) t)
    (is (string= "#121f25" (x11-effect-border-color (configure-effect-for backend "terminal"))))
    (setf (lime.x11::x11-backend-focus-root-override-p backend) nil)
    (create-head world "other")
    (setf (gethash "other" (lime.x11::x11-backend-heads backend))
          (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
          (lime.x11::x11-backend-head-ids backend) '("main" "other"))
    (create-view world "development/browser" "development" "Browser"
                 (list (make-placement :client-id "browser")) :focus-client-id "browser")
    (activate-view-strictly world "other" "development/browser")
    (is (string= "#121f25" (x11-effect-border-color (configure-effect-for backend "browser"))))
    (setf (lime.x11::x11-backend-focused-head-id backend) "other")
    (is (string= "#ffac54" (x11-effect-border-color (configure-effect-for backend "browser"))))
    (is (string= "#121f25" (x11-effect-border-color (configure-effect-for backend "terminal"))))))

(test tiled-minimum-hints-cannot-overlap-neighbors-or-borders
  (let ((backend (make-appearance-fixture)))
    (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info
           :normal-hints (xlib:make-wm-size-hints :min-width 9000 :min-height 9000)))
    (let ((editor (configure-effect-for backend "editor"))
          (terminal (configure-effect-for backend "terminal")))
      (is (= 5 (- (geometry-x (x11-effect-geometry terminal)) (frame-right editor))))
      (is (= 625 (frame-bottom editor))))))

(test floating-frames-have-borders-but-no-tile-gaps
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend)))
    (toggle-client-floating world (presentation-id (current-presentation world "main"))
                            "editor" :data '(:x 0 :y 0 :width 1 :height 1))
    (let* ((effect (configure-effect-for backend "editor"))
           (geometry (x11-effect-geometry effect)))
      (is (= 3 (x11-effect-border-width effect)))
      (is (= 40 (geometry-x geometry)))
      (is (= 52 (geometry-y geometry)))
      (is (= 840 (frame-right effect)))
      (is (= 630 (frame-bottom effect))))))

(test fullscreen-removes-decoration-and-exiting-restores-it
  (let* ((backend (make-appearance-fixture))
         (table (lime.x11::x11-backend-fullscreen-clients backend)))
    (setf (gethash "editor" table) t)
    (let* ((effect (configure-effect-for backend "editor"))
           (geometry (x11-effect-geometry effect)))
      (is (= 0 (x11-effect-border-width effect)))
      (is (= 40 (geometry-x geometry)))
      (is (= 30 (geometry-y geometry)))
      (is (= 800 (geometry-width geometry)))
      (is (= 600 (geometry-height geometry))))
    (remhash "editor" table)
    (let ((effect (configure-effect-for backend "editor")))
      (is (= 3 (x11-effect-border-width effect)))
      (is (= 45 (geometry-x (x11-effect-geometry effect)))))))

(test monocle-is-undecorated-without-becoming-fullscreen
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation-id (presentation-id (current-presentation world "main"))))
    (set-presentation-monocle-layout world presentation-id)
    (let ((editor (configure-effect-for backend "editor")))
      (is (= 0 (x11-effect-border-width editor)))
      (is (= 40 (geometry-x (x11-effect-geometry editor))))
      (is (= 52 (geometry-y (x11-effect-geometry editor))))
      (is (= 840 (frame-right editor)))
      (is (= 630 (frame-bottom editor)))
      (is-false (configure-effect-for backend "terminal")))
    ;; Cycling changes which tile is displayed, not its decoration policy.
    (focus-client-on-presentation world "terminal" presentation-id)
    (is (= 0 (x11-effect-border-width (configure-effect-for backend "terminal"))))
    (is-false (configure-effect-for backend "editor"))
    ;; Ordinary hints still apply; monocle is not application fullscreen.
    (setf (gethash "terminal" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info
           :normal-hints (xlib:make-wm-size-hints :max-width 320 :max-height 240)))
    (let ((geometry (x11-effect-geometry (configure-effect-for backend "terminal"))))
      (is (= 320 (geometry-width geometry)))
      (is (= 240 (geometry-height geometry))))
    (remhash "terminal" (lime.x11::x11-backend-icccm-clients backend))
    ;; Switching layouts restores the configured decoration, not a cached zero.
    (set-presentation-master-stack-layout world presentation-id)
    (let ((editor (configure-effect-for backend "editor")))
      (is (= 3 (x11-effect-border-width editor)))
      (is (= 45 (geometry-x (x11-effect-geometry editor)))))))

(test monocle-does-not-remove-floating-client-borders
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation-id (presentation-id (current-presentation world "main"))))
    (toggle-client-floating world presentation-id "terminal"
                            :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
    (set-presentation-monocle-layout world presentation-id)
    (focus-client-on-presentation world "terminal" presentation-id)
    (is (= 3 (x11-effect-border-width (configure-effect-for backend "terminal"))))
    (is (string= "#ffac54"
                 (x11-effect-border-color (configure-effect-for backend "terminal"))))
    (is (= 0 (x11-effect-border-width (configure-effect-for backend "editor"))))))

(test smart-gaps-make-one-tile-undecorated-in-every-layout
  (dolist (mode '(:manual :master-stack :monocle))
    (let* ((backend (make-appearance-fixture))
           (world (lime.x11::x11-backend-world backend))
           (presentation (current-presentation world "main"))
           (id (presentation-id presentation)))
      (hide-client-from-presentation world "terminal" id)
      (set-presentation-layout-mode world id mode)
      (let* ((revision (world-revision world))
             (dirty-p (presentation-dirty-p presentation))
             (effect (configure-effect-for backend "editor"))
             (geometry (x11-effect-geometry effect)))
        (is (= 0 (x11-effect-border-width effect)))
        (is (= 40 (geometry-x geometry)))
        (is (= 52 (geometry-y geometry)))
        (is (= 800 (geometry-width geometry)))
        (is (= 578 (geometry-height geometry)))
        (is (= revision (world-revision world)))
        (is (eql dirty-p (presentation-dirty-p presentation)))))))

(test smart-gaps-follow-hide-show-float-unfloat-and-close
  (dolist (mode '(:manual :master-stack))
    (let* ((backend (make-appearance-fixture))
           (world (lime.x11::x11-backend-world backend))
           (id (presentation-id (current-presentation world "main"))))
      (set-presentation-layout-mode world id mode)
      (hide-client-from-presentation world "terminal" id)
      (is (= 0 (x11-effect-border-width (configure-effect-for backend "editor"))))
      (show-client-on-presentation world "terminal" id)
      (let ((editor (configure-effect-for backend "editor")))
        (is (= 3 (x11-effect-border-width editor)))
        (is (= 45 (geometry-x (x11-effect-geometry editor)))))
      (toggle-client-floating world id "terminal")
      (is (= 0 (x11-effect-border-width (configure-effect-for backend "editor"))))
      (is (= 3 (x11-effect-border-width (configure-effect-for backend "terminal"))))
      (toggle-client-floating world id "editor")
      ;; Zero tiles does not mean floats should lose their borders.
      (is (= 3 (x11-effect-border-width (configure-effect-for backend "editor"))))
      (is (= 3 (x11-effect-border-width (configure-effect-for backend "terminal"))))
      (toggle-client-floating world id "editor")
      (toggle-client-floating world id "terminal")
      (is (= 3 (x11-effect-border-width (configure-effect-for backend "editor"))))
      (retire-client world "terminal")
      (let ((editor (configure-effect-for backend "editor")))
        (is (= 0 (x11-effect-border-width editor)))
        (is (= 40 (geometry-x (x11-effect-geometry editor))))))))

(test smart-gaps-count-only-this-heads-leased-tiles
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend)))
    (create-head world "other")
    (setf (gethash "other" (lime.x11::x11-backend-heads backend))
          (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
          (lime.x11::x11-backend-head-ids backend) '("main" "other"))
    (create-view world "development/browser" "development" "Browser"
                 (list (make-placement :client-id "browser")))
    (activate-view-strictly world "other" "development/browser")
    (is (= 3 (x11-effect-border-width (configure-effect-for backend "editor"))))
    (is (= 0 (x11-effect-border-width (configure-effect-for backend "browser"))))
    ;; A saved slot remaining on main must not count once its lease moves.
    (create-view world "development/pair" "development" "Pair"
                 (list (make-placement :client-id "browser")
                       (make-placement :client-id "terminal")))
    (activate-view-taking world "other" "development/pair")
    (is (= 0 (x11-effect-border-width (configure-effect-for backend "editor"))))
    (is (= 3 (x11-effect-border-width (configure-effect-for backend "browser"))))
    (is (= 3 (x11-effect-border-width (configure-effect-for backend "terminal"))))))

(test smart-gaps-preserve-normal-hints-and-configured-style
  (let* ((backend (make-appearance-fixture))
         (world (lime.x11::x11-backend-world backend))
         (id (presentation-id (current-presentation world "main"))))
    (hide-client-from-presentation world "terminal" id)
    (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend))
          (lime.x11::make-icccm-client-info
           :normal-hints (xlib:make-wm-size-hints :max-width 320 :max-height 240)))
    (let* ((effect (configure-effect-for backend "editor"))
           (geometry (x11-effect-geometry effect))
           (style (lime.x11::x11-backend-window-appearance backend)))
      (is (= 0 (x11-effect-border-width effect)))
      (is (= 52 (geometry-y geometry)))
      (is (= 320 (geometry-width geometry)))
      (is (= 240 (geometry-height geometry)))
      (is (= 3 (window-appearance-border-width style)))
      (is (= 5 (window-appearance-inner-gap style)))
      (is (= 5 (window-appearance-outer-gap style))))))

(test oversized-decoration-degrades-to-a-contained-one-pixel-client
  (let ((backend (make-appearance-fixture)))
    (setf (lime.x11::x11-backend-window-appearance backend)
          (make-window-appearance :border-width 65535 :inner-gap 65535 :outer-gap 65535))
    (let* ((effect (configure-effect-for backend "editor"))
           (geometry (x11-effect-geometry effect)))
      (is (= 0 (x11-effect-border-width effect)))
      (is (= 1 (geometry-width geometry)))
      (is (= 1 (geometry-height geometry)))
      (is (<= 40 (geometry-x geometry) 839))
      (is (<= 52 (geometry-y geometry) 629)))))

(test appearance-configuration-validates-before-installation
  (let ((style (lime-configuration-appearance config-dsl-fixture)))
    (is (= 3 (window-appearance-border-width style)))
    (is (= 5 (window-appearance-inner-gap style)))
    (is (= 5 (window-appearance-outer-gap style)))
    (is (string= "#ffac54" (window-appearance-focused-border style))))
  (dolist (style (list (make-window-appearance :border-width -1)
                      (make-window-appearance :inner-gap 1/2)
                      (make-window-appearance :outer-gap 65536)
                      (make-window-appearance :focused-border "#gg2233")
                      (make-window-appearance :unfocused-border "blue")
                      nil))
    (signals invalid-transition
      (lime.x11::%validate-lime-configuration (make-lime-configuration :appearance style)))))

(test head-bars-reserve-the-normal-client-work-area
  (let* ((backend (make-head-bar-fixture))
         (work-area (x11-head-work-area backend "main"))
         (presentation (current-presentation (lime.x11::x11-backend-world backend)
                                             "main"))
         (geometries (lime.x11::%active-client-geometries backend))
         (editor (cdr (assoc "editor" geometries :test #'equal))))
    (is (= (x11-work-area-x work-area) 40))
    (is (= (x11-work-area-y work-area) 52))
    (is (= (x11-work-area-width work-area) 800))
    (is (= (x11-work-area-height work-area) 578))
    ;; The default manual tree receives the work area rather than the physical
    ;; Head, so even its first tile cannot draw underneath the persistent bar.
    (is (= (geometry-y editor) 52))
    (is (= (geometry-height editor) 578))
    (setf (presentation-layout-mode presentation) :master-stack)
    (is (equal (lime.x11::%bar-layout-token backend "main") "[]="))
    (setf (presentation-layout-mode presentation) :manual)
    (is (equal (lime.x11::%bar-layout-token backend "main") "|M|"))
    (setf (presentation-layout-mode presentation) :monocle)
    (is (equal (lime.x11::%bar-layout-token backend "main") "[2]"))))

(test monocle-bar-count-includes-visible-tile-but-not-floats-or-hidden-clients
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation-id (presentation-id (current-presentation world "main"))))
    (set-presentation-monocle-layout world presentation-id)
    ;; Editor and terminal participate; the parked browser does not.
    (is (equal "[2]" (lime.x11::%bar-layout-token backend "main")))
    (focus-client-on-presentation world "terminal" presentation-id)
    (is (equal "[2]" (lime.x11::%bar-layout-token backend "main")))
    (hide-client-from-presentation world "terminal" presentation-id)
    (is (equal "[1]" (lime.x11::%bar-layout-token backend "main")))
    (show-client-on-presentation world "terminal" presentation-id)
    (is (equal "[2]" (lime.x11::%bar-layout-token backend "main")))
    (toggle-client-floating world presentation-id "terminal")
    (is (equal "[1]" (lime.x11::%bar-layout-token backend "main")))
    (hide-client-from-presentation world "editor" presentation-id)
    (is (equal "[0]" (lime.x11::%bar-layout-token backend "main")))
    (hide-client-from-presentation world "terminal" presentation-id)
    (is (equal "[0]" (lime.x11::%bar-layout-token backend "main")))
    (show-client-on-presentation world "editor" presentation-id)
    (is (equal "[1]" (lime.x11::%bar-layout-token backend "main")))))

(test monocle-bar-count-excludes-tiles-leased-to-another-head
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend)))
    (set-presentation-monocle-layout world
                                    (presentation-id (current-presentation world "main")))
    (create-head world "other")
    (create-view world "development/other" "development" "Other"
                 (list (make-placement :client-id "terminal")))
    (activate-view-taking world "other" "development/other")
    (is (equal "[1]" (lime.x11::%bar-layout-token backend "main")))))

(defun bar-test-text-width (text)
  "Deliberately unequal advances to catch character-count approximations."
  (loop for character across text
        sum (case character (#\W 11) (#\i 3) (#\. 2) (otherwise 6))))

(test bar-truncation-fits-pixels-including-ellipsis
  (let ((measure #'bar-test-text-width))
    (is (string= "WWiiii" (lime.x11::%bar-short-text "WWiiii" 34 measure)))
    (multiple-value-bind (text retained)
        (lime.x11::%bar-short-text "WWiiii" 20 measure)
      (is (string= "W..." text))
      (is (= 1 retained))
      (is (<= (funcall measure text) 20)))
    (is (string= "..." (lime.x11::%bar-short-text "WWiiii" 6 measure)))
    (is (string= "i" (lime.x11::%bar-short-text "iiWW" 5 measure)))
    (is (string= "" (lime.x11::%bar-short-text "WWiiii" 1 measure)))
    (is (string= "" (lime.x11::%bar-short-text "WWiiii" 0 measure)))
    (is (string= "" (lime.x11::%bar-short-text "" 30 measure)))))

(test bar-layout-uses-measured-separators-and-a-left-aligned-title
  (let* ((measure #'bar-test-text-width)
         (narrow (lime.x11::%bar-text-layout 1000 "iii" "[]=" "Title" "Status" measure))
         (wide (lime.x11::%bar-text-layout 1000 "WWW" "[]=" "Title" "Status" measure)))
    (is (= 10 (getf narrow :logo-x)))
    (is (= (+ 10 (funcall measure "Lime")) (getf narrow :logo-width)))
    (is (= (funcall measure " | ")
           (- (getf narrow :label-x) (getf narrow :logo-x) (funcall measure "Lime"))))
    (is (= (funcall measure " | ") (- (getf narrow :layout-x)
                (+ (getf narrow :label-x) (funcall measure "iii")))))
    (is (= (- (funcall measure "WWW") (funcall measure "iii"))
           (- (getf wide :layout-x) (getf narrow :layout-x))))
    (is (= 990 (+ (getf wide :status-x) (funcall measure (getf wide :status)))))
    (let* ((title-left (+ (getf wide :layout-x) (funcall measure "[]=") 8))
           (title-right (- (getf wide :status-x) 8)))
      (is (= title-left (getf wide :title-left)))
      (is (= title-right (getf wide :title-right)))
      (is (= (+ title-left 11) (getf wide :title-x))))))

(test long-bar-label-is-truncated-by-pixels-before-positioning-layout
  (let* ((measure #'bar-test-text-width)
         (layout (lime.x11::%bar-text-layout
                  300 (make-string 100 :initial-element #\W) "|M|" "Title" "" measure))
         (label (getf layout :label)))
    (is (string= "..." (subseq label (- (length label) 3))))
    (is (= (+ (getf layout :label-x) (funcall measure label)
              (funcall measure " | "))
           (getf layout :layout-x)))
    (is (<= (+ (getf layout :layout-x) (funcall measure "|M|") 8)
            (getf layout :title-x)))))

(test bar-padding-insets-text-and-remains-part-of-layout-not-hit-test-guesswork
  (dolist (padding '(0 6 10 24 128))
    (let ((layout (lime.x11::%bar-text-layout 2000 "Work:Code" "[]=" "Title" "Status"
                                            #'bar-test-text-width :padding-x padding)))
      (is (= padding (getf layout :logo-x)))
      (is (= (+ padding (bar-test-text-width "Lime")) (getf layout :logo-width)))
      (is (= (- 2000 padding) (+ (getf layout :status-x) (bar-test-text-width "Status"))))
      (is (= (+ (getf layout :title-left) 1 padding) (getf layout :title-x)))
      (is (= (- (getf layout :title-right) 1 padding)
             (+ (getf layout :title-x) (getf layout :title-width)))))))

(test bar-fields-stay-contained-and-separated-on-narrow-heads
  (dolist (width '(0 1 6 12 24 50 100 160 320 1000))
    (dolist (padding '(0 10 128))
      (let* ((measure #'bar-test-text-width)
             (layout (lime.x11::%bar-text-layout
                      width "Long Activity:Long View*" "[123]"
                      "WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW"
                      "WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW"
                      measure :padding-x padding))
             (previous-right (getf layout :logo-width)))
        (is (<= 0 previous-right width))
        (is (<= 0 (getf layout :title-left) (getf layout :title-right) width))
        (dolist (span (getf layout :separators))
          (is (<= 0 (car span) (+ (car span) (funcall measure (cdr span))) width)))
        (dolist (keys '((:label :label-x) (:layout-token :layout-x)
                       (:title :title-x) (:status :status-x)))
          (let ((text (getf layout (first keys)))
                (x (getf layout (second keys))))
            (when (plusp (length text))
              (is (<= previous-right x (+ x (funcall measure text)) width))
              (setf previous-right (+ x (funcall measure text))))))))))

(test status-hit-spans-use-visible-measured-text-only
  (let* ((action (lambda (&rest arguments) (declare (ignore arguments))))
         (first (make-head-bar-segment :text "Wi" :click-action action))
         (second (make-head-bar-segment :text "iiW" :click-action action))
         (segments (list first second)))
    (is (equal (list (list 100 114 first) (list 132 149 second))
               (lime.x11::%bar-status-hit-spans segments 8 100 #'bar-test-text-width)))
    ;; Prefix ends partway through the second segment, before truncation dots.
    (is (equal (list (list 100 114 first) (list 132 138 second))
               (lime.x11::%bar-status-hit-spans segments 7 100 #'bar-test-text-width)))
    ;; Prefix ends within the separator: no phantom second click target.
    (is (equal (list (list 100 114 first))
               (lime.x11::%bar-status-hit-spans segments 3 100 #'bar-test-text-width)))
    (is-false (lime.x11::%bar-status-hit-spans segments 0 100 #'bar-test-text-width))))

(test bar-title-anchor-is-stable-when-title-or-status-length-changes
  (let* ((measure #'bar-test-text-width)
         (one (lime.x11::%bar-text-layout 1000 "WM:Code*" "[]=" "Short" "" measure))
         (two (lime.x11::%bar-text-layout 1000 "WM:Code*" "[]=" "A longer title" "Music | 25%" measure)))
    (is (= (getf one :title-x) (getf two :title-x)))
    (is (= 1000 (getf one :title-right)))
    (is (< (getf two :title-right) 1000))
    (is (= 2 (length (getf one :separators))))
    (dolist (span (getf one :separators))
      (is (string= " | " (cdr span))))))

(test bar-colors-and-optional-title-edges-are-validated-config-data
  (is (string= "#52616b"
               (head-bar-style-title-edge-color (lime-configuration-bar-style config-dsl-fixture))))
  (let* ((configuration (make-lime-configuration))
         (style (lime-configuration-bar-style configuration)))
    (is (= 10 (head-bar-style-padding-x style)))
    (dolist (bad '(-1 129 1/2 nil))
      (setf (head-bar-style-padding-x style) bad)
      (signals invalid-transition (lime.x11::%validate-lime-configuration configuration)))
    (setf (head-bar-style-padding-x style) 10)
    (is (string= "#40535d" (head-bar-style-title-edge-color style)))
    (setf (head-bar-style-title-edge-color style) nil)
    (is (eq configuration (lime.x11::%validate-lime-configuration configuration)))
    (setf (head-bar-style-title-edge-color style) "blue")
    (signals invalid-transition (lime.x11::%validate-lime-configuration configuration))
    (setf (head-bar-style-title-edge-color style) nil
          (head-bar-style-separator-color style) nil)
    (signals invalid-transition (lime.x11::%validate-lime-configuration configuration)))
  (let ((configuration
          (eval '(progn
                   (lime.config:defconfiguration edge-free-fixture
                     (:bar :title-edge-color nil :background "#123456" :padding-x 16))
                   edge-free-fixture))))
    (is-false (head-bar-style-title-edge-color (lime-configuration-bar-style configuration)))
    (is (= 16 (head-bar-style-padding-x (lime-configuration-bar-style configuration))))
    (is (string= "#123456" (head-bar-style-background (lime-configuration-bar-style configuration))))))

(test logo-color-is-optional-and-independent-of-other-bar-text
  (let* ((configuration
           (eval '(progn
                    (lime.config:defconfiguration logo-color-fixture
                      (:bar :foreground "#dbc9a6" :logo-color "#768565"))
                    logo-color-fixture)))
         (style (lime-configuration-bar-style configuration)))
    (is (eq configuration (lime.x11::%validate-lime-configuration configuration)))
    (is (string= "#768565" (head-bar-style-logo-color style)))
    (is (string= "#dbc9a6" (head-bar-style-foreground style)))
    (is (member "#768565" (lime.x11::%head-bar-style-colors style) :test #'equal))
    (setf (head-bar-style-logo-color style) nil)
    (is (eq configuration (lime.x11::%validate-lime-configuration configuration)))
    (is-false (head-bar-style-logo-color (make-head-bar-style)))
    (dolist (bad '("green" "#12345" 42))
      (setf (head-bar-style-logo-color style) bad)
      (signals invalid-transition (lime.x11::%validate-lime-configuration configuration)))))

(test menu-accents-and-labels-are-independent-of-title-and-separators
  (let* ((configuration
           (eval '(progn
                    (lime.config:defconfiguration independent-menu-colors-fixture
                      (:bar :focused-foreground "#dbc9a6" :separator-color "#686868"
                            :accent-color "#ffb054" :menu-label-color "#dbc9a6"))
                    independent-menu-colors-fixture)))
         (style (lime-configuration-bar-style configuration)))
    (is (eq configuration (lime.x11::%validate-lime-configuration configuration)))
    (is (string= "#dbc9a6" (head-bar-style-focused-foreground style)))
    (is (string= "#ffb054" (lime.x11::%ui-accent-color style)))
    (is (string= "#dbc9a6" (lime.x11::%ui-menu-label-color style)))
    (setf (head-bar-style-accent-color style) nil
          (head-bar-style-menu-label-color style) nil)
    (is (string= "#dbc9a6" (lime.x11::%ui-accent-color style)))
    (is (string= "#686868" (lime.x11::%ui-menu-label-color style)))
    (setf (head-bar-style-accent-color style) "yellow")
    (signals invalid-transition (lime.x11::%validate-lime-configuration configuration))
    (setf (head-bar-style-accent-color style) nil
          (head-bar-style-menu-label-color style) "cream")
    (signals invalid-transition (lime.x11::%validate-lime-configuration configuration))))

(test status-separator-coloring-never-mistakes-provider-content-for-a-divider
  (let ((segments (list (make-head-bar-segment :text "a|b")
                        (make-head-bar-segment :text "end"))))
    (is (equal '((118 . " | "))
               (lime.x11::%bar-status-separator-spans segments 9 100 #'bar-test-text-width)))
    (is-false (lime.x11::%bar-status-separator-spans segments 3 100 #'bar-test-text-width))
    (is (equal '((118 . " "))
               (lime.x11::%bar-status-separator-spans segments 4 100 #'bar-test-text-width)))))

(test bar-title-fallbacks-are-human-readable
  (let* ((backend (make-head-bar-fixture))
         (info (lime.x11::make-icccm-client-info :title "Editor title"
                                               :resource-class "Editor" :resource-name "editor")))
    (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend)) info)
    (is (string= "Editor title" (lime.x11::%bar-focused-title backend "main")))
    (setf (icccm-client-info-title info) "")
    (is (string= "Editor" (lime.x11::%bar-focused-title backend "main")))
    (setf (icccm-client-info-resource-class info) nil)
    (is (string= "editor" (lime.x11::%bar-focused-title backend "main")))
    (remhash "editor" (lime.x11::x11-backend-icccm-clients backend))
    (is (string= "Untitled window" (lime.x11::%bar-focused-title backend "main")))))

(test single-line-text-preserves-unicode-but-not-control-characters
  (is (string= "café — 日本語 🎮 👩‍💻 ‘quoted’"
               (lime.x11::%single-line-text "café — 日本語 🎮 👩‍💻 ‘quoted’")))
  (is (string= "a b" (lime.x11::%single-line-text (format nil "a~%b"))))
  (is (string= "a b" (lime.x11::%single-line-text (format nil "a~Cb" #\Null)))))

(test head-bar-labels-identify-activities-not-checkpoint-state
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation (current-presentation world "main")))
    (is (equal (lime.x11::%bar-presentation-label backend "main")
               "Development"))
    (setf (presentation-dirty-p presentation) t)
    (is (equal (lime.x11::%bar-presentation-label backend "main")
               "Development"))
    (is (presentation-dirty-p presentation))
    (is (equal "development/code" (presentation-source-view-id presentation)))
    ;; A zero reservation cleanly recovers the full physical Head for an
    ;; intentionally bar-less configuration.
    (setf (lime.x11::x11-backend-head-bar-height backend) 0)
    (let ((work-area (x11-head-work-area backend "main")))
      (is (= (x11-work-area-y work-area) 30))
      (is (= (x11-work-area-height work-area) 600)))))

(test configuration-dsl-keeps-commands-bindings-rules-and-bar-policy-separate
  (let ((configuration config-dsl-fixture))
    ;; This is the complete validation step that happens before a real backend
    ;; releases/regrabs any key or changes its visible bar state.
    (is (eq configuration
            (lime.x11::%validate-lime-configuration configuration)))
    (is-true (lime-configuration-default-keybindings-p configuration))
    (is (equal (lime-configuration-default-modifiers configuration) '(:mod-4)))
    (is (eq :monocle (lime-configuration-default-layout configuration)))
    (is-false (lime-configuration-new-client-focus-p configuration))
    (is (eq (lime-configuration-new-tiled-client-position configuration) :front))
    (is (eq (lime-configuration-close-focus-direction configuration) :next))
    (let ((monocle-policy
            (find :monocle
                  (lime-configuration-layout-client-flow-policies configuration)
                  :key #'layout-client-flow-policy-layout-mode)))
      (is-true monocle-policy)
      (is (eq (layout-client-flow-policy-new-tiled-client-position monocle-policy)
              :back))
      (is (eq (layout-client-flow-policy-close-focus-direction monocle-policy)
              :previous)))
    (is (= (lime-configuration-bar-height configuration) 24))
    (is-true (lime-configuration-bar-height-supplied-p configuration))
    (is-true (lime-configuration-status-providers-supplied-p configuration))
    (is (equal (mapcar #'lime-command-id
                       (lime-configuration-commands configuration))
               '(terminal)))
    (is (equal (mapcar #'configuration-binding-command-id
                       (lime-configuration-bindings configuration))
               '(terminal)))
    (is (equal (mapcar #'window-rule-id (lime-configuration-rules configuration))
               '(mpv fallback)))))

(test default-layout-is-adapter-policy-and-does-not-replace-existing-work
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (existing (current-presentation world "main")))
    (is (eq :master-stack (lime.x11::configured-default-layout backend)))
    (let ((draft (lime.x11::%ensure-active-presentation world "other" "scratch")))
      (is (eq :master-stack (presentation-layout-mode draft)))
      (is-false (presentation-source-view-id draft)))
    (is (eq existing (lime.x11::%ensure-active-presentation world "main" "development")))
    (is (eq :manual (presentation-layout-mode existing)))
    (setf (lime.x11::x11-backend-configuration backend) config-dsl-fixture)
    (is (eq :monocle (lime.x11::configured-default-layout backend)))
    ;; A portable Activity keeps its existing layout when brought here.
    (is (eq :master-stack
            (activation-report-desired-layout-mode
             (backend-preflight-activity-activation backend "scratch"))))
    (create-activity world "new-layout" "New")
    (is (eq :monocle (activation-report-desired-layout-mode
                      (backend-preflight-activity-activation backend "new-layout"))))
    (dolist (mode '(:manual :master-stack :monocle))
      (is (typep (lime.x11::%validate-lime-configuration
                  (make-lime-configuration :default-layout mode))
                 'lime-configuration)))
    (dolist (mode '(nil :floating :bogus "master-stack"))
      (signals invalid-transition
        (lime.x11::%validate-lime-configuration
         (make-lime-configuration :default-layout mode))))))

(test layout-client-flow-policies-override-the-ordinary-client-flow-fallback
  (let ((backend (make-head-bar-fixture)))
    ;; The built-in policy is useful even with no configuration file at all.
    (is (eq (lime.x11::configured-new-tiled-client-position backend :monocle)
            :front))
    (is (eq (lime.x11::configured-close-focus-direction backend :monocle)
            :next))
    (setf (lime.x11::x11-backend-configuration backend) config-dsl-fixture)
    ;; The fixture's ordinary policy applies to master/stack and manual; its
    ;; explicit monocle entry overrides only monocle.
    (is (eq (lime.x11::configured-new-tiled-client-position
             backend :master-stack)
            :front))
    (is (eq (lime.x11::configured-close-focus-direction
             backend :master-stack)
            :next))
    (is (eq (lime.x11::configured-new-tiled-client-position backend :monocle)
            :back))
    (is (eq (lime.x11::configured-close-focus-direction backend :monocle)
            :previous))))

(test configured-commands-power-both-direct-search-and-which-key
  (let ((backend (make-head-bar-fixture))
        (*configured-command-runs* 0))
    (setf (lime.x11::x11-backend-configuration backend) config-dsl-fixture)
    (let* ((candidate (first (lime.x11::configuration-command-candidates backend)))
           (result (funcall (ui-candidate-action candidate))))
      (is (equal (ui-candidate-id candidate) '(:configured-command terminal)))
      (is (equal (ui-candidate-label candidate) "Command: Terminal"))
      (is (= *configured-command-runs* 1))
      (is (eq (ui-result-kind result) :close)))
    (let ((session (make-ui-session '()
                                    :key-path (lime.x11::%ui-key-path backend))))
      (ui-session-handle-key session :tab)
      (let ((user-node (find :user-commands (ui-session-key-nodes session)
                             :key #'ui-key-node-id)))
        (is-true user-node)
        (is (equal (mapcar #'ui-key-node-key (ui-key-node-children user-node))
                   '(#\t)))))))

(test palette-offers-a-dmenu-like-run-prompt-and-starter-launches
  (let* ((backend (make-head-bar-fixture))
         (candidates (lime.x11::%command-palette-candidates backend)))
    (is (find :run-shell-command candidates :key #'ui-candidate-id))
    (is (find :launch-terminal candidates :key #'ui-candidate-id))
    (is (find :launch-browser candidates :key #'ui-candidate-id))
    (let ((session (make-ui-session '()
                                    :key-path (lime.x11::%ui-key-path backend))))
      (ui-session-handle-key session :tab)
      (ui-session-handle-key session #\r)
      (is (find :run-command (ui-session-key-nodes session)
                :key #'ui-key-node-id)))))

(test hiding-and-showing-activity-clients-update-only-the-live-draft
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (presentation (current-presentation world "main"))
         (apply-symbol 'lime.x11:apply-active-presentation)
         (original-apply (symbol-function apply-symbol)))
    ;; Command tests use the real core/model and command surfaces, but replace
    ;; the one CLX execution seam.  A separate nested-X test covers actual
    ;; map/unmap; this fixture keeps state semantics deterministic.
    (unwind-protect
         (progn
           (setf (symbol-function apply-symbol)
                 (lambda (ignored-backend)
                   (declare (ignore ignored-backend))
                   backend))
           (backend-hide-focused-client backend)
           (is (equal (presentation-client-ids presentation) '("terminal")))
           (is (equal (getf (backend-status backend) :hidden-client-ids)
                      '("editor" "browser")))
           (is-false (lease-for-client world "editor"))
           (is (equal (presentation-focus-client-id presentation) "terminal"))
           (let ((show-editor
                   (find '(:show-hidden-client "editor")
                         (lime.x11::%ui-hidden-client-candidates backend)
                         :key #'ui-candidate-id :test #'equal)))
             (is-true show-editor)
             (is (equal (ui-candidate-label show-editor) "Show: Editor")))
           (backend-show-client backend "editor")
           (is (equal (presentation-client-ids presentation)
                      '("terminal" "editor")))
           (is (equal (presentation-focus-client-id presentation) "editor"))
           (is (equal (getf (backend-status backend) :hidden-client-ids)
                      '("browser")))
           (let* ((key-root (lime.x11::%ui-key-path backend))
                  (window-node (find :window key-root :key #'ui-key-node-id))
                  (activity-node (find :activity key-root :key #'ui-key-node-id)))
             (is-true (find :hide-focused-client (ui-key-node-children window-node)
                            :key #'ui-key-node-id))
             (is-true (find :show-hidden-client (ui-key-node-children window-node)
                            :key #'ui-key-node-id))
             (is-false (find :show-hidden-client (ui-key-node-children activity-node)
                             :key #'ui-key-node-id))))
      (setf (symbol-function apply-symbol) original-apply))))

(test showing-a-hidden-client-can-explicitly-take-its-lease-from-another-head
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (heads (lime.x11::x11-backend-heads backend))
         (source (current-presentation world "main"))
         (apply-symbol 'lime.x11:apply-active-presentation)
         (original-apply (symbol-function apply-symbol)))
    (setf (gethash "other" heads)
          (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
          (lime.x11::x11-backend-head-ids backend) '("main" "other"))
    (create-head world "other")
    (let ((target (open-activity-draft world "other" "development")))
      (unwind-protect
           (progn
             (setf (symbol-function apply-symbol)
                   (lambda (ignored-backend)
                     (declare (ignore ignored-backend))
                     backend))
             ;; Editor begins visible on main and absent from the other draft.
             ;; The taking command must make the cross-Head move explicit,
             ;; without pretending the same real X window can appear twice.
             (backend-show-client-taking backend "editor" :head-id "other")
             (is (equal (lease-presentation-id (lease-for-client world "editor"))
                        (presentation-id target)))
             (is (member "editor" (presentation-client-ids target) :test #'equal))
             (is (equal (presentation-focus-client-id target) "editor"))
             (is-false (member "editor" (presentation-client-ids source) :test #'equal))
             (is (equal (presentation-focus-client-id source) "terminal")))
        (setf (symbol-function apply-symbol) original-apply)))))

(test path-program-picker-exposes-one-safe-launch-candidate-per-program
  (let ((backend (make-head-bar-fixture))
        (function-name 'lime.x11::%path-program-names))
    (let ((original-function (symbol-function function-name)))
      (unwind-protect
           (progn
             (setf (symbol-function function-name)
                   (lambda () '("emacs" "st" "waterfox")))
             (let ((candidates (lime.x11::%ui-program-launch-candidates backend)))
               (is (equal (mapcar #'ui-candidate-id candidates)
                          '((:program "emacs") (:program "st") (:program "waterfox"))))
               (is (equal (mapcar #'ui-candidate-detail candidates)
                          '("PATH executable" "PATH executable"
                            "Waterfox (normal profile)")))))
        (setf (symbol-function function-name) original-function)))))

(test program-catalog-normalization-is-distinct-and-alphabetical
  (is (equal '("emacs" "st" "waterfox")
             (lime.x11::%normalize-program-names '("st" nil "waterfox" "" "st" 42 "emacs")))))

(test program-catalog-cache-invalidation-and-empty-results
  (let ((lime.x11::*path-program-cache* nil)
        (signature '("path-a" "cwd-a" (1 2)))
        (programs '("emacs" "st")) (scans 0)
        (original-signature (symbol-function 'lime.x11::%path-program-signature))
        (original-scan (symbol-function 'lime.x11::%scan-path-program-names)))
    (unwind-protect
         (progn
           (setf (symbol-function 'lime.x11::%path-program-signature) (lambda () signature)
                 (symbol-function 'lime.x11::%scan-path-program-names) (lambda () (incf scans) programs))
           (is (equal programs (lime.x11::%path-program-names)))
           (is (equal programs (lime.x11::%path-program-names)))
           (is (= 1 scans))
           (setf (car (lime.x11::%path-program-names)) "changed by caller")
           (is (equal programs (lime.x11::%path-program-names)))
           (dolist (new-signature '(("path-b" "cwd-a" (1 2))
                                    ("path-b" "cwd-b" (1 2))
                                    ("path-b" "cwd-b" (1 3))))
             (setf signature new-signature)
             (lime.x11::%path-program-names))
           (is (= 4 scans))
           (lime.x11::%path-program-names :refresh-p t)
           (is (= 5 scans))
           (decf (getf lime.x11::*path-program-cache* :time) (* 301 internal-time-units-per-second))
           (lime.x11::%path-program-names)
           (is (= 6 scans))
           (setf programs nil)
           (is-false (lime.x11::%path-program-names :refresh-p t))
           (is-false (lime.x11::%path-program-names))
           (is (= 7 scans)))
      (setf (symbol-function 'lime.x11::%path-program-signature) original-signature
            (symbol-function 'lime.x11::%scan-path-program-names) original-scan))))

(test shortcut-dispatch-always-releases-queued-keyboard-events
  (dolist (outcome '(:success :error :missing :nonlocal))
    (let* ((backend (make-head-bar-fixture)) (calls nil)
           (allow (symbol-function 'xlib:allow-events))
           (flush (symbol-function 'xlib:display-force-output)))
      (setf (lime.x11::x11-backend-display backend) :fake-display)
      (unless (eq outcome :missing)
        (setf (gethash (cons 42 64) (lime.x11::x11-backend-keybindings backend))
              (lime.x11::make-keybinding
               :handler (lambda (b) (declare (ignore b))
                          (case outcome (:error (error "test failure"))
                            (:nonlocal (throw 'dispatch-done :left)))))))
      (unwind-protect
           (progn
             (setf (symbol-function 'xlib:allow-events)
                   (lambda (display mode &optional time) (declare (ignore time))
                     (push (list display mode) calls))
                   (symbol-function 'xlib:display-force-output)
                   (lambda (display) (push (list display :flush) calls)))
             (catch 'dispatch-done (lime.x11::%handle-key-press backend 42 64))
             (is (equal '((:fake-display :flush) (:fake-display :async-keyboard)) calls))
             (is (eq (eq outcome :error) (not (null (backend-last-command-error backend))))))
        (setf (symbol-function 'xlib:allow-events) allow
              (symbol-function 'xlib:display-force-output) flush)))))

(test browser-launch-defaults-to-normal-profile-and-isolation-is-explicit
  (let ((original-launch (symbol-function 'backend-launch-program))
        (original-profile (symbol-function 'lime.x11::%lime-browser-profile-directory))
        (profile-requests 0)
        (launched nil))
    (unwind-protect
         (progn
           ;; Do not spawn a browser or create/write an actual profile.
           (setf (symbol-function 'backend-launch-program)
                 (lambda (backend argv) (declare (ignore backend)) (setf launched argv))
                 (symbol-function 'lime.x11::%lime-browser-profile-directory)
                 (lambda () (incf profile-requests) "/tmp/lime-test-profile/"))
           (backend-launch-browser nil)
           (is (equal '("waterfox") launched))
           (is (zerop profile-requests))
           (backend-launch-browser nil :test-profile-p t)
           (is (equal '("waterfox" "--new-instance" "--profile" "/tmp/lime-test-profile/") launched))
           (is (= 1 profile-requests)))
      (setf (symbol-function 'backend-launch-program) original-launch
            (symbol-function 'lime.x11::%lime-browser-profile-directory) original-profile))))

(test launcher-rejects-blank-shell-commands-before-starting-a-process
  (signals invalid-transition
    (lime.x11::%nonblank-launch-command (format nil "  ~C " #\Tab)))
  (is (equal (lime.x11::%nonblank-launch-command " st -e htop ")
             "st -e htop")))

(test input-registers-lock-insensitive-variants-of-a-binding-state
  (let* ((base-state (xlib:make-state-mask :mod-4 :shift))
         (variants (lime.x11::%input-state-variants base-state)))
    (is (= (length variants) 4))
    (is (member base-state variants))
    (is (member (logior base-state (xlib:make-state-mask :lock)) variants))
    (is (member (logior base-state (xlib:make-state-mask :mod-2)) variants))
    (is (member (logior base-state
                        (xlib:make-state-mask :lock :mod-2))
                variants))))

(test graceful-quit-is-a-command-request-and-a-palette-entry
  (let ((backend (make-head-bar-fixture)))
    ;; The command changes only the event-loop flag.  Its owner performs the
    ;; actual CLX/root cleanup after the current X event has finished.
    (setf (lime.x11::x11-backend-running-p backend) t)
    (is (eq (backend-request-quit backend) backend))
    (is-false (lime.x11::x11-backend-running-p backend))
    (let ((candidate (find :quit-lime
                           (lime.x11::%command-palette-candidates backend)
                           :key #'ui-candidate-id)))
      (is-true candidate)
      (is (equal (ui-candidate-label candidate) "Quit Lime"))
      (is (eq (ui-result-kind (funcall (ui-candidate-action candidate))) :close)))
    (let ((session (make-ui-session '()
                                    :key-path (lime.x11::%ui-key-path backend))))
      (ui-session-handle-key session :tab)
      (ui-session-handle-key session #\q)
      (is (find :quit-lime (ui-session-key-nodes session)
                :key #'ui-key-node-id)))))

(test window-rules-use-the-first-icccm-match-without-changing-an-activity
  (let* ((backend (make-head-bar-fixture))
         (info (lime.x11::make-icccm-client-info
                :client-id "player" :resource-name "mpv" :resource-class "mpv"
                :title "movie")))
    (setf (lime.x11::x11-backend-configuration backend) config-dsl-fixture
          (gethash "player" (lime.x11::x11-backend-icccm-clients backend)) info)
    (let ((rule (lime.x11::%matching-window-rule backend "player" info)))
      (is (eq (window-rule-id rule) 'mpv))
      (is-true (window-rule-float-p rule))
      (is-true (window-rule-center-p rule)))))

(test loading-a-configuration-file-records-one-reloadable-definition
  (multiple-value-bind (configuration name)
      (load-lime-configuration
       (merge-pathnames "test/config-fixture.lisp"
                        (asdf:system-source-directory "lime/x11")))
    (is (eq name 'config-file-fixture))
    (is (typep configuration 'lime-configuration))
    ;; The no-:OPTIONS default is the normal Super modifier list, not quoted
    ;; source data accidentally left unevaluated by the macro.
    (is (equal (lime-configuration-default-modifiers configuration) '(:mod-4)))
    (is (eq :master-stack (lime-configuration-default-layout configuration)))
    (is-true (lime-configuration-new-client-focus-p configuration))
    (is (eq (lime-configuration-new-tiled-client-position configuration) :back))
    (is (eq (lime-configuration-close-focus-direction configuration) :previous))
    (is (equal (mapcar #'lime-command-id
                       (lime-configuration-commands configuration))
               '(reload)))))

(test randr-groups-cloned-outputs-into-one-logical-head
  (flet ((output (id name crtc connection x y width height)
           (lime.x11::make-x11-randr-output
            :output-id id :name name :crtc-id crtc :connection connection
            :x x :y y :width width :height height)))
    (let ((heads
            (lime.x11::%x11-randr-heads-from-outputs
             (list
              (output 101 "DP-1" 11 :connected 0 0 1920 1080)
              ;; HDMI-1 mirrors DP-1 through the same CRTC: one physical
              ;; rectangle must never become two overlapping Lime Heads.
              (output 102 "HDMI-1" 11 :connected 0 0 1920 1080)
              (output 201 "DP-3" 12 :connected 1920 0 1920 1080)
              (output 301 "DP-4" 0 :disconnected 0 0 0 0))
             201)))
      (is (equal (mapcar #'x11-head-head-id heads) '("DP-1" "DP-3")))
      (let ((left (first heads))
            (right (second heads)))
        (is (equal (x11-head-output-ids left) '(101 102)))
        (is (= (x11-head-width left) 1920))
        (is (= (x11-head-x right) 1920))
        ;; The primary output is retained as its own representative Head.
        (is (= (x11-head-output-id right) 201))))))

(test randr-topology-report-keeps-choice-separate-from-application
  (let ((world (make-world)))
    (create-head world "left")
    (create-head world "right")
    (create-activity world "lime" "Lime")
    (create-client world "emacs" "lime")
    (create-client world "firefox" "lime")
    (create-view world "code" "lime" "Code"
                 (list (make-placement :client-id "emacs")))
    (create-view world "browser" "lime" "Browser"
                 (list (make-placement :client-id "firefox")))
    (activate-view-strictly world "left" "code")
    (let* ((browser (activate-view-strictly world "right" "browser"))
           (backend
             (lime.x11::%make-x11-backend
              :world world
              :head-source :randr
              :randr-topology
              (lime.x11::make-x11-randr-topology
               :heads (list (make-x11-head :head-id "left" :x 0 :y 0
                                           :width 1000 :height 700)
                            (make-x11-head :head-id "dock" :x 1000 :y 0
                                           :width 1000 :height 700)))))
           (snapshot (backend-randr-topology-report backend))
           (report (getf snapshot :report))
           (plan
             (backend-build-randr-topology-plan
              backend
              :moves (list (make-head-topology-move
                            :from-head-id "right" :to-head-id "dock")))))
      (is (typep report 'head-topology-report))
      (is (equal (getf snapshot :added-head-ids) '("dock")))
      (is (equal (getf snapshot :removed-head-ids) '("right")))
      (is (equal (mapcar #'head-topology-source-presentation-id
                         (getf snapshot :removed-active-sources))
                 (list (presentation-id browser))))
      ;; Building the plan is read-only: a palette/IPC caller can still cancel.
      (is (current-presentation world "right"))
      (is (equal (mapcar #'head-topology-move-to-head-id
                         (head-topology-plan-moves plan))
                 '("dock"))))))

(test backend-status-describes-a-deliberately-blank-head
  (let* ((world (make-world))
         (heads (make-hash-table :test #'equal))
         (backend
           (lime.x11::%make-x11-backend
            :world world :head-id "new" :focused-head-id "new"
            :heads heads :head-ids '("new"))))
    (create-head world "new")
    (setf (gethash "new" heads)
          (make-x11-head :head-id "new" :x 0 :y 0 :width 800 :height 600))
    (let ((status (backend-status backend)))
      (is-true (getf status :blank-p))
      (is-false (getf status :activity-id))
      (is-false (getf status :leased-client-ids)))))

(defun make-randr-palette-fixture ()
  "Build a pending physical-topology change without requiring an X server."
  (let* ((world (make-world))
         (heads (make-hash-table :test #'equal)))
    (create-head world "left")
    (create-head world "right")
    (create-activity world "lime" "Lime")
    (create-client world "emacs" "lime")
    (create-client world "firefox" "lime")
    (create-view world "code" "lime" "Code"
                 (list (make-placement :client-id "emacs")))
    (create-view world "browser" "lime" "Browser"
                 (list (make-placement :client-id "firefox")))
    (activate-view-strictly world "left" "code")
    (activate-view-strictly world "right" "browser")
    (setf (gethash "left" heads)
          (make-x11-head :head-id "left" :x 0 :y 0 :width 1000 :height 700)
          (gethash "right" heads)
          (make-x11-head :head-id "right" :x 1000 :y 0 :width 1000 :height 700))
    (lime.x11::%make-x11-backend
     :world world :head-id "left" :activity-id "lime" :focused-head-id "left"
     :heads heads :head-ids '("left" "right") :head-source :randr
     :randr-topology-dirty-p t
     :randr-topology
     (lime.x11::make-x11-randr-topology
      :heads (list (make-x11-head :head-id "left" :x 0 :y 0
                                  :width 1000 :height 700)
                   (make-x11-head :head-id "dock" :x 1000 :y 0
                                  :width 1000 :height 700))))))

(test randr-palette-offers-explicit-move-or-suspend-choices
  (let* ((backend (make-randr-palette-fixture))
         (direct-candidate
           (find :reconcile-randr-topology
                 (lime.x11::%command-palette-candidates backend)
                 :key #'ui-candidate-id))
         (choice-result (funcall (ui-candidate-action direct-candidate)))
         (choice-labels (mapcar #'ui-candidate-label
                                (ui-result-candidates choice-result))))
    (is-true direct-candidate)
    (is (eq (ui-result-kind choice-result) :replace))
    (is (member "Move to left" choice-labels :test #'equal))
    (is (member "Move to dock" choice-labels :test #'equal))
    (is (member "Suspend safely" choice-labels :test #'equal))
    (let* ((suspend-candidate
             (find "Suspend safely" (ui-result-candidates choice-result)
                   :key #'ui-candidate-label :test #'equal))
           (final-result (funcall (ui-candidate-action suspend-candidate))))
      (is (eq (ui-result-kind final-result) :replace))
      (is (find "Apply display plan" (ui-result-candidates final-result)
                :key #'ui-candidate-label :test #'equal)))
    (let ((session (make-ui-session '()
                                    :key-path (lime.x11::%ui-key-path backend))))
      (ui-session-handle-key session :tab)
      (ui-session-handle-key session #\h)
      (is (find :reconcile-randr-topology (ui-session-key-nodes session)
                :key #'ui-key-node-id))
      (is (eq (ui-result-kind (ui-session-handle-key session #\t)) :replace)))))

(test viewsets-appear-in-the-command-and-which-key-surfaces
  (let* ((backend (make-randr-palette-fixture))
         (viewset (backend-save-viewset backend "work-desk" "Work desk"))
         (candidate (find (list :viewset "work-desk")
                          (lime.x11::%command-palette-candidates backend)
                          :key #'ui-candidate-id :test #'equal)))
    ;; Capture is a mapping of durable source Views, never a serialization of
    ;; the mutable Presentations currently mounted on these Heads.
    (is (equal (viewset-name viewset) "Work desk"))
    (is (equal (mapcar #'viewset-entry-head-id (viewset-entries viewset))
               '("left" "right")))
    (is (equal (mapcar #'viewset-entry-view-id (viewset-entries viewset))
               '("code" "browser")))
    (is-true candidate)
    (is (equal (ui-candidate-label candidate) "Viewset: Work desk"))
    (is (search "left -> Lime / Code" (ui-candidate-detail candidate)))
    (let ((session (make-ui-session '()
                                    :key-path (lime.x11::%ui-key-path backend))))
      (ui-session-handle-key session :tab)
      (is (find :viewset (ui-session-key-nodes session)
                :key #'ui-key-node-id))
      (ui-session-handle-key session #\x)
      (is (find :open-viewset (ui-session-key-nodes session)
                :key #'ui-key-node-id)))))

(test super-y-builds-a-which-key-root-without-changing-the-world
  (let* ((backend (make-head-bar-fixture))
         (world (lime.x11::x11-backend-world backend))
         (revision (world-revision world))
         (session (lime.x11::%make-command-menu-session backend))
         (entries (lime.x11::%ui-menu-entries session)))
    (is (eq :key-path (ui-session-mode session)))
    (is-false (ui-session-candidates session))
    (is (find "+Windows" entries :key (lambda (entry) (getf entry :label)) :test #'equal))
    (is (find "SPC" entries :key (lambda (entry) (getf entry :key)) :test #'equal))
    (ui-session-handle-key session #\w)
    (is (string= "Lime  ›  w Windows" (lime.x11::%ui-menu-heading session)))
    (is (find :hide-focused-client (ui-session-key-nodes session) :key #'ui-key-node-id))
    (ui-session-handle-key session :backspace)
    (is (string= "Lime" (lime.x11::%ui-menu-heading session)))
    (ui-session-handle-key session #\Space)
    (is (eq :search (ui-session-mode session)))
    (is (= revision (world-revision world)))))

(test which-key-grid-is-compact-paged-and-bounded-by-its-head
  (let ((entries (loop for i below 41 collect (list :key "x" :label (format nil "Command ~D" i)))))
    (let ((wide (lime.x11::%ui-key-grid-layout (subseq entries 0 9) 1600 500 28 #'bar-test-text-width)))
      (is (= 4 (getf wide :columns)))
      (is (= 3 (getf wide :rows)))
      (is (< (getf wide :height) 200)))
    (dolist (width '(1 100 320 1000 1600))
      (dolist (height '(1 70 240 500))
        (let* ((layout (lime.x11::%ui-key-grid-layout entries width height 28 #'bar-test-text-width))
               (shown nil))
          (is (<= 1 (getf layout :height) height))
          (is (<= 0 (+ (* 2 (getf layout :padding))
                       (* (getf layout :columns) (getf layout :cell-width))
                       (* (1- (getf layout :columns)) (getf layout :gap))) width))
          (when (plusp (getf layout :capacity))
            (dotimes (page (getf layout :page-count))
              (let ((part (lime.x11::%ui-key-grid-layout entries width height 28 #'bar-test-text-width page)))
                (setf shown (append shown (subseq entries (getf part :start) (getf part :end))))))
            (is (equal entries shown)))
          (let ((last (lime.x11::%ui-key-grid-layout entries width height 28 #'bar-test-text-width 999)))
            (is (= (1- (getf last :page-count)) (getf last :page)))))))))

(defun run-tests ()
  (run! 'lime-x11-suite))